module FreeC.Environment
(
Environment(..)
, emptyEnv
, makeModuleAvailable
, isModuleAvailable
, lookupAvailableModule
, addEntry
, defineDecArg
, removeDecArg
, modifyEntryIdent
, addEffectsToEntry
, lookupEntry
, encapsulatesEffects
, isFunction
, isVariable
, isPureVar
, lookupModName
, lookupIdent
, lookupSmartIdent
, usedIdents
, usedAgdaIdents
, lookupSrcSpan
, lookupTypeArgs
, lookupTypeArgArity
, lookupArgTypes
, lookupStrictArgs
, lookupReturnType
, lookupTypeScheme
, lookupArity
, lookupTypeSynonym
, needsFreeArgs
, hasEffect
, lookupEffects
, lookupDecArg
, lookupDecArgIndex
, lookupDecArgIdent
) where
import Data.Composition ( (.:), (.:.) )
import Data.List ( find )
import Data.Map.Strict ( Map )
import qualified Data.Map.Strict as Map
import Data.Maybe ( isJust )
import Data.Tuple.Extra ( (&&&) )
import qualified FreeC.Backend.Agda.Syntax as Agda
import qualified FreeC.Backend.Coq.Syntax as Coq
import FreeC.Environment.Entry
import FreeC.Environment.ModuleInterface
import FreeC.IR.SrcSpan
import qualified FreeC.IR.Syntax as IR
import FreeC.LiftedIR.Effect
import FreeC.Util.Predicate
data Environment = Environment
{ envAvailableModules :: Map IR.ModName ModuleInterface
, envEntries :: Map IR.ScopedName EnvEntry
, envDecArgs :: Map IR.QName (Int, String)
, envFreshIdentCount :: Map String Int
}
deriving Show
emptyEnv :: Environment
emptyEnv = Environment
{ envAvailableModules = Map.empty
, envEntries = Map.empty
, envDecArgs = Map.empty
, envFreshIdentCount = Map.empty
}
makeModuleAvailable :: ModuleInterface -> Environment -> Environment
makeModuleAvailable iface env = env
{ envAvailableModules = Map.insert (interfaceModName iface) iface
(envAvailableModules env)
}
isModuleAvailable :: IR.ModName -> Environment -> Bool
isModuleAvailable = isJust .: lookupAvailableModule
lookupAvailableModule :: IR.ModName -> Environment -> Maybe ModuleInterface
lookupAvailableModule modName = Map.lookup modName . envAvailableModules
addEntry :: EnvEntry -> Environment -> Environment
addEntry entry env = env
{ envEntries = Map.insert (entryScopedName entry) entry (envEntries env)
}
defineDecArg :: IR.QName -> Int -> String -> Environment -> Environment
defineDecArg funcName decArgIndex decArgIdent env = env
{ envDecArgs = Map.insert funcName (decArgIndex, decArgIdent) (envDecArgs env)
}
removeDecArg :: IR.QName -> Environment -> Environment
removeDecArg funcName env
= env { envDecArgs = Map.delete funcName (envDecArgs env) }
modifyEntryIdent
:: IR.Scope -> IR.QName -> Coq.Qualid -> Environment -> Environment
modifyEntryIdent scope name newIdent env = case lookupEntry scope name env of
Nothing -> env
Just entry -> addEntry (entry { entryIdent = newIdent }) env
addEffectsToEntry :: IR.QName -> [Effect] -> Environment -> Environment
addEffectsToEntry name effects env = case lookupEntry IR.ValueScope name env of
Nothing -> env
Just entry -> if isFuncEntry entry
then addEntry (entry { entryEffects = entryEffects entry ++ effects }) env
else env
encapsulatesEffects :: IR.QName -> Environment -> Bool
encapsulatesEffects = maybe False (isFuncEntry .&&. entryEncapsulatesEffects)
.: lookupEntry IR.ValueScope
lookupEntry :: IR.Scope -> IR.QName -> Environment -> Maybe EnvEntry
lookupEntry scope name = Map.lookup (scope, name) . envEntries
isFunction :: IR.QName -> Environment -> Bool
isFunction = maybe False isFuncEntry .: lookupEntry IR.ValueScope
isVariable :: IR.QName -> Environment -> Bool
isVariable = maybe False isVarEntry .: lookupEntry IR.ValueScope
isPureVar :: IR.QName -> Environment -> Bool
isPureVar = maybe False (isVarEntry .&&. entryIsPure)
.: lookupEntry IR.ValueScope
lookupModName :: IR.Scope -> IR.QName -> Environment -> Maybe IR.ModName
lookupModName scope name env = case entryName <$> lookupEntry scope name env of
Just (IR.Qual modName _) -> Just modName
_ -> Nothing
lookupIdent :: IR.Scope -> IR.QName -> Environment -> Maybe Coq.Qualid
lookupIdent = fmap entryIdent .:. lookupEntry
lookupSmartIdent :: IR.QName -> Environment -> Maybe Coq.Qualid
lookupSmartIdent
= fmap entrySmartIdent . find isConEntry .: lookupEntry IR.ValueScope
usedIdents :: Environment -> [Coq.Qualid]
usedIdents = concatMap entryIdents . Map.elems . envEntries
where
entryIdents :: EnvEntry -> [Coq.Qualid]
entryIdents entry
= entryIdent entry : [entrySmartIdent entry | isConEntry entry]
usedAgdaIdents :: Environment -> [Agda.QName]
usedAgdaIdents = concatMap entryIdents . Map.elems . envEntries
where
entryIdents :: EnvEntry -> [Agda.QName]
entryIdents entry
= entryAgdaIdent entry : [entryAgdaSmartIdent entry | isConEntry entry]
lookupSrcSpan :: IR.Scope -> IR.QName -> Environment -> Maybe SrcSpan
lookupSrcSpan = fmap entrySrcSpan .:. lookupEntry
lookupTypeArgs
:: IR.Scope -> IR.QName -> Environment -> Maybe [IR.TypeVarIdent]
lookupTypeArgs = fmap entryTypeArgs
. find (isTypeSynEntry .||. isConEntry .||. isFuncEntry)
.:. lookupEntry
lookupTypeArgArity :: IR.Scope -> IR.QName -> Environment -> Maybe Int
lookupTypeArgArity = fmap length .:. lookupTypeArgs
lookupArgTypes :: IR.Scope -> IR.QName -> Environment -> Maybe [IR.Type]
lookupArgTypes = fmap entryArgTypes . find (isConEntry .||. isFuncEntry)
.:. lookupEntry
lookupStrictArgs :: IR.QName -> Environment -> Maybe [Bool]
lookupStrictArgs
= fmap entryStrictArgs . find isFuncEntry .: lookupEntry IR.ValueScope
lookupReturnType :: IR.Scope -> IR.QName -> Environment -> Maybe IR.Type
lookupReturnType = fmap entryReturnType . find (isConEntry .||. isFuncEntry)
.:. lookupEntry
lookupTypeScheme :: IR.Scope -> IR.QName -> Environment -> Maybe IR.TypeScheme
lookupTypeScheme scope name env
| scope == IR.ValueScope && isVariable name env = do
typeExpr <- lookupEntry scope name env >>= entryType
return (IR.TypeScheme NoSrcSpan [] typeExpr)
| otherwise = do
typeArgs <- lookupTypeArgs scope name env
argTypes <- lookupArgTypes scope name env
returnType <- lookupReturnType scope name env
let typeArgDecls = map (IR.TypeVarDecl NoSrcSpan) typeArgs
funcType = IR.funcType NoSrcSpan argTypes returnType
return (IR.TypeScheme NoSrcSpan typeArgDecls funcType)
lookupArity :: IR.Scope -> IR.QName -> Environment -> Maybe Int
lookupArity = fmap entryArity . find (not . (isVarEntry .||. isTypeVarEntry))
.:. lookupEntry
lookupTypeSynonym
:: IR.QName -> Environment -> Maybe ([IR.TypeVarIdent], IR.Type)
lookupTypeSynonym = fmap (entryTypeArgs &&& entryTypeSyn) . find isTypeSynEntry
.: lookupEntry IR.TypeScope
needsFreeArgs :: IR.QName -> Environment -> Bool
needsFreeArgs = maybe False (isFuncEntry .&&. entryNeedsFreeArgs)
.: lookupEntry IR.ValueScope
hasEffect :: Effect -> IR.QName -> Environment -> Bool
hasEffect effect = maybe False (isFuncEntry .&&. elem effect . entryEffects)
.: lookupEntry IR.ValueScope
lookupEffects :: IR.QName -> Environment -> [Effect]
lookupEffects
= maybe [] entryEffects . find isFuncEntry .: lookupEntry IR.ValueScope
lookupDecArg :: IR.QName -> Environment -> Maybe (Int, String)
lookupDecArg name = Map.lookup name . envDecArgs
lookupDecArgIndex :: IR.QName -> Environment -> Maybe Int
lookupDecArgIndex = fmap fst .: lookupDecArg
lookupDecArgIdent :: IR.QName -> Environment -> Maybe String
lookupDecArgIdent = fmap snd .: lookupDecArg