{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}
-- | Export-list resolution on the HSE AST, used by the embedder
--   (Embedder.HSE.ToAtmo).
module ReWire.HSE.Exports
      ( Export (..)
      , sDeclHead
      , exportAll
      , getExportFixities
      , transExport
      , tysynNames
      , getTypeExports
      , resolveExports
      , getInlines
      ) where

import ReWire.Annotation (Annote)
import ReWire.Error (failAt, MonadError, AstError)
import ReWire.HSE.Fixity (getFixities)
import ReWire.HSE.Rename

import Control.Monad (void)
import Data.Char (isUpper)
import Data.Map.Strict (Map)
import Data.Set (Set)
import Language.Haskell.Exts.Fixity (Fixity (..))

import qualified Data.Set                     as Set
import qualified Data.Map.Strict              as Map
import qualified Language.Haskell.Exts.Syntax as S

import Language.Haskell.Exts.Syntax hiding (Annotation, Name, Kind)

-- | An intermediate form for exports. TODO(chathhorn): get rid of it.
data Export = Export FQName
            -- | ExportWith: Type name, ctors
            | ExportWith FQName (Set FQName) FQCtorSigs
            | ExportAll FQName
            | ExportMod (S.ModuleName ())
            | ExportFixity (S.Assoc ()) Int (S.Name ())
      deriving Int -> Export -> ShowS
[Export] -> ShowS
Export -> String
(Int -> Export -> ShowS)
-> (Export -> String) -> ([Export] -> ShowS) -> Show Export
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Export -> ShowS
showsPrec :: Int -> Export -> ShowS
$cshow :: Export -> String
show :: Export -> String
$cshowList :: [Export] -> ShowS
showList :: [Export] -> ShowS
Show

sDeclHead :: S.DeclHead a -> (S.Name (), [S.TyVarBind ()])
sDeclHead :: forall a. DeclHead a -> (Name (), [TyVarBind ()])
sDeclHead = \ case
      DHead a
_ Name a
n                          -> (Name a -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name a
n, [])
      DHInfix a
_ TyVarBind a
tv Name a
n                     -> (Name a -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name a
n, [TyVarBind a -> TyVarBind ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void TyVarBind a
tv])
      DHParen a
_ DeclHead a
dh                       -> DeclHead a -> (Name (), [TyVarBind ()])
forall a. DeclHead a -> (Name (), [TyVarBind ()])
sDeclHead DeclHead a
dh
      DHApp a
_ (DeclHead a -> (Name (), [TyVarBind ()])
forall a. DeclHead a -> (Name (), [TyVarBind ()])
sDeclHead -> (Name ()
n, [TyVarBind ()]
tvs)) TyVarBind a
tv -> (Name ()
n, [TyVarBind ()]
tvs [TyVarBind ()] -> [TyVarBind ()] -> [TyVarBind ()]
forall a. [a] -> [a] -> [a]
++ [TyVarBind a -> TyVarBind ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void TyVarBind a
tv])

exportAll :: QNamish a => Renamer -> a -> Export
exportAll :: forall a. QNamish a => Renamer -> a -> Export
exportAll Renamer
rn a
x = let x' :: FQName
x' = Namespace -> Renamer -> a -> FQName
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Type Renamer
rn a
x in
      FQName -> Set FQName -> FQCtorSigs -> Export
ExportWith FQName
x' (Renamer -> FQName -> Set FQName
forall a. QNamish a => Renamer -> a -> Set FQName
lookupCtors Renamer
rn FQName
x') (Renamer -> FQName -> FQCtorSigs
forall a. QNamish a => Renamer -> a -> FQCtorSigs
lookupCtorSigsForType Renamer
rn FQName
x')

getExportFixities :: [Decl Annote] -> [Export]
getExportFixities :: [Decl Annote] -> [Export]
getExportFixities = (Fixity -> Export) -> [Fixity] -> [Export]
forall a b. (a -> b) -> [a] -> [b]
map Fixity -> Export
toExportFixity ([Fixity] -> [Export])
-> ([Decl Annote] -> [Fixity]) -> [Decl Annote] -> [Export]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Decl Annote] -> [Fixity]
forall a. [Decl a] -> [Fixity]
getFixities
      where toExportFixity :: Fixity -> Export
            toExportFixity :: Fixity -> Export
toExportFixity (Fixity Assoc ()
asc Int
lvl (S.UnQual () Name ()
n)) = Assoc () -> Int -> Name () -> Export
ExportFixity Assoc ()
asc Int
lvl Name ()
n
            toExportFixity Fixity
_                                = Export
forall a. HasCallStack => a
undefined

