-- Standard modules
import qualified Monad
import qualified System.IO.Unsafe
+import qualified Language.Haskell.TH as TH
+import qualified Maybe
-- GHC API
import qualified Annotations
listBindings :: FilePath -> [FilePath] -> IO [()]
listBindings libdir filenames = do
(cores,_,_) <- loadModules libdir filenames Nothing
- let binds = concat $ map (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
- mapM (listBinding) binds
+ let binds = concatMap (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
+ mapM listBinding binds
listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
listBinding (b, e) = do
listBind libdir filenames name = do
(cores,_,_) <- loadModules libdir filenames Nothing
bindings <- concatM $ mapM (findBinder (hasVarName name)) cores
- mapM listBinding bindings
+ mapM_ listBinding bindings
return ()
-- Change a DynFlag from within the Ghc monad. Strangely enough there seems to
-- just return an IO monad when they are evaluated).
unsafeRunGhc :: FilePath -> GHC.Ghc a -> a
unsafeRunGhc libDir m =
- System.IO.Unsafe.unsafePerformIO $ do
+ System.IO.Unsafe.unsafePerformIO $
GHC.runGhc (Just libDir) $ do
dflags <- GHC.getSessionDynFlags
GHC.setSessionDynFlags dflags
, [EntitySpec]
) -- ^ ( The loaded modules, the resulting ghc environment, the entities to build)
loadModules libdir filenames finder =
- GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do
+ GHC.defaultErrorHandler DynFlags.defaultDynFlags $
GHC.runGhc (Just libdir) $ do
dflags <- GHC.getSessionDynFlags
GHC.setSessionDynFlags dflags
- cores <- mapM GHC.compileToCoreSimplified filenames
+ cores <- mapM GHC.compileToCoreModule filenames
env <- GHC.getSession
specs <- case finder of
Nothing -> return []
Just f -> concatM $ mapM f cores
return (cores, env, specs)
+findBinds ::
+ Monad m =>
+ (Var.Var -> m Bool)
+ -> HscTypes.CoreModule
+ -> m (Maybe [CoreSyn.CoreBndr])
+findBinds criteria core = do
+ binders <- findBinder criteria core
+ case binders of
+ [] -> return Nothing
+ bndrs -> return $ Just $ map fst bndrs
+
findBind ::
Monad m =>
(Var.Var -> m Bool)
-> HscTypes.CoreModule
-> m (Maybe CoreSyn.CoreBndr)
findBind criteria core = do
+ binders <- findBinds criteria core
+ case binders of
+ Nothing -> return Nothing
+ (Just bndrs) -> return $ Just $ head bndrs
+
+findExprs ::
+ Monad m =>
+ (Var.Var -> m Bool)
+ -> HscTypes.CoreModule
+ -> m (Maybe [CoreSyn.CoreExpr])
+findExprs criteria core = do
binders <- findBinder criteria core
case binders of
[] -> return Nothing
- bndrs -> return $ Just $ fst $ head bndrs
+ bndrs -> return $ Just (map snd bndrs)
findExpr ::
Monad m =>
-> HscTypes.CoreModule
-> m (Maybe CoreSyn.CoreExpr)
findExpr criteria core = do
- binders <- findBinder criteria core
- case binders of
- [] -> return Nothing
- bndrs -> return $ Just $ snd $ head bndrs
+ exprs <- findExprs criteria core
+ case exprs of
+ Nothing -> return Nothing
+ (Just exprs) -> return $ Just $ head exprs
+
+findAnns ::
+ Monad m =>
+ (Var.Var -> m [CLasHAnn])
+ -> HscTypes.CoreModule
+ -> m [CLasHAnn]
+findAnns criteria core = do
+ let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
+ anns <- Monad.mapM (criteria . fst) binds
+ case anns of
+ [] -> return []
+ xs -> return $ concat xs
-- | Find a binder in module according to a certain criteria
findBinder ::
-> m [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- ^ The binders to meet the criteria
findBinder criteria core = do
let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
- critbinds <- Monad.filterM (criteria . fst) binds
- return critbinds
+ Monad.filterM (criteria . fst) binds
-- | Determine if a binder has an Annotation meeting a certain criteria
-hasCLasHAnnotation ::
+isCLasHAnnotation ::
GHC.GhcMonad m =>
(CLasHAnn -> Bool) -- ^ The criteria the Annotation has to meet
-> Var.Var -- ^ The Binder
- -> m Bool -- ^ Indicates if binder has the Annotation
-hasCLasHAnnotation clashAnn var = do
+ -> m [CLasHAnn] -- ^ Indicates if binder has the Annotation
+isCLasHAnnotation clashAnn var = do
let deserializer = Serialized.deserializeWithData
let target = Annotations.NamedTarget (Var.varName var)
(anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
let annEnts = filter clashAnn anns
- case annEnts of
+ return annEnts
+
+-- | Determine if a binder has an Annotation meeting a certain criteria
+hasCLasHAnnotation ::
+ GHC.GhcMonad m =>
+ (CLasHAnn -> Bool) -- ^ The criteria the Annotation has to meet
+ -> Var.Var -- ^ The Binder
+ -> m Bool -- ^ Indicates if binder has the Annotation
+hasCLasHAnnotation clashAnn var = do
+ anns <- isCLasHAnnotation clashAnn var
+ case anns of
[] -> return False
xs -> return True
String -- ^ The name the binder has to have
-> Var.Var -- ^ The Binder
-> m Bool -- ^ Indicate if the binder has the name
-hasVarName lookfor bind = return $ lookfor == (Name.occNameString $ Name.nameOccName $ Name.getName bind)
+hasVarName lookfor bind = return $ lookfor == Name.occNameString (Name.nameOccName $ Name.getName bind)
+
+
+findInitStates ::
+ (Var.Var -> GHC.Ghc Bool) ->
+ (Var.Var -> GHC.Ghc [CLasHAnn]) ->
+ HscTypes.CoreModule ->
+ GHC.Ghc (Maybe [(CoreSyn.CoreBndr, CoreSyn.CoreBndr)])
+findInitStates statec annsc mod = do
+ states <- findBinds statec mod
+ anns <- findAnns annsc mod
+ let funs = Maybe.catMaybes (map extractInits anns)
+ exprs' <- mapM (\x -> findBind (hasVarName (TH.nameBase x)) mod) funs
+ let exprs = Maybe.catMaybes exprs'
+ let inits = zipMWith (\a b -> (a,b)) states exprs
+ return inits
+ where
+ extractInits :: CLasHAnn -> Maybe TH.Name
+ extractInits (InitState x) = Just x
+ extractInits _ = Nothing
+ zipMWith :: (a -> b -> c) -> (Maybe [a]) -> [b] -> (Maybe [c])
+ zipMWith _ Nothing _ = Nothing
+ zipMWith f (Just as) bs = Just $ zipWith f as bs
-- | Make a complete spec out of a three conditions
findSpec ::
- (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool)
+ (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc [CLasHAnn]) -> (Var.Var -> GHC.Ghc Bool)
-> Finder
-findSpec topc statec testc mod = do
+findSpec topc statec annsc testc mod = do
top <- findBind topc mod
- state <- findExpr statec mod
+ state <- findExprs statec mod
+ anns <- findAnns annsc mod
test <- findExpr testc mod
- case top of
- Just t -> return [(t, state, test)]
- Nothing -> error $ "Could not find top entity requested"
+ inits <- findInitStates statec annsc mod
+ return [(top, inits, test)]
+ -- case top of
+ -- Just t -> return [(t, state, test)]
+ -- Nothing -> return error $ "Could not find top entity requested"