module Language.Fay.ModuleScope
(ModuleScope
,bindAsLocals
,findTopLevelNames
,resolveName
,moduleLocals)
where
import Control.Arrow
import Control.Monad.Reader
import Control.Monad.Writer
import Data.Default
import Data.Map (Map)
import qualified Data.Map as M
import Language.Haskell.Exts hiding (name, binds)
import Prelude hiding (mod)
newtype ModuleScope = ModuleScope (Map QName QName)
deriving Show
instance Monoid ModuleScope where
mempty = ModuleScope M.empty
mappend (ModuleScope a) (ModuleScope b) = ModuleScope $ a `M.union` b
instance Default ModuleScope where
def = mempty
resolveName :: QName -> ModuleScope -> Maybe QName
resolveName q (ModuleScope binds) = case M.lookup q binds of
Just q'@(Qual (ModuleName "Prelude") n) -> case M.lookup n envPrimOpsMap of
Just x -> Just x
Nothing -> Just q'
Nothing -> case q of
UnQual n -> M.lookup n envPrimOpsMap
_ -> Nothing
j -> j
bindAsLocals :: [QName] -> ModuleScope -> ModuleScope
bindAsLocals qs (ModuleScope binds) =
ModuleScope $ M.fromList (map (unqual &&& id) qs) `M.union` binds
where unqual (Qual _ n) = (UnQual n)
unqual u@UnQual{} = u
unqual Special{} = error "fay: ModuleScope.bindAsLocals: Special"
moduleLocals :: ModuleName -> ModuleScope -> [QName]
moduleLocals mod (ModuleScope binds) = filter isLocal . M.elems $ binds
where
isLocal (Qual m _) = mod == m
isLocal _ = False
envPrimOpsMap :: Map Name QName
envPrimOpsMap = M.fromList
[ (Symbol ">>", (Qual (ModuleName "Fay$") (Ident "then")))
, (Symbol ">>=", (Qual (ModuleName "Fay$") (Ident "bind")))
, (Ident "return", (Qual (ModuleName "Fay$") (Ident "return")))
, (Ident "force", (Qual (ModuleName "Fay$") (Ident "force")))
, (Ident "seq", (Qual (ModuleName "Fay$") (Ident "seq")))
, (Symbol "*", (Qual (ModuleName "Fay$") (Ident "mult")))
, (Symbol "+", (Qual (ModuleName "Fay$") (Ident "add")))
, (Symbol "-", (Qual (ModuleName "Fay$") (Ident "sub")))
, (Symbol "/", (Qual (ModuleName "Fay$") (Ident "div")))
, (Symbol "==", (Qual (ModuleName "Fay$") (Ident "eq")))
, (Symbol "/=", (Qual (ModuleName "Fay$") (Ident "neq")))
, (Symbol ">", (Qual (ModuleName "Fay$") (Ident "gt")))
, (Symbol "<", (Qual (ModuleName "Fay$") (Ident "lt")))
, (Symbol ">=", (Qual (ModuleName "Fay$") (Ident "gte")))
, (Symbol "<=", (Qual (ModuleName "Fay$") (Ident "lte")))
, (Symbol "&&", (Qual (ModuleName "Fay$") (Ident "and")))
, (Symbol "||", (Qual (ModuleName "Fay$") (Ident "or")))
]
type ModuleScopeSt = ReaderT ModuleName (Writer ModuleScope) ()
findTopLevelNames :: ModuleName -> [Decl] -> ModuleScope
findTopLevelNames mod decls = snd . runWriter $ runReaderT (mapM_ d_decl decls) mod
bindName :: Name -> ModuleScopeSt
bindName k = ask >>= \mod -> tell (ModuleScope $ M.singleton (UnQual k) (Qual mod k))
d_decl :: Decl -> ModuleScopeSt
d_decl d = case d of
DataDecl _ _ _ _ _ dd _ -> mapM_ d_qualCon dd
PatBind _ (PVar n) _ _ _ -> bindName n
FunBind (Match _ n _ _ _ _ : _) -> bindName n
ClassDecl _ _ _ _ _ cds -> mapM_ d_classDecl cds
TypeSig _ ns _ -> mapM_ bindName ns
_ -> return ()
d_classDecl :: ClassDecl -> ModuleScopeSt
d_classDecl cd = case cd of
ClsDecl d -> d_decl d
_ -> return ()
d_qualCon :: QualConDecl -> ModuleScopeSt
d_qualCon (QualConDecl _ _ _ cd) = case cd of
ConDecl n _ -> bindName n
InfixConDecl _ n _ -> bindName n
RecDecl n ns -> bindName n >> mapM_ bindName (concatMap fst ns)