module Language.HERMIT.Primitive.Common
(
applyInContextT
, callT
, callPredT
, callNameT
, callSaturatedT
, callNameG
, callDataConT
, callDataConNameT
, callsR
, callsT
, progIdsT
, consIdsT
, consRecIdsT
, consNonRecIdT
, bindVarsT
, nonRecVarT
, recIdsT
, defIdT
, lamVarT
, letVarsT
, letRecIdsT
, letNonRecVarT
, caseVarsT
, caseWildIdT
, caseAltVarsT
, altVarsT
, boundVarsT
, findBoundVarT
, findIdT
, findId
, wrongExprForm
, nodups
, mapAlts
)
where
import GhcPlugins
import Data.List
import Data.Monoid
import qualified Data.Set as S
import Control.Monad(liftM)
import Language.HERMIT.Kure
import Language.HERMIT.Core
import Language.HERMIT.Context
import Language.HERMIT.GHC
import Language.HERMIT.Primitive.GHC
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax (showName)
applyInContextT :: Translate c m a b -> a -> Translate c m x b
applyInContextT t a = contextonlyT $ \ c -> apply t c a
callT :: Monad m => Translate c m CoreExpr (CoreExpr, [CoreExpr])
callT = contextfreeT $ \ e -> case e of
Var {} -> return (e, [])
App {} -> return (collectArgs e)
_ -> fail "not an application or variable occurence."
callPredT :: Monad m => (Id -> [CoreExpr] -> Bool) -> Translate c m CoreExpr (CoreExpr, [CoreExpr])
callPredT p = do
call@(Var i, args) <- callT
guardMsg (p i args) "predicate failed."
return call
callNameT :: MonadCatch m => TH.Name -> Translate c m CoreExpr (CoreExpr, [CoreExpr])
callNameT nm = setFailMsg ("callNameT: not a call to " ++ show nm) $
callPredT (const . cmpTHName2Var nm)
callSaturatedT :: Monad m => Translate c m CoreExpr (CoreExpr, [CoreExpr])
callSaturatedT = callPredT (\ i args -> idArity i == length args)
callNameG :: MonadCatch m => TH.Name -> Translate c m CoreExpr ()
callNameG nm = prefixFailMsg "callNameG failed: " $ callNameT nm >>= \_ -> constT (return ())
callDataConT :: MonadCatch m => Translate c m CoreExpr (DataCon, [Type], [CoreExpr])
callDataConT = prefixFailMsg "callDataConT failed:" $
#if __GLASGOW_HASKELL__ > 706
do mb <- contextfreeT $ \ e -> let in_scope = mkInScopeSet (mkVarEnv [ (v,v) | v <- S.toList (coreExprFreeVars e) ])
in return $ exprIsConApp_maybe (in_scope, idUnfolding) e
maybe (fail "not a datacon application.") return mb
#else
contextfreeT (return . exprIsConApp_maybe idUnfolding)
>>= maybe (fail "not a datacon application.") return
#endif
callDataConNameT :: MonadCatch m => TH.Name -> Translate c m CoreExpr (DataCon, [Type], [CoreExpr])
callDataConNameT nm = do
res@(dc,_,_) <- callDataConT
guardMsg (cmpTHName2Name nm (dataConName dc)) "wrong datacon."
return res
callsR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => TH.Name -> Rewrite c m CoreExpr -> Rewrite c m Core
callsR nm rr = prunetdR (promoteExprR $ callNameG nm >> rr)
callsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => TH.Name -> Translate c m CoreExpr b -> Translate c m Core [b]
callsT nm t = collectPruneT (promoteExprT $ callNameG nm >> t)
progIdsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreProg [Id]
progIdsT = progNilT [] <+ progConsT bindVarsT progIdsT (++)
consIdsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreProg [Id]
consIdsT = progConsT bindVarsT mempty (\ vs () -> vs)
consRecIdsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg [Id]
consRecIdsT = progConsT recIdsT mempty (\ vs () -> vs)
consNonRecIdT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg Id
consNonRecIdT = progConsT nonRecVarT mempty (\ v () -> v)
bindVarsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreBind [Var]
bindVarsT = liftM return nonRecVarT <+ recIdsT
nonRecVarT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreBind Var
nonRecVarT = nonRecT idR mempty (\ v () -> v)
recIdsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind [Id]
recIdsT = recT (\ _ -> defIdT) id
defIdT :: (ExtendPath c Crumb, Monad m) => Translate c m CoreDef Id
defIdT = defT idR mempty (\ v () -> v)
lamVarT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Var
lamVarT = lamT idR mempty (\ v () -> v)
letVarsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreExpr [Var]
letVarsT = letT bindVarsT mempty (\ vs () -> vs)
letRecIdsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [Id]
letRecIdsT = letT recIdsT mempty (\ vs () -> vs)
letNonRecVarT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Var
letNonRecVarT = letT nonRecVarT mempty (\ v () -> v)
caseVarsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [Var]
caseVarsT = caseT mempty idR mempty (\ _ -> altVarsT) (\ () v () vss -> v : nub (concat vss))
caseWildIdT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Id
caseWildIdT = caseT mempty idR mempty (\ _ -> idR) (\ () i () _ -> i)
caseAltVarsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [[Var]]
caseAltVarsT = caseT mempty mempty mempty (\ _ -> altVarsT) (\ () () () vss -> vss)
altVarsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreAlt [Var]
altVarsT = altT mempty (\ _ -> idR) mempty (\ () vs () -> vs)
boundVarsT :: (BoundVars c, Monad m) => Translate c m a (S.Set Var)
boundVarsT = contextonlyT (return . boundVars)
findBoundVarT :: (BoundVars c, MonadCatch m) => TH.Name -> Translate c m a Var
findBoundVarT nm = prefixFailMsg ("Cannot resolve name " ++ showName nm ++ ", ") $
do c <- contextT
case findBoundVars nm c of
[] -> fail "no matching variables in scope."
[v] -> return v
_ : _ : _ -> fail "multiple matching variables in scope."
findIdT :: (BoundVars c, HasGlobalRdrEnv c, HasDynFlags m, MonadThings m, MonadCatch m) => TH.Name -> Translate c m a Id
findIdT nm = prefixFailMsg ("Cannot resolve name " ++ showName nm ++ ", ") $
contextonlyT (findId nm)
findId :: (BoundVars c, HasGlobalRdrEnv c, HasDynFlags m, MonadThings m) => TH.Name -> c -> m Id
findId nm c = case findBoundVars nm c of
[] -> findIdMG nm c
[v] -> return v
_ : _ : _ -> fail "multiple matching variables in scope."
findIdMG :: (BoundVars c, HasGlobalRdrEnv c, HasDynFlags m, MonadThings m) => TH.Name -> c -> m Id
findIdMG nm c =
case filter isValName $ findNamesFromTH (hermitGlobalRdrEnv c) nm of
[] -> findIdBuiltIn nm
[n] -> lookupId n
ns -> do dynFlags <- getDynFlags
fail $ "multiple matches found:\n" ++ intercalate ", " (map (showPpr dynFlags) ns)
findIdBuiltIn :: forall m. Monad m => TH.Name -> m Id
findIdBuiltIn = go . showName
where go ":" = dataConId consDataCon
go "[]" = dataConId nilDataCon
go "True" = return trueDataConId
go "False" = return falseDataConId
go "<" = return ltDataConId
go "==" = return eqDataConId
go ">" = return gtDataConId
go "I#" = dataConId intDataCon
go "()" = return unitDataConId
go _ = fail "variable not in scope."
dataConId :: DataCon -> m Id
dataConId = return . dataConWorkId
wrongExprForm :: String -> String
wrongExprForm form = "Expression does not have the form: " ++ form
nodups :: Eq a => [a] -> Bool
nodups as = length as == length (nub as)
mapAlts :: (CoreExpr -> CoreExpr) -> [CoreAlt] -> [CoreAlt]
mapAlts f alts = [ (ac, vs, f e) | (ac, vs, e) <- alts ]