+
+-- | Loads the given file and turns it into a core module.
+loadModuleAnn :: FilePath -> String -> IO (HscTypes.CoreModule, [CoreSyn.CoreBndr], [CoreSyn.CoreBndr], [CoreSyn.CoreExpr], HscTypes.HscEnv)
+loadModuleAnn libdir filename =
+ defaultErrorHandler defaultDynFlags $ do
+ runGhc (Just libdir) $ do
+ dflags <- getSessionDynFlags
+ setSessionDynFlags dflags
+ --target <- guessTarget "adder.hs" Nothing
+ --liftIO (print (showSDoc (ppr (target))))
+ --liftIO $ printTarget target
+ --setTargets [target]
+ --load LoadAllTargets
+ --core <- GHC.compileToCoreSimplified "Adders.hs"
+ core <- GHC.compileToCoreModule filename
+ env <- GHC.getSession
+ top_entity <- findTopEntity core
+ init_state <- findInitState core
+ test_input <- findTestInput core
+ return (core, top_entity, init_state, test_input, env)
+
+findTopEntity :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreBndr]
+findTopEntity core = do
+ let binds = CoreSyn.flattenBinds $ cm_binds core
+ topbinds <- Monad.filterM (hasTopEntityAnnotation . fst) binds
+ let bndrs = case topbinds of [] -> error $ "Couldn't find top entity in current module." ; xs -> fst (unzip topbinds)
+ return bndrs
+
+findInitState :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreBndr]
+findInitState core = do
+ let binds = CoreSyn.flattenBinds $ cm_binds core
+ statebinds <- Monad.filterM (hasInitStateAnnotation . fst) binds
+ let bndrs = case statebinds of [] -> [] ; xs -> fst (unzip statebinds)
+ return bndrs
+
+findTestInput :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreExpr]
+findTestInput core = do
+ let binds = CoreSyn.flattenBinds $ cm_binds core
+ testbinds <- Monad.filterM (hasTestInputAnnotation . fst) binds
+ let exprs = case testbinds of [] -> [] ; xs -> snd (unzip testbinds)
+ return exprs
+
+hasTopEntityAnnotation :: GhcMonad m => Var.Var -> m Bool
+hasTopEntityAnnotation var = do
+ let deserializer = Serialized.deserializeWithData
+ let target = Annotations.NamedTarget (Var.varName var)
+ (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
+ let top_ents = filter isTopEntity anns
+ case top_ents of
+ [] -> return False
+ xs -> return True
+
+hasInitStateAnnotation :: GhcMonad m => Var.Var -> m Bool
+hasInitStateAnnotation var = do
+ let deserializer = Serialized.deserializeWithData
+ let target = Annotations.NamedTarget (Var.varName var)
+ (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
+ let top_ents = filter isInitState anns
+ case top_ents of
+ [] -> return False
+ xs -> return True
+
+hasTestInputAnnotation :: GhcMonad m => Var.Var -> m Bool
+hasTestInputAnnotation var = do
+ let deserializer = Serialized.deserializeWithData
+ let target = Annotations.NamedTarget (Var.varName var)
+ (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
+ let top_ents = filter isTestInput anns
+ case top_ents of
+ [] -> return False
+ xs -> return True