transExport :: MonadError AstError m => Renamer -> [Decl Annote] -> [Export] -> ExportSpec Annote -> m [Export]
transExport :: forall (m :: * -> *).
MonadError AstError m =>
Renamer
-> [Decl Annote] -> [Export] -> ExportSpec Annote -> m [Export]
transExport Renamer
rn [Decl Annote]
ds [Export]
exps = \ case
      EVar Annote
l (QName Annote -> QName ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void -> QName ()
x)                 ->
            if Namespace -> Renamer -> QName () -> Bool
forall a. QNamish a => Namespace -> Renamer -> a -> Bool
finger Namespace
Value Renamer
rn QName ()
x
            then [Export] -> m [Export]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Export] -> m [Export]) -> [Export] -> m [Export]
forall a b. (a -> b) -> a -> b
$ FQName -> Export
Export (Namespace -> Renamer -> QName () -> FQName
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn QName ()
x) Export -> [Export] -> [Export]
forall a. a -> [a] -> [a]
: Name () -> [Export]
fixities (QName () -> Name ()
forall a b. (QNamish a, QNamish b) => a -> b
qnamish QName ()
x) [Export] -> [Export] -> [Export]
forall a. [a] -> [a] -> [a]
++ [Export]
exps
            else Annote -> Text -> m [Export]
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l Text
"Unknown variable name in export list"
      -- TODO(chathhorn): Ignore type exports.
      -- This is to ease compatibility with GHC -- we can have built-in type
      -- operators while ignoring parts exported from GHC.TypeLits in the
      -- RWC.Primitives module.
      EAbs Annote
_ (TypeNamespace Annote
_) QName Annote
_         -> [Export] -> m [Export]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Export]
exps
      EAbs Annote
l Namespace Annote
_ (QName Annote -> QName ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void -> QName ()
x)               ->
            if Namespace -> Renamer -> QName () -> Bool
forall a. QNamish a => Namespace -> Renamer -> a -> Bool
finger Namespace
Type Renamer
rn QName ()
x
            then [Export] -> m [Export]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Export] -> m [Export]) -> [Export] -> m [Export]
forall a b. (a -> b) -> a -> b
$ FQName -> Export
Export (Namespace -> Renamer -> QName () -> FQName
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Type Renamer
rn QName ()
x) Export -> [Export] -> [Export]
forall a. a -> [a] -> [a]
: [Export]
exps
            else Annote -> Text -> m [Export]
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l Text
"Unknown class or type name in export list"
      EThingWith Annote
l (NoWildcard Annote
_) (QName Annote -> QName ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void -> QName ()
x) [CName Annote]
cs       -> let cs' :: Set FQName
cs' = [FQName] -> Set FQName
forall a. Ord a => [a] -> Set a
Set.fromList ([FQName] -> Set FQName) -> [FQName] -> Set FQName
forall a b. (a -> b) -> a -> b
$ (CName Annote -> FQName) -> [CName Annote] -> [FQName]
forall a b. (a -> b) -> [a] -> [b]
map (Namespace -> Renamer -> Name () -> FQName
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn (Name () -> FQName)
-> (CName Annote -> Name ()) -> CName Annote -> FQName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CName Annote -> Name ()
unwrap) [CName Annote]
cs in
            if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ Namespace -> Renamer -> QName () -> Bool
forall a. QNamish a => Namespace -> Renamer -> a -> Bool
finger Namespace
Type Renamer
rn QName ()
x Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: (FQName -> Bool) -> [FQName] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Namespace -> Renamer -> Name () -> Bool
forall a. QNamish a => Namespace -> Renamer -> a -> Bool
finger Namespace
Value Renamer
rn (Name () -> Bool) -> (FQName -> Name ()) -> FQName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FQName -> Name ()
name) (Set FQName -> [FQName]
forall a. Set a -> [a]
Set.toList Set FQName
cs')
            then [Export] -> m [Export]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Export] -> m [Export]) -> [Export] -> m [Export]
forall a b. (a -> b) -> a -> b
$ FQName -> Set FQName -> FQCtorSigs -> Export
ExportWith (Namespace -> Renamer -> QName () -> FQName
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Type Renamer
rn QName ()
x) Set FQName
cs' ((FQName -> [(Maybe FQName, Type ())]) -> Set FQName -> FQCtorSigs
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (Renamer -> FQName -> [(Maybe FQName, Type ())]
forall a. QNamish a => Renamer -> a -> [(Maybe FQName, Type ())]
lookupCtorSig Renamer
rn) Set FQName
cs')
                  Export -> [Export] -> [Export]
