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 Language.HERMIT.Kure
import Language.HERMIT.Core
import Language.HERMIT.Context
import Language.HERMIT.GHC
import Language.HERMIT.Monad
import qualified Language.Haskell.TH as TH
applyInContextT :: Translate c m a b -> a -> Translate c m a b
applyInContextT t a = contextonlyT $ \ c -> apply t c a
callT :: TranslateH CoreExpr (CoreExpr, [CoreExpr])
callT = do
e <- idR
case e of
Var {} -> return (e, [])
App {} -> return (collectArgs e)
_ -> fail "not an application or variable occurence."
callPredT :: (Id -> [CoreExpr] -> Bool) -> TranslateH CoreExpr (CoreExpr, [CoreExpr])
callPredT p = do
call@(Var i, args) <- callT
guardMsg (p i args) "predicate failed."
return call
callNameT :: TH.Name -> TranslateH CoreExpr (CoreExpr, [CoreExpr])
callNameT nm = setFailMsg ("callNameT: not a call to " ++ show nm) $
callPredT (const . cmpTHName2Var nm)
callSaturatedT :: TranslateH CoreExpr (CoreExpr, [CoreExpr])
callSaturatedT = callPredT (\ i args -> idArity i == length args)
callNameG :: TH.Name -> TranslateH CoreExpr ()
callNameG nm = prefixFailMsg "callNameG failed: " $ callNameT nm >>= \_ -> constT (return ())
callDataConT :: TranslateH CoreExpr (DataCon, [Type], [CoreExpr])
callDataConT = prefixFailMsg "callDataConT failed:" $
contextfreeT (return . exprIsConApp_maybe idUnfolding)
>>= maybe (fail "not a datacon application.") return
callDataConNameT :: TH.Name -> TranslateH CoreExpr (DataCon, [Type], [CoreExpr])
callDataConNameT nm = do
res@(dc,_,_) <- callDataConT
guardMsg (cmpTHName2Name nm (dataConName dc)) "wrong datacon."
return res
callsR :: TH.Name -> RewriteH CoreExpr -> RewriteH Core
callsR nm rr = prunetdR (promoteExprR $ callNameG nm >> rr)
callsT :: TH.Name -> TranslateH CoreExpr b -> TranslateH Core [b]
callsT nm t = collectPruneT (promoteExprT $ callNameG nm >> t)
progIdsT :: TranslateH CoreProg [Id]
progIdsT = progNilT [] <+ progConsT bindVarsT progIdsT (++)
consIdsT :: TranslateH CoreProg [Id]
consIdsT = progConsT bindVarsT mempty (\ vs () -> vs)
consRecIdsT :: TranslateH CoreProg [Id]
consRecIdsT = progConsT recIdsT mempty (\ vs () -> vs)
consNonRecIdT :: TranslateH CoreProg Id
consNonRecIdT = progConsT nonRecVarT mempty (\ v () -> v)
bindVarsT :: TranslateH CoreBind [Var]
bindVarsT = fmap return nonRecVarT <+ recIdsT
nonRecVarT :: TranslateH CoreBind Var
nonRecVarT = nonRecT mempty (\ v () -> v)
recIdsT :: TranslateH CoreBind [Id]
recIdsT = recT (\ _ -> defIdT) id
defIdT :: TranslateH CoreDef Id
defIdT = defT mempty (\ v () -> v)
lamVarT :: TranslateH CoreExpr Var
lamVarT = lamT mempty (\ v () -> v)
letVarsT :: TranslateH CoreExpr [Var]
letVarsT = letT bindVarsT mempty (\ vs () -> vs)
letRecIdsT :: TranslateH CoreExpr [Id]
letRecIdsT = letT recIdsT mempty (\ vs () -> vs)
letNonRecVarT :: TranslateH CoreExpr Var
letNonRecVarT = letT nonRecVarT mempty (\ v () -> v)
caseVarsT :: TranslateH CoreExpr [Var]
caseVarsT = caseT mempty (\ _ -> altVarsT) (\ () v _ vss -> v : nub (concat vss))
caseWildIdT :: TranslateH CoreExpr Id
caseWildIdT = caseT mempty (\ _ -> return ()) (\ () v _ _ -> v)
caseAltVarsT :: TranslateH CoreExpr [[Var]]
caseAltVarsT = caseT mempty (\ _ -> altVarsT) (\ () _ _ vss -> vss)
altVarsT :: TranslateH CoreAlt [Var]
altVarsT = altT mempty (\ _ vs () -> vs)
boundVarsT :: TranslateH a [Var]
boundVarsT = contextonlyT (return . boundVars)
findBoundVarT :: TH.Name -> TranslateH a Var
findBoundVarT nm = prefixFailMsg ("Cannot resolve name " ++ TH.nameBase 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 :: TH.Name -> TranslateH a Id
findIdT nm = prefixFailMsg ("Cannot resolve name " ++ TH.nameBase nm ++ ", ") $
contextonlyT (findId nm)
findId :: TH.Name -> HermitC -> HermitM Id
findId nm c = case findBoundVars nm c of
[] -> findIdMG nm c
[v] -> return v
_ : _ : _ -> fail "multiple matching variables in scope."
findIdMG :: TH.Name -> HermitC -> HermitM Id
findIdMG nm c =
case filter isValName $ findNameFromTH (mg_rdr_env $ hermitModGuts c) nm of
[] -> findIdBuiltIn nm
[n] -> lookupId n
ns -> do dynFlags <- getDynFlags
fail $ "multiple matches found:\n" ++ intercalate ", " (map (showPpr dynFlags) ns)
findIdBuiltIn :: TH.Name -> HermitM Id
findIdBuiltIn = go . TH.nameBase
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 -> HermitM 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 ]