{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -- | Haskell Translation module G2.Translation.Haskell ( loadProj , guessProj , hskToG2ViaModGuts , hskToG2ViaModGutsFromFile , hskToG2ViaCgGuts , hskToG2ViaCgGutsFromFile , mkCgGutsClosure , mkModDetailsClosure , mkModGutsClosure , EnvModSumModGuts (..) , envModSumModGutsFromFile , hskToG2ViaEMS , envModSumModGutsImports , mergeExtractedG2s , mkExpr , mkName , mkTyConName , mkData , mkSpan , mkRealSpan , absVarLoc , readFileExtractedG2 , readAllExtractedG2s , mergeFileExtractedG2s , findCabal , mkIdUnsafe , mkTyConNameUnsafe , mkDataUnsafe ) where import qualified G2.Language.TypeEnv as G2 (AlgDataTy (..)) import qualified G2.Language.Syntax as G2 -- import qualified G2.Language.Typing as G2 import qualified G2.Translation.TransTypes as G2 import G2.Translation.GHC import Control.Monad import qualified Control.Monad.State.Lazy as SM import qualified Data.Array as A import qualified Data.ByteString.Char8 as C import Data.Foldable import Data.List import Data.List.Split import Data.Maybe import qualified Data.HashMap.Lazy as HM import qualified Data.HashSet as HS import qualified Data.Text as T import System.FilePath import System.Directory -- Copying from Language.Typing so the thing we stuff into Ghc -- does not have to rely on Language.Typing, which depends on other things. mkG2TyApp :: [G2.Type] -> G2.Type mkG2TyApp [] = G2.TYPE mkG2TyApp (t:[]) = t mkG2TyApp (t1:t2:ts) = mkG2TyApp (G2.TyApp t1 t2 : ts) mkG2TyCon :: G2.Name -> [G2.Type] -> G2.Kind -> G2.Type mkG2TyCon n ts k = mkG2TyApp $ G2.TyCon n k:ts equivMods :: HM.HashMap T.Text T.Text equivMods = HM.fromList [ ("GHC.BaseMonad", "GHC.Base") , ("GHC.Classes2", "GHC.Classes") , ("GHC.Types2", "GHC.Types") , ("GHC.Integer2", "GHC.Integer") #if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) , ("GHC.Integer.Type2", "GHC.Num.Integer") #else , ("GHC.Integer.Type2", "GHC.Integer.Type") #endif , ("GHC.Prim2", "GHC.Prim") #if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) , ("GHC.Tuple2", "GHC.Tuple.Prim") #else , ("GHC.Tuple2", "GHC.Tuple") #endif , ("GHC.Magic2", "GHC.Magic") , ("GHC.CString2", "GHC.CString") , ("Data.Map.Base", "Data.Map")] loadProj :: Maybe HscTarget -> [FilePath] -> [FilePath] -> [GeneralFlag] -> G2.TranslationConfig -> Ghc SuccessFlag loadProj hsc proj src gflags tr_con = do beta_flags <- getSessionDynFlags let gen_flags = if G2.hpc_ticks tr_con then Opt_Hpc:gflags else gflags let init_beta_flags = gopt_unset beta_flags Opt_StaticArgumentTransformation let beta_flags' = foldl' gopt_set init_beta_flags gen_flags let dflags = beta_flags' { #if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) backend = case hsc of Just hsc' -> hsc' _ -> backend beta_flags' #elif MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) backend = if hostIsProfiled then Interpreter else case hsc of Just hsc' -> hsc' _ -> backend beta_flags' #elif MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) hscTarget = if hostIsProfiled then HscInterpreted else case hsc of Just hsc' -> hsc' _ -> hscTarget beta_flags' #else hscTarget = if rtsIsProfiled then HscInterpreted else case hsc of Just hsc' -> hsc' _ -> hscTarget beta_flags' #endif #if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0) -- Profiling gives warnings without this special case , targetWays_ = if hostIsProfiled then addWay WayProf (targetWays_ beta_flags') else targetWays_ beta_flags' #endif , ghcLink = LinkInMemory , ghcMode = CompManager , importPaths = proj ++ importPaths beta_flags' , simplPhases = if G2.simpl tr_con then simplPhases beta_flags' else 0 , maxSimplIterations = if G2.simpl tr_con then maxSimplIterations beta_flags' else 0 , hpcDir = head proj} dflags' = setIncludePaths proj dflags _ <- setSessionDynFlags dflags' #if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) targets <- mapM (\s -> guessTarget s Nothing Nothing) src #else targets <- mapM (flip guessTarget Nothing) src #endif _ <- setTargets targets load LoadAllTargets setIncludePaths :: [FilePath] -> DynFlags -> DynFlags #if __GLASGOW_HASKELL__ < 806 setIncludePaths proj dflags = dflags { includePaths = proj ++ includePaths dflags } #else setIncludePaths proj dflags = dflags { includePaths = addQuoteInclude (includePaths dflags) proj } #endif -- Compilation pipeline with CgGuts hskToG2ViaCgGutsFromFile :: Maybe HscTarget -> [FilePath] -> [FilePath] -> G2.NameMap -> G2.TypeNameMap -> G2.TranslationConfig -> IO (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2) hskToG2ViaCgGutsFromFile hsc proj src nm tm tr_con = do ems <- envModSumModGutsFromFile hsc proj src tr_con hskToG2ViaEMS tr_con ems nm tm hskToG2ViaEMS :: G2.TranslationConfig -> EnvModSumModGuts -> G2.NameMap -> G2.TypeNameMap -> IO (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2) hskToG2ViaEMS tr_con (EnvModSumModGuts env _ modgutss) nm tm = do closures <- mkCgGutsModDetailsClosures tr_con env modgutss let (ex_g2, (nm', tm')) = SM.runState (hskToG2ViaCgGuts closures tr_con) (nm, tm) return (nm', tm', ex_g2) hskToG2ViaCgGuts :: [(G2.CgGutsClosure, G2.ModDetailsClosure)] -> G2.TranslationConfig -> G2.NamesM G2.ExtractedG2 hskToG2ViaCgGuts pairs tr_con = do exg2s <- mapM (\(c, m) -> do let mgcc = cgGutsModDetailsClosureToModGutsClosure c m g2 <- modGutsClosureToG2 mgcc tr_con return g2) pairs return $ mergeExtractedG2s exg2s cgGutsModDetailsClosureToModGutsClosure :: G2.CgGutsClosure -> G2.ModDetailsClosure -> G2.ModGutsClosure cgGutsModDetailsClosureToModGutsClosure cg md = G2.ModGutsClosure { G2.mgcc_mod_name = G2.cgcc_mod_name cg , G2.mgcc_binds = G2.cgcc_binds cg , G2.mgcc_tycons = G2.cgcc_tycons cg , G2.mgcc_breaks = G2.cgcc_breaks cg , G2.mgcc_cls_insts = G2.mdcc_cls_insts md , G2.mgcc_type_env = G2.mdcc_type_env md , G2.mgcc_exports = G2.mdcc_exports md , G2.mgcc_deps = G2.mdcc_deps md , G2.mgcc_rules = G2.cgcc_rules cg } data EnvModSumModGuts = EnvModSumModGuts HscEnv [ModSummary] [ModGuts] envModSumModGutsFromFile :: Maybe HscTarget -> [FilePath] -> [FilePath] -> G2.TranslationConfig -> IO EnvModSumModGuts envModSumModGutsFromFile hsc proj src tr_con = runGhc (Just libdir) $ do _ <- loadProj hsc proj src [] tr_con env <- getSession mod_graph <- getModuleGraph let msums = convertModuleGraph mod_graph parsed_mods <- mapM parseModule msums typed_mods <- mapM typecheckModule parsed_mods desug_mods <- mapM desugarModule typed_mods return . EnvModSumModGuts env msums $ map coreModule desug_mods envModSumModGutsImports :: EnvModSumModGuts -> [String] envModSumModGutsImports (EnvModSumModGuts _ ms _) = concatMap (map (\(_, L _ m) -> moduleNameString m) . ms_textual_imps) ms -- | Extract information from GHC into a form that G2 can process. mkCgGutsModDetailsClosures :: G2.TranslationConfig -> HscEnv -> [ModGuts] -> IO [( G2.CgGutsClosure, G2.ModDetailsClosure)] #if __GLASGOW_HASKELL__ < 806 mkCgGutsModDetailsClosures tr_con env modgutss = do simplgutss <- mapM (if G2.simpl tr_con then hscSimplify env else return . id) modgutss tidys <- mapM (tidyProgram env) simplgutss let pairs = map (\((cg, md), mg) -> ( mkCgGutsClosure (mg_binds mg) cg md , mkModDetailsClosure (mg_deps mg) md)) $ zip tidys simplgutss return pairs #else mkCgGutsModDetailsClosures tr_con env modgutss = do simplgutss <- mapM (if G2.simpl tr_con then hscSimplify env [] else return . id) modgutss #if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) tidy_opts <- initTidyOpts env tidys <- mapM (tidyProgram tidy_opts) simplgutss #else tidys <- mapM (tidyProgram env) simplgutss #endif let pairs = map (\((cg, md), mg) -> ( mkCgGutsClosure (mg_binds mg) cg md , mkModDetailsClosure (mg_deps mg) md)) $ zip tidys simplgutss return pairs #endif -- | Extract information from GHC into a form that G2 can process. mkCgGutsClosure :: CoreProgram -> CgGuts -> ModDetails -> G2.CgGutsClosure mkCgGutsClosure binds cgguts md = let binds_rules = concatMap ruleInfoRules . map ruleInfo . map idInfo . concatMap bindersOf $ binds in G2.CgGutsClosure { G2.cgcc_mod_name = Just $ moduleNameString $ moduleName $ cg_module cgguts , G2.cgcc_binds = cg_binds cgguts , G2.cgcc_breaks = cg_modBreaks cgguts , G2.cgcc_tycons = cg_tycons cgguts -- Getting all rules is complicated by GHC's build process. GHC goes through a "tidying" -- process, which performs various transformation on the Core code. Unfortunately: -- 1) The core program in the CgGuts does not include rules after tidying. -- 2) The ModDetails does not include all rules after tidying. -- 3) Names of functions in rules in the original CoreProgram may have been changed by bindings -- (in which case it seems like those rules ARE in the ModDetails.) -- We can't just take the rules from the ModDetails, because some are eliminated during tidying. -- But we can't just take the rules from the original CoreProgram, because they might have function/variables -- names that no longer exist. -- As such, we keep: -- 1) Rules from the ModDetails -- 2) Rules from the CoreProgram, IF a rule with the same name is not in ModDetails , G2.cgcc_rules = nubBy (\r1 r2 -> ru_name r1 == ru_name r2) (md_rules md ++ binds_rules) } mkModDetailsClosure :: Dependencies -> ModDetails -> G2.ModDetailsClosure mkModDetailsClosure deps moddet = G2.ModDetailsClosure { G2.mdcc_cls_insts = getClsInst moddet , G2.mdcc_type_env = md_types moddet , G2.mdcc_exports = exportedNames moddet , G2.mdcc_deps = getModuleNames deps } -- Compilation pipeline with ModGuts hskToG2ViaModGutsFromFile :: Maybe HscTarget -> [FilePath] -> [FilePath] -> G2.NameMap -> G2.TypeNameMap -> G2.TranslationConfig -> IO (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2) hskToG2ViaModGutsFromFile hsc proj src nm tm tr_con = do closures <- mkModGutsClosuresFromFile hsc proj src tr_con let (ex_g2, (nm', tm')) = SM.runState (hskToG2ViaModGuts closures tr_con) (nm, tm) return (nm', tm', ex_g2) hskToG2ViaModGuts :: [G2.ModGutsClosure] -> G2.TranslationConfig -> G2.NamesM G2.ExtractedG2 hskToG2ViaModGuts modgutss tr_con = do exg2s <- mapM (\m -> modGutsClosureToG2 m tr_con) modgutss return $ mergeExtractedG2s exg2s modGutsClosureToG2 :: G2.ModGutsClosure -> G2.TranslationConfig -> G2.NamesM G2.ExtractedG2 modGutsClosureToG2 mgcc tr_con = do let breaks = G2.mgcc_breaks mgcc -- Do the binds binds <- foldM (\bs b -> do bs' <- mkBinds breaks b return $ bs `HM.union` bs') HM.empty (G2.mgcc_binds mgcc) -- Do the tycons let raw_tycons = G2.mgcc_tycons mgcc ++ typeEnvTyCons (G2.mgcc_type_env mgcc) tycons <- foldM (\tcs tc -> do (n, mb_t) <- mkTyCon tc return $ maybe tcs (\t -> HM.insert n t tcs) mb_t) HM.empty raw_tycons -- Do the class classes <- mapM mkClass $ G2.mgcc_cls_insts mgcc -- Do the rules rules <- if G2.load_rewrite_rules tr_con then mapM (mkRewriteRule breaks) $ G2.mgcc_rules mgcc else return [] -- Do the exports let exports = G2.mgcc_exports mgcc let deps = fmap T.pack $ G2.mgcc_deps mgcc return (G2.ExtractedG2 { G2.exg2_mod_names = [fmap T.pack $ G2.mgcc_mod_name mgcc] , G2.exg2_binds = binds , G2.exg2_tycons = tycons , G2.exg2_classes = classes , G2.exg2_exports = exports , G2.exg2_deps = deps , G2.exg2_rules = catMaybes rules }) mkModGutsClosuresFromFile :: Maybe HscTarget -> [FilePath] -> [FilePath] -> G2.TranslationConfig -> IO [G2.ModGutsClosure] mkModGutsClosuresFromFile hsc proj src tr_con = do (env, modgutss) <- runGhc (Just libdir) $ do _ <- loadProj hsc proj src [] tr_con env <- getSession mod_graph <- getModuleGraph let msums = convertModuleGraph mod_graph parsed_mods <- mapM parseModule msums typed_mods <- mapM typecheckModule parsed_mods desug_mods <- mapM desugarModule typed_mods return (env, map coreModule desug_mods) if G2.simpl tr_con then do simpls <- mapM (hscSimplifyC env) modgutss mapM (mkModGutsClosure env) simpls else do mapM (mkModGutsClosure env) modgutss {-# INLINE convertModuleGraph #-} convertModuleGraph :: ModuleGraph -> [ModSummary] #if __GLASGOW_HASKELL__ < 806 convertModuleGraph = id #else convertModuleGraph = mgModSummaries #endif {-# INLINE hscSimplifyC #-} hscSimplifyC :: HscEnv -> ModGuts -> IO ModGuts #if __GLASGOW_HASKELL__ < 806 hscSimplifyC = hscSimplify #else hscSimplifyC env = hscSimplify env [] #endif -- This one will need to do the Tidy program stuff mkModGutsClosure :: HscEnv -> ModGuts -> IO G2.ModGutsClosure mkModGutsClosure env modguts = do #if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) tidy_opts <- initTidyOpts env (cgguts, moddets) <- tidyProgram tidy_opts modguts #else (cgguts, moddets) <- tidyProgram env modguts #endif return G2.ModGutsClosure { G2.mgcc_mod_name = Just $ moduleNameString $ moduleName $ cg_module cgguts , G2.mgcc_binds = cg_binds cgguts , G2.mgcc_tycons = cg_tycons cgguts , G2.mgcc_breaks = cg_modBreaks cgguts , G2.mgcc_cls_insts = getClsInst moddets , G2.mgcc_type_env = md_types moddets , G2.mgcc_exports = exportedNames moddets , G2.mgcc_deps = getModuleNames $ mg_deps modguts , G2.mgcc_rules = mg_rules modguts } getClsInst :: ModDetails -> [ClsInst] #if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) getClsInst = instEnvElts . md_insts #else getClsInst = md_insts #endif getModuleNames :: Dependencies -> [String] #if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) getModuleNames = map moduleNameString . dep_sig_mods #elif MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) getModuleNames = map (moduleNameString . gwib_mod) . dep_mods #else getModuleNames = map (moduleNameString . fst) . dep_mods #endif -- Merging, order matters! mergeExtractedG2s :: [G2.ExtractedG2] -> G2.ExtractedG2 mergeExtractedG2s [] = G2.emptyExtractedG2 mergeExtractedG2s (g2:g2s) = let g2' = mergeExtractedG2s g2s in G2.ExtractedG2 { G2.exg2_mod_names = G2.exg2_mod_names g2 ++ G2.exg2_mod_names g2' -- order matters , G2.exg2_binds = G2.exg2_binds g2 `HM.union` G2.exg2_binds g2' , G2.exg2_tycons = G2.exg2_tycons g2 `HM.union` G2.exg2_tycons g2' , G2.exg2_classes = G2.exg2_classes g2 ++ G2.exg2_classes g2' , G2.exg2_exports = G2.exg2_exports g2 ++ G2.exg2_exports g2' , G2.exg2_deps = G2.exg2_deps g2 ++ G2.exg2_deps g2' , G2.exg2_rules = G2.exg2_rules g2 ++ G2.exg2_rules g2' } ---------------- -- Translating the individual components in CoreSyn, etc into G2 Core mkBinds :: Maybe ModBreaks -> CoreBind -> G2.NamesM (HM.HashMap G2.Name G2.Expr) mkBinds mb (NonRec var expr) = do i <- mkIdLookup var e <- mkExpr mb expr return $ HM.singleton (G2.idName i) e mkBinds mb (Rec ves) = return . HM.fromList =<< mapM (\(v, expr) -> do i <- mkIdLookup v e <- mkExpr mb expr return (G2.idName i, e)) ves mkExpr :: Maybe ModBreaks -> CoreExpr -> G2.NamesM G2.Expr mkExpr _ (Var var) = return . G2.Var =<< mkIdLookup var mkExpr _ (Lit lit) = return $ G2.Lit (mkLit lit) mkExpr mb (App fxpr axpr) = liftM2 G2.App (mkExpr mb fxpr) (mkExpr mb axpr) mkExpr mb (Lam var expr) = liftM2 (G2.Lam (mkLamUse var)) (valId var) (mkExpr mb expr) mkExpr mb (Let bnd expr) = liftM2 G2.Let (mkBind mb bnd) (mkExpr mb expr) mkExpr mb (Case mxpr var t alts) = do bindee <- mkExpr mb mxpr binder <- valId var ty <- mkType t as <- mkAlts mb alts return $ G2.Case bindee binder ty as mkExpr mb (Cast expr c) = liftM2 G2.Cast (mkExpr mb expr) (mkCoercion c) mkExpr _ (Coercion c) = liftM G2.Coercion (mkCoercion c) mkExpr mb (Tick t expr) = case createTickish mb t of Just t' -> return . G2.Tick t' =<< mkExpr mb expr Nothing -> mkExpr mb expr mkExpr _ (Type ty) = liftM G2.Type (mkType ty) #if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) createTickish :: Maybe ModBreaks -> GenTickish i -> Maybe G2.Tickish #else createTickish :: Maybe ModBreaks -> Tickish i -> Maybe G2.Tickish #endif createTickish (Just mb) (Breakpoint {breakpointId = bid}) = case mkSpan $ modBreaks_locs mb A.! bid of Just s -> Just $ G2.Breakpoint $ s Nothing -> Nothing createTickish _ (HpcTick { tickModule = md, tickId = i}) = Just . G2.HpcTick i . T.pack . moduleNameString $ moduleName md createTickish _ _ = Nothing mkLamUse :: Id -> G2.LamUse mkLamUse v | isTyVar v = G2.TypeL | otherwise = G2.TermL valId :: Id -> G2.NamesM G2.Id valId vid = liftM2 G2.Id (valNameLookup . varName $ vid) (mkType . varType $ vid) typeId :: Id -> G2.NamesM G2.Id typeId vid = liftM2 G2.Id (typeNameLookup . varName $ vid) (mkType . varType $ vid) mkIdLookup :: Id -> G2.NamesM G2.Id mkIdLookup i = do n <- valNameLookup (varName i) t <- mkType . varType $ i return $ G2.Id n t mkName :: Name -> G2.Name mkName name = G2.Name occ mdl unq sp where occ = T.pack . occNameString . nameOccName $ name unq = (getKey . nameUnique) name mdl = case nameModule_maybe name of Nothing -> Nothing Just md -> switchModule (T.pack . moduleNameString . moduleName $ md) sp = mkSpan $ getSrcSpan name valNameLookup :: Name -> G2.NamesM G2.Name valNameLookup n = do (nm, tm) <- SM.get (n', nm') <- nameLookup nm n SM.put (nm', tm) return n' typeNameLookup :: Name -> G2.NamesM G2.Name typeNameLookup n = do (nm, tm) <- SM.get (n', tm') <- nameLookup tm n SM.put (nm, tm') return n' nameLookup :: HM.HashMap (T.Text, Maybe T.Text) G2.Name -> Name -> G2.NamesM (G2.Name, HM.HashMap (T.Text, Maybe T.Text) G2.Name) nameLookup nm name = do -- We only lookup in the G2.NameMap if the Module name is not Nothing -- Internally, a module may use multiple variables with the same name and a module Nothing return $ case mdl of Nothing -> (G2.Name occ mdl unq sp, nm) _ -> case HM.lookup (occ, mdl) nm of Just (G2.Name n' m i _) -> (G2.Name n' m i sp, nm) Nothing -> let n = G2.Name occ mdl unq sp in (n, HM.insert (occ, mdl) n nm) where occ = T.pack . occNameString . nameOccName $ name unq = getKey . nameUnique $ name mdl = case nameModule_maybe name of Nothing -> Nothing Just md -> switchModule (T.pack . moduleNameString . moduleName $ md) sp = mkSpan $ getSrcSpan name mkSpan :: SrcSpan -> Maybe G2.Span #if MIN_VERSION_GLASGOW_HASKELL(9,0,2,0) mkSpan (RealSrcSpan s _) = Just $ mkRealSpan s #else mkSpan (RealSrcSpan s) = Just $ mkRealSpan s #endif mkSpan _ = Nothing mkRealSpan :: RealSrcSpan -> G2.Span mkRealSpan s = let st = mkRealLoc $ realSrcSpanStart s en = mkRealLoc $ realSrcSpanEnd s in G2.Span { G2.start = st , G2.end = en} mkRealLoc :: RealSrcLoc -> G2.Loc mkRealLoc l = G2.Loc { G2.line = srcLocLine l , G2.col = srcLocCol l , G2.file = unpackFS $ srcLocFile l} switchModule :: T.Text -> Maybe T.Text switchModule m = case HM.lookup m equivMods of Just m'' -> Just m'' Nothing -> Just m mkLit :: Literal -> G2.Lit #if __GLASGOW_HASKELL__ < 808 mkLit (MachChar chr) = G2.LitChar chr mkLit (MachStr bstr) = G2.LitString (C.unpack bstr) #else mkLit (LitChar chr) = G2.LitChar chr mkLit (LitString bstr) = G2.LitString (C.unpack bstr) #endif #if __GLASGOW_HASKELL__ < 806 mkLit (MachInt i) = G2.LitInt (fromInteger i) mkLit (MachInt64 i) = G2.LitInt (fromInteger i) mkLit (MachWord i) = G2.LitInt (fromInteger i) mkLit (MachWord64 i) = G2.LitInt (fromInteger i) mkLit (LitInteger i _) = G2.LitInteger (fromInteger i) #elif __GLASGOW_HASKELL__ <= 810 mkLit (LitNumber LitNumInteger i _) = G2.LitInteger (fromInteger i) mkLit (LitNumber LitNumNatural i _) = G2.LitInteger (fromInteger i) mkLit (LitNumber LitNumInt i _) = G2.LitInt (fromInteger i) mkLit (LitNumber LitNumInt64 i _) = G2.LitInt (fromInteger i) mkLit (LitNumber LitNumWord i _) = G2.LitInt (fromInteger i) mkLit (LitNumber LitNumWord64 i _) = G2.LitInt (fromInteger i) #elif __GLASGOW_HASKELL__ <= 902 mkLit (LitNumber LitNumInteger i) = G2.LitInteger (fromInteger i) mkLit (LitNumber LitNumNatural i) = G2.LitInteger (fromInteger i) mkLit (LitNumber LitNumInt i) = G2.LitInt (fromInteger i) mkLit (LitNumber LitNumInt64 i) = G2.LitInt (fromInteger i) mkLit (LitNumber LitNumWord i) = G2.LitInt (fromInteger i) mkLit (LitNumber LitNumWord64 i) = G2.LitInt (fromInteger i) #else mkLit (LitNumber LitNumInt i) = G2.LitInt (fromInteger i) mkLit (LitNumber LitNumInt64 i) = G2.LitInt (fromInteger i) mkLit (LitNumber LitNumWord i) = G2.LitInt (fromInteger i) mkLit (LitNumber LitNumWord64 i) = G2.LitInt (fromInteger i) #endif #if __GLASGOW_HASKELL__ < 808 mkLit (MachFloat rat) = G2.LitFloat rat mkLit (MachDouble rat) = G2.LitDouble rat #else mkLit (LitFloat rat) = G2.LitFloat rat mkLit (LitDouble rat) = G2.LitDouble rat #endif mkLit _ = error "mkLit: unhandled Lit" -- mkLit (MachNullAddr) = error "mkLit: MachNullAddr" -- mkLit (MachLabel _ _ _ ) = error "mkLit: MachLabel" mkBind :: Maybe ModBreaks -> CoreBind -> G2.NamesM [(G2.Id, G2.Expr)] mkBind mb (NonRec var expr) = do i <- valId var e <- mkExpr mb expr return [(i, e)] mkBind mb (Rec ves) = mapM (\(v, e) -> do i <- valId v e' <- mkExpr mb e return (i, e')) ves mkAlts :: Maybe ModBreaks -> [CoreAlt] -> G2.NamesM [G2.Alt] mkAlts mb = mapM (mkAlt mb) mkAlt :: Maybe ModBreaks -> CoreAlt -> G2.NamesM G2.Alt #if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) mkAlt mb (Alt acon prms expr) = liftM2 G2.Alt (mkAltMatch acon prms) (mkExpr mb expr) #else mkAlt mb (acon, prms, expr) = liftM2 G2.Alt (mkAltMatch acon prms) (mkExpr mb expr) #endif mkAltMatch :: AltCon -> [Var] -> G2.NamesM G2.AltMatch mkAltMatch (DataAlt dcon) params = liftM2 G2.DataAlt (mkData dcon) (mapM valId params) mkAltMatch (LitAlt lit) _ = return $ G2.LitAlt (mkLit lit) mkAltMatch DEFAULT _ = return G2.Default mkType :: Type -> G2.NamesM G2.Type mkType (TyVarTy v) = liftM G2.TyVar $ typeId v mkType (AppTy t1 t2) = liftM2 G2.TyApp (mkType t1) (mkType t2) #if __GLASGOW_HASKELL__ < 808 mkType (FunTy t1 t2) = liftM2 G2.TyFun (mkType t1) (mkType t2) #elif __GLASGOW_HASKELL__ <= 810 mkType (FunTy _ t1 t2) = liftM2 G2.TyFun (mkType t1) (mkType t2) #else mkType (FunTy _ _ t1 t2) = liftM2 G2.TyFun (mkType t1) (mkType t2) #endif mkType (ForAllTy b ty) = liftM2 G2.TyForAll (mkTyBinder b) (mkType ty) mkType (LitTy _) = return G2.TyBottom -- mkType (CastTy _ _) = error "mkType: CastTy" mkType (CastTy _ _) = return G2.TyUnknown mkType (CoercionTy _) = return G2.TyUnknown -- mkType (CoercionTy _) = error "mkType: Coercion" mkType (TyConApp tc ts) #if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) #else | isFunTyCon tc , length ts == 2 = case ts of [t1, t2] -> liftM2 G2.TyFun (mkType t1) (mkType t2) _ -> error "mkType: non-arity 2 FunTyCon from GHC" #endif | G2.Name "Type" _ _ _ <- mkName $ tyConName tc = return G2.TYPE | G2.Name "TYPE" _ _ _ <- mkName $ tyConName tc = return G2.TYPE | G2.Name "->" _ _ _ <- mkName $ tyConName tc , [_, _, t1, t2] <- ts = liftM2 G2.TyFun (mkType t1) (mkType t2) | otherwise = liftM3 mkG2TyCon (mkTyConName tc) (mapM mkType ts) (mkType $ tyConKind tc) mkTyCon :: TyCon -> G2.NamesM (G2.Name, Maybe G2.AlgDataTy) mkTyCon t = do n@(G2.Name n' m _ _) <- typeNameLookup . tyConName $ t (nm, tm) <- SM.get let tm' = HM.insert (n', m) n tm dc_names <- mapM (valNameLookup . dataConName) $ visibleDataCons (algTyConRhs t) let nm' = foldr (uncurry HM.insert) nm . map (\n_@(G2.Name n'_ m_ _ _) -> ((n'_, m_), n_)) $ dc_names bv <- mapM typeId $ tyConTyVars t dcs <- case isAlgTyCon t of True -> do SM.put (nm', tm') case algTyConRhs t of DataTyCon { data_cons = dc } -> do dcs <- mapM mkData dc return . Just $ G2.DataTyCon bv dcs NewTyCon { data_con = dc , nt_rhs = rhst} -> do dc' <- mkData dc t' <- mkType rhst return . Just $ G2.NewTyCon { G2.bound_ids = bv , G2.data_con = dc' , G2.rep_type = t'} AbstractTyCon {} -> error "Unhandled TyCon AbstractTyCon" -- TupleTyCon {} -> error "Unhandled TyCon TupleTyCon" TupleTyCon { data_con = dc } -> do dc' <- mkData dc return . Just $ G2.DataTyCon bv $ [dc'] SumTyCon {} -> error "Unhandled TyCon SumTyCon" False -> case isTypeSynonymTyCon t of True -> do SM.put (nm, tm') let (tv, st) = fromJust $ synTyConDefn_maybe t st' <- mkType st tv' <- mapM typeId tv return . Just $ G2.TypeSynonym { G2.bound_ids = tv' , G2.synonym_of = st'} False -> return Nothing case dcs of Just dcs' -> return (n, Just dcs') Nothing -> return (n, Nothing) mkTyConName :: TyCon -> G2.NamesM G2.Name mkTyConName tc = typeNameLookup (tyConName tc) mkData :: DataCon -> G2.NamesM G2.DataCon mkData datacon = do name <- mkDataName datacon ty <- (mkType . dataConRepType) datacon return $ G2.DataCon name ty mkDataName :: DataCon -> G2.NamesM G2.Name mkDataName datacon = valNameLookup . dataConName $ datacon mkTyBinder :: TyVarBinder -> G2.NamesM G2.Id #if __GLASGOW_HASKELL__ < 808 mkTyBinder (TvBndr v _) = typeId v #else mkTyBinder (Bndr v _) = typeId v #endif mkCoercion :: Coercion -> G2.NamesM G2.Coercion mkCoercion c = do let (Pair t1 t2) = coercionKind c t1' <- mkType t1 t2' <- mkType t2 return $ t1' G2.:~ t2' mkClass :: ClsInst -> G2.NamesM (G2.Name, G2.Id, [G2.Id], [(G2.Type, G2.Id)]) mkClass (ClsInst { is_cls = c, is_dfun = dfun }) = do class_name <- typeNameLookup . className $ c i <- valId dfun tyvars <- mapM typeId $ classTyVars c sctheta <- mapM mkType $ classSCTheta c sel_ids <- mapM mkIdLookup $ classAllSelIds c let sctheta_selids = zip sctheta sel_ids return ( class_name , i , tyvars , sctheta_selids) mkRewriteRule :: Maybe ModBreaks -> CoreRule -> G2.NamesM (Maybe G2.RewriteRule) mkRewriteRule breaks (Rule { ru_name = n , ru_origin = mdl , ru_fn = fn , ru_rough = rough , ru_bndrs = bndrs , ru_args = args , ru_rhs = rhs }) = do head_name <- valNameLookup fn rough' <- mapM (maybe (return Nothing) (\nm -> return . Just =<< valNameLookup nm)) rough bndrs' <- mapM valId bndrs args' <- mapM (mkExpr breaks) args rhs' <- mkExpr breaks rhs let r = G2.RewriteRule { G2.ru_name = T.pack $ unpackFS n , G2.ru_module = T.pack . moduleNameString $ moduleName mdl , G2.ru_head = head_name , G2.ru_rough = rough' , G2.ru_bndrs = bndrs' , G2.ru_args = args' , G2.ru_rhs = rhs' } return $ Just r mkRewriteRule _ _ = return Nothing exportedNames :: ModDetails -> [G2.ExportedName] exportedNames = concatMap availInfoNames . md_exports availInfoNames :: AvailInfo -> [G2.ExportedName] #if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) availInfoNames (Avail n) = [greNameToName n] availInfoNames (AvailTC n ns) = mkName n:map greNameToName ns greNameToName :: GreName -> G2.Name greNameToName (NormalGreName n) = mkName n greNameToName (FieldGreName fl) = mkName $ flSelector fl #else availInfoNames (Avail n) = [mkName n] availInfoNames (AvailTC n ns _) = mkName n:map mkName ns #endif -- | absVarLoc' -- Switches all file paths in Var namesand Ticks to be absolute absVarLoc :: HM.HashMap G2.Name G2.Expr -> IO (HM.HashMap G2.Name G2.Expr) absVarLoc = mapM absVarLoc' absVarLoc' :: G2.Expr -> IO G2.Expr absVarLoc' (G2.Var (G2.Id (G2.Name n m i (Just s)) t)) = do return $ G2.Var $ G2.Id (G2.Name n m i (Just $ s)) t absVarLoc' (G2.App e1 e2) = do e1' <- absVarLoc' e1 e2' <- absVarLoc' e2 return $ G2.App e1' e2' absVarLoc' (G2.Lam u i e) = return . G2.Lam u i =<< absVarLoc' e absVarLoc' (G2.Let b e) = do b' <- mapM (\(i, be) -> do be' <- absVarLoc' be return (i, be') ) b e' <- absVarLoc' e return $ G2.Let b' e' absVarLoc' (G2.Case e i t as) = do e' <- absVarLoc' e as' <- mapM (\(G2.Alt a ae) -> return . G2.Alt a =<< absVarLoc' ae) as return $ G2.Case e' i t as' absVarLoc' (G2.Cast e c) = do e' <- absVarLoc' e return $ G2.Cast e' c absVarLoc' (G2.Tick (G2.Breakpoint s) e) = do s' <- absLocSpan s let t' = G2.Breakpoint s' e' <- absVarLoc' e return $ G2.Tick t' e' absVarLoc' (G2.Assume fc e1 e2) = do e1' <- absVarLoc' e1 e2' <- absVarLoc' e2 return $ G2.Assume fc e1' e2' absVarLoc' (G2.Assert fc e1 e2) = do e1' <- absVarLoc' e1 e2' <- absVarLoc' e2 return $ G2.Assert fc e1' e2' absVarLoc' e = return e absLocSpan :: G2.Span -> IO G2.Span absLocSpan s@G2.Span {G2.start = st, G2.end = en} = do st' <- absLoc st en' <- absLoc en return $ s {G2.start = st', G2.end = en'} absLoc :: G2.Loc -> IO G2.Loc absLoc l@G2.Loc {G2.file = f} = do f' <- makeAbsolute f return $ l {G2.file = f'} -- When we don't want the -- Loading stuff readFileExtractedG2 :: FilePath -> IO (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2) readFileExtractedG2 file = do contents <- readFile file return $ read contents readAllExtractedG2s :: FilePath -> FilePath -> IO [(G2.NameMap, G2.TypeNameMap, G2.ExtractedG2)] readAllExtractedG2s root file = go [file] HS.empty [] where go :: [FilePath] -> HS.HashSet FilePath -> [(G2.NameMap, G2.TypeNameMap, G2.ExtractedG2)] -> IO [(G2.NameMap, G2.TypeNameMap, G2.ExtractedG2)] go [] _ accum = return accum go (tgt : todos) visited accum = let absPath = root ++ "/" ++ tgt in if HS.member absPath visited then go todos visited accum else do (nameMap, tyNameMap, exg2) <- readFileExtractedG2 absPath -- Dependencies are relative paths let deps = map (\d -> (T.unpack d) ++ ".g2i") $ G2.exg2_deps exg2 let todos' = todos ++ deps let visited' = HS.insert absPath visited let accum' = accum ++ [(nameMap, tyNameMap, exg2)] go todos' visited' accum' -- Merge nm2 into nm1 rewriteNameMap :: (T.Text, Maybe T.Text) -> G2.Name -> G2.NameMap -> G2.NameMap rewriteNameMap key val@(G2.Name occ md _ _) nameMap = case HM.lookup (occ, md) nameMap of Nothing -> HM.insert key val nameMap Just new -> HM.insert key new nameMap mergeNameMap :: G2.NameMap -> G2.NameMap -> G2.NameMap mergeNameMap nm1 = foldr (\(key, name) nm1' -> rewriteNameMap key name nm1') nm1 . HM.toList -- Favors earlier in the list mergeFileExtractedG2s :: [(G2.NameMap, G2.TypeNameMap, G2.ExtractedG2)] -> (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2) mergeFileExtractedG2s [] = (HM.empty, HM.empty, G2.emptyExtractedG2) mergeFileExtractedG2s (ex : []) = ex mergeFileExtractedG2s ((nm1, tnm1, ex1) : (nm2, tnm2, ex2) : exs) = let nm' = mergeNameMap nm1 nm2 in let tnm' = mergeNameMap tnm1 tnm2 in let ex' = mergeExtractedG2s [ex1, ex2] in mergeFileExtractedG2s $ (nm', tnm', ex') : exs -- Look for the directory that contains the first instance of a *.cabal file guessProj :: FilePath -> IO FilePath guessProj tgt = do absTgt <- makeAbsolute tgt let splits = splitOn "/" absTgt potentialDirs <- filterM (dirContainsCabal) $ reverse -- since we prefer looking in backtrack manner $ map (intercalate "/") $ inits splits case potentialDirs of (d : _) -> return d -- Unable to find a .cabal file at all, so we take the first one -- with the file loped off. [] -> return $ takeDirectory absTgt dirContainsCabal :: FilePath -> IO Bool dirContainsCabal "" = return False dirContainsCabal dir = do exists <- doesDirectoryExist dir if exists then do files <- listDirectory dir return $ any (\f -> ".cabal" `isSuffixOf` f) files else return $ False findCabal :: FilePath -> IO (Maybe FilePath) findCabal fp = do dir <- guessProj fp files <- listDirectory dir return $ find (\f -> ".cabal" `isSuffixOf` f) files ------------------------------------------------------------------------------- -- Unsafe construction ------------------------------------------------------------------------------- mkUnsafe :: G2.NamesM a -> a mkUnsafe nms = SM.evalState nms (HM.empty, HM.empty) -- | Makes an Id, not respecting uniques mkIdUnsafe :: Id -> G2.Id mkIdUnsafe vid = mkUnsafe (liftM2 G2.Id (return . mkName . varName $ vid) (mkType . varType $ vid)) -- | Makes a TyCon, not respecting uniques mkTyConNameUnsafe :: TyCon -> G2.Name mkTyConNameUnsafe tc = mkUnsafe (mkTyConName tc) -- | Makes a Data, not respecting uniques mkDataUnsafe :: DataCon -> G2.DataCon mkDataUnsafe dc = mkUnsafe (mkData dc)