module HERMIT.Dictionary.Common
(
applyInContextT
, callT
, callPredT
, callNameT
, callSaturatedT
, callNameG
, callDataConT
, callDataConNameT
, callsR
, callsT
, progConsIdsT
, progConsRecIdsT
, progConsNonRecIdT
, nonRecVarT
, recIdsT
, lamVarT
, letVarsT
, letRecIdsT
, letNonRecVarT
, caseVarsT
, caseWildIdT
, caseAltVarsT
, boundVarsT
, findBoundVarT
, findIdT
, findId
, varBindingDepthT
, varIsOccurrenceOfT
, exprIsOccurrenceOfT
, wrongExprForm
)
where
import Data.List
import Data.Monoid
import Control.Arrow
import HERMIT.Kure
import HERMIT.Core
import HERMIT.Context
import HERMIT.GHC
import qualified Language.Haskell.TH as TH
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 failed: 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 <- varSetElems (localFreeVarsExpr 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)
progConsIdsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreProg [Id]
progConsIdsT = progConsT (arr bindVars) mempty (\ vs () -> vs)
progConsRecIdsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg [Id]
progConsRecIdsT = progConsT recIdsT mempty (\ vs () -> vs)
progConsNonRecIdT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg Id
progConsNonRecIdT = progConsT nonRecVarT mempty (\ v () -> v)
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 (\ _ -> arr defId) id
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 (arr bindVars) 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 (\ _ -> arr altVars) (\ () 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 (\ _ -> arr altVars) (\ () () () vss -> vss)
varBindingDepthT :: (ReadBindings c, Monad m) => Var -> Translate c m g BindingDepth
varBindingDepthT v = contextT >>= lookupHermitBindingDepth v
varIsOccurrenceOfT :: (ExtendPath c Crumb, ReadBindings c, Monad m) => Var -> BindingDepth -> Translate c m Var Bool
varIsOccurrenceOfT v d = readerT $ \ v' -> if v == v'
then varBindingDepthT v >>^ (== d)
else return False
exprIsOccurrenceOfT :: (ExtendPath c Crumb, ReadBindings c, Monad m) => Var -> BindingDepth -> Translate c m CoreExpr Bool
exprIsOccurrenceOfT v d = varT $ varIsOccurrenceOfT v d
boundVarsT :: (BoundVars c, Monad m) => Translate c m a VarSet
boundVarsT = contextonlyT (return . boundVars)
findBoundVarT :: (BoundVars c, MonadCatch m) => TH.Name -> Translate c m a Var
findBoundVarT nm = prefixFailMsg ("Cannot resolve name " ++ show nm ++ ", ") $
do c <- contextT
case varSetElems (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 " ++ show nm ++ ", ") $
contextonlyT (findId nm)
findId :: (BoundVars c, HasGlobalRdrEnv c, HasDynFlags m, MonadThings m) => TH.Name -> c -> m Id
findId nm c = case varSetElems (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 . show
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