forall a. a -> [a] -> [a]
: (CName Annote -> [Export]) -> [CName Annote] -> [Export]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name () -> [Export]
fixities (Name () -> [Export])
-> (CName Annote -> Name ()) -> CName Annote -> [Export]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CName Annote -> Name ()
unwrap) [CName Annote]
cs [Export] -> [Export] -> [Export]
forall a. [a] -> [a] -> [a]
++ [Export]
exps
            else Annote -> Text -> m [Export]
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l Text
"Unknown class or type name in export list"
      -- TODO(chathhorn): I don't know what it means for a wildcard to appear in the middle of an export list.
      EThingWith Annote
l (EWildcard Annote
_ Int
_) (QName Annote -> QName ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void -> QName ()
x) [CName Annote]
_       ->
            if Namespace -> Renamer -> QName () -> Bool
forall a. QNamish a => Namespace -> Renamer -> a -> Bool
finger Namespace
Type Renamer
rn QName ()
x
            then [Export] -> m [Export]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Export] -> m [Export]) -> [Export] -> m [Export]
forall a b. (a -> b) -> a -> b
$ Renamer -> QName () -> Export
forall a. QNamish a => Renamer -> a -> Export
exportAll Renamer
rn QName ()
x Export -> [Export] -> [Export]
forall a. a -> [a] -> [a]
: (FQName -> [Export]) -> [FQName] -> [Export]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name () -> [Export]
fixities (Name () -> [Export]) -> (FQName -> Name ()) -> FQName -> [Export]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FQName -> Name ()
name) (Set FQName -> [FQName]
forall a. Set a -> [a]
Set.toList (Set FQName -> [FQName]) -> Set FQName -> [FQName]
forall a b. (a -> b) -> a -> b
$ Renamer -> QName () -> Set FQName
forall a. QNamish a => Renamer -> a -> Set FQName
lookupCtors Renamer
rn QName ()
x) [Export] -> [Export] -> [Export]
forall a. [a] -> [a] -> [a]
++ [Export]
exps
            else Annote -> Text -> m [Export]
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l Text
"Unknown class or type name in export list"
      EModuleContents Annote
_ (ModuleName Annote -> ModuleName ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void -> ModuleName ()
m) ->
            [Export] -> m [Export]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Export] -> m [Export]) -> [Export] -> m [Export]
forall a b. (a -> b) -> a -> b
$ ModuleName () -> Export
ExportMod ModuleName ()
m Export -> [Export] -> [Export]
forall a. a -> [a] -> [a]
: [Export]
exps
      where unwrap :: CName Annote -> S.Name ()
            unwrap :: CName Annote -> Name ()
unwrap (VarName Annote
_ Name Annote
x) = Name Annote -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name Annote
x
            unwrap (ConName Annote
_ Name Annote
x) = Name Annote -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name Annote
x

            fixities :: S.Name () -> [Export]
            fixities :: Name () -> [Export]
fixities Name ()
n = ((Export -> Bool) -> [Export] -> [Export])
-> [Export] -> (Export -> Bool) -> [Export]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Export -> Bool) -> [Export] -> [Export]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Decl Annote] -> [Export]
getExportFixities [Decl Annote]
ds) ((Export -> Bool) -> [Export]) -> (Export -> Bool) -> [Export]
forall a b. (a -> b) -> a -> b
$ \ case
                  ExportFixity Assoc ()
_ Int
_ Name ()
n' -> Name ()
n Name () -> Name () -> Bool
forall a. Eq a => a -> a -> Bool
== Name ()
n'
                  Export
_                   -> Bool
False

tysynNames :: [Decl Annote] -> [S.Name ()]
tysynNames :: [Decl Annote] -> [Name ()]
tysynNames = (Decl Annote -> [Name ()]) -> [Decl Annote] -> [Name ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl Annote -> [Name ()]
tySynName
      where tySynName :: Decl Annote -> [S.Name ()]
            tySynName :: Decl Annote -> [Name ()]
tySynName = \ case
                  TypeDecl Annote
_ (DeclHead Annote -> (Name (), [TyVarBind ()])
forall a. DeclHead a -> (Name (), [TyVarBind ()])
sDeclHead -> (Name (), [TyVarBind ()])
hd) Type Annote
_ -> [(Name (), [TyVarBind ()]) -> Name ()
forall a b. (a, b) -> a
fst (Name (), [TyVarBind ()])
hd]
                  Decl Annote
_                              -> []

getTypeExports :: Renamer -> [Decl Annote] -> [Export]
getTypeExports :: Renamer -> [Decl Annote] -> [Export]
getTypeExports Renamer
rn [Decl Annote]
ds = (Name () -> Export) -> [Name ()] -> [Export]
forall a b. (a -> b) -> [a] -> [b]
map (Renamer -> Name () -> Export
forall a. QNamish a => Renamer -> a -> Export
exportAll Renamer
rn) ([Name ()] -> [Export]) -> [Name ()] -> [Export]
forall a b. (a -> b) -> a -> b
$ Set (Name ()) -> [Name ()]
forall a. Set a -> [a]
Set.toList (Renamer -> Set (Name ())
getLocalTypes Renamer
rn) [Name ()] -> [Name ()] -> [Name ()]
forall a. Semigroup a => a -> a -> a
<> [Decl Annote] -> [Name ()]
tysynNames [Decl Annote]
ds

resolveExports :: Renamer -> [Export] -> Exports
resolveExports :: Renamer -> [Export] -> Exports
resolveExports Renamer
rn = (Export -> Exports -> Exports) -> Exports -> [Export] -> Exports
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Renamer -> Export -> Exports -> Exports
resolveExport Renamer
rn) Exports
forall a. Monoid a => a
mempty
      where resolveExport :: Renamer -> Export -> Exports -> Exports
            resolveExport :: Renamer -> Export -> Exports -> Exports
resolveExport Renamer
rn = \ case
                  Export FQName
x              | FQName -> Bool
isValueName FQName
x -> FQName -> Exports -> Exports
expValue FQName
x
                  Export FQName
x                              -> FQName -> Set FQName -> FQCtorSigs -> Exports -> Exports
expType FQName
x Set FQName
forall a. Monoid a => a
mempty FQCtorSigs
forall a. Monoid a => a
mempty
                  ExportAll FQName
x                           -> FQName -> Set FQName -> FQCtorSigs -> Exports -> Exports
expType FQName
x (Renamer -> FQName -> Set FQName
forall a. QNamish a => Renamer -> a -> Set FQName
lookupCtors Renamer
rn FQName
x) (Renamer -> FQName -> FQCtorSigs
forall a. QNamish a => Renamer -> a -> FQCtorSigs
lookupCtorSigsForType Renamer
rn FQName
x)
                  ExportWith FQName
x Set FQName
cs FQCtorSigs
fs                    -> FQName -> Set FQName -> FQCtorSigs -> Exports -> Exports
expType FQName
x Set FQName
cs FQCtorSigs
fs
                  ExportMod ModuleName ()
m                           -> (Exports -> Exports -> Exports
forall a. Semigroup a => a -> a -> a
<> ModuleName () -> Renamer -> Exports
getExports ModuleName ()
m Renamer
rn)
                  ExportFixity Assoc ()
asc Int
lvl Name ()
x                -> Assoc () -> Int -> Name () -> Exports -> Exports
expFixity Assoc ()
asc Int
lvl Name ()
x

            isValueName :: FQName -> Bool
            isValueName :: FQName -> Bool
isValueName = \ case
                  (FQName -> Name ()
name -> Ident ()
_ (Char
c : String
_)) | Char -> Bool
isUpper Char
c -> Bool
False
                  FQName
_                                     -> Bool
True

-- | Collect INLINE/NOINLINE pragmas into a map from the pragma'd name to an
--   attribute built from the pragma's polarity (True for INLINE).
getInlines :: (Bool -> a) -> [Decl Annote] -> Map (S.Name ()) a
getInlines :: forall a. (Bool -> a) -> [Decl Annote] -> Map (Name ()) a
getInlines Bool -> a
attr = (Decl Annote -> Map (Name ()) a -> Map (Name ()) a)
-> Map (Name ()) a -> [Decl Annote] -> Map (Name ()) a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Decl Annote -> Map (Name ()) a -> Map (Name ()) a
forall {a}. Decl a -> Map (Name ()) a -> Map (Name ()) a
inl' Map (Name ()) a
forall a. Monoid a => a
mempty
      where inl' :: Decl a -> Map (Name ()) a -> Map (Name ()) a
inl' = \ case
                  InlineSig a
_ Bool
b Maybe (Activation a)
Nothing (Qual a
_ ModuleName a
_ Name a
x) -> Name () -> a -> Map (Name ()) a -> Map (Name ()) a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Name a -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name a
x) (a -> Map (Name ()) a -> Map (Name ()) a)
-> a -> Map (Name ()) a -> Map (Name ()) a
forall a b. (a -> b) -> a -> b
$ Bool -> a
attr Bool
b
                  InlineSig a
_ Bool
b Maybe (Activation a)
Nothing (UnQual a
_ Name a
x) -> Name () -> a -> Map (Name ()) a -> Map (Name ()) a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Name a -> Name ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Name a
x) (a -> Map (Name ()) a -> Map (Name ()) a)
-> a -> Map (Name ()) a -> Map (Name ()) a
forall a b. (a -> b) -> a -> b
$ Bool -> a
attr Bool
b
                  Decl a
_                                  -> Map (Name ()) a -> Map (Name ()) a
forall a. a -> a
id