g2-0.1.0.0: src/G2/Translation/Haskell.hs
{-# LANGUAGE OverloadedStrings #-}
-- | Haskell Translation
module G2.Translation.Haskell
( loadProj
, guessProj
, hskToG2ViaModGuts
, hskToG2ViaModGutsFromFile
, hskToG2ViaCgGuts
, hskToG2ViaCgGutsFromFile
, mkCgGutsClosure
, mkModDetailsClosure
, mergeExtractedG2s
, mkIOString
, prim_list
, mkRawCore
, rawDump
, mkExpr
, mkId
, mkIdUnsafe
, mkName
, mkTyConName
, mkData
, mkSpan
, mkRealSpan
, absVarLoc
, readFileExtractedG2
, readAllExtractedG2s
, mergeFileExtractedG2s
, findCabal
) where
import qualified G2.Language.TypeEnv as G2 (AlgDataTy (..), ProgramType)
import qualified G2.Language.Syntax as G2
-- import qualified G2.Language.Typing as G2
import qualified G2.Translation.TransTypes as G2
import Avail
import qualified Class as C
import Coercion
import CoreSyn
import DataCon
import DynFlags
import FastString
import GHC
import GHC.Paths
import HscMain
import HscTypes
import IdInfo
import InstEnv
import Literal
import Name
import Outputable
import Pair
import SrcLoc
import TidyPgm
import TyCon
import TyCoRep
import Unique
import Var as V
import Control.Monad
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
mkIOString :: (Outputable a) => a -> IO String
mkIOString obj = runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
return (showPpr dflags obj)
mkRawCore :: FilePath -> IO CoreModule
mkRawCore fp = runGhc (Just libdir) $ do
_ <- setSessionDynFlags =<< getSessionDynFlags
-- compileToCoreModule fp
compileToCoreSimplified fp
rawDump :: FilePath -> IO ()
rawDump fp = do
core <- mkRawCore fp
str <- mkIOString core
putStrLn str
equivMods :: HM.HashMap T.Text T.Text
equivMods = HM.fromList
[ ("GHC.Classes2", "GHC.Classes")
, ("GHC.Types2", "GHC.Types")
, ("GHC.Integer2", "GHC.Integer")
, ("GHC.Integer.Type2", "GHC.Integer.Type")
, ("GHC.Prim2", "GHC.Prim")
, ("GHC.Tuple2", "GHC.Tuple")
, ("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 = 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' { -- Profiling fails to load a profiler friendly version of the base
-- without this special casing for hscTarget, but we can't use HscInterpreted when we have certain unboxed types
hscTarget = if rtsIsProfiled
then HscInterpreted
else case hsc of
Just hsc' -> hsc'
_ -> hscTarget beta_flags'
, ghcLink = LinkInMemory
, ghcMode = CompManager
, includePaths = proj ++ includePaths beta_flags'
, 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}
_ <- setSessionDynFlags dflags
targets <- mapM (flip guessTarget Nothing) src
_ <- setTargets targets
load LoadAllTargets
-- 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
closures <- mkCgGutsModDetailsClosuresFromFile hsc proj src tr_con
return $ hskToG2ViaCgGuts nm tm closures tr_con
hskToG2ViaCgGuts :: G2.NameMap
-> G2.TypeNameMap
-> [(G2.CgGutsClosure, G2.ModDetailsClosure)]
-> G2.TranslationConfig
-> (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2)
hskToG2ViaCgGuts nm tm pairs tr_con = do
let (nm2, tm2, exg2s) = foldr (\(c, m) (nm', tm', exs) ->
let mgcc = cgGutsModDetailsClosureToModGutsClosure c m in
let (nm'', tm'', g2) = modGutsClosureToG2 nm' tm' mgcc tr_con in
(nm'', tm'', g2 : exs))
(nm, tm, [])
pairs in
(nm2, tm2, 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
}
mkCgGutsModDetailsClosuresFromFile :: Maybe HscTarget
-> [FilePath]
-> [FilePath]
-> G2.TranslationConfig
-> IO [(G2.CgGutsClosure, G2.ModDetailsClosure)]
mkCgGutsModDetailsClosuresFromFile hsc proj src tr_con = do
(env, modgutss) <- runGhc (Just libdir) $ do
_ <- loadProj hsc proj src [] tr_con
env <- getSession
mod_graph <- getModuleGraph
parsed_mods <- mapM parseModule mod_graph
typed_mods <- mapM typecheckModule parsed_mods
desug_mods <- mapM desugarModule typed_mods
return (env, map coreModule desug_mods)
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, mkModDetailsClosure (mg_deps mg) md)) $ zip tidys simplgutss
return pairs
-- | The core program in the CgGuts does not include local rules after tidying.
-- As such, we pass in the CoreProgram from the ModGuts
mkCgGutsClosure :: CoreProgram -> CgGuts -> G2.CgGutsClosure
mkCgGutsClosure bndrs cgguts =
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
, G2.cgcc_rules = concatMap ruleInfoRules . map ruleInfo . map idInfo
. concatMap bindersOf $ bndrs }
mkModDetailsClosure :: Dependencies -> ModDetails -> G2.ModDetailsClosure
mkModDetailsClosure deps moddet =
G2.ModDetailsClosure
{ G2.mdcc_cls_insts = md_insts moddet
, G2.mdcc_type_env = md_types moddet
, G2.mdcc_exports = exportedNames moddet
, G2.mdcc_deps = map (moduleNameString . fst) $ dep_mods 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
return $ hskToG2ViaModGuts nm tm closures tr_con
hskToG2ViaModGuts :: G2.NameMap
-> G2.TypeNameMap
-> [G2.ModGutsClosure]
-> G2.TranslationConfig
-> (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2)
hskToG2ViaModGuts nm tm modgutss tr_con =
let (nm2, tm2, exg2s) = foldr (\m (nm', tm', cls) ->
let (nm'', tm'', mc) = modGutsClosureToG2 nm' tm' m tr_con in
(nm'', tm'', mc : cls))
(nm, tm, [])
modgutss in
(nm2, tm2, mergeExtractedG2s exg2s)
modGutsClosureToG2 :: G2.NameMap
-> G2.TypeNameMap
-> G2.ModGutsClosure
-> G2.TranslationConfig
-> (G2.NameMap, G2.TypeNameMap, G2.ExtractedG2)
modGutsClosureToG2 nm tm mgcc tr_con =
let breaks = G2.mgcc_breaks mgcc in
-- Do the binds
let (nm2, binds) = foldr (\b (nm', bs) ->
let (nm'', bs') = mkBinds nm' tm breaks b in
(nm'', bs ++ bs'))
(nm, [])
(G2.mgcc_binds mgcc) in
-- Do the tycons
let raw_tycons = G2.mgcc_tycons mgcc ++ typeEnvTyCons (G2.mgcc_type_env mgcc) in
let (nm3, tm2, tycons) = foldr (\tc (nm', tm', tcs) ->
let ((nm'', tm''), mb_t) = mkTyCon nm' tm' tc in
(nm'', tm'', maybeToList mb_t ++ tcs))
(nm2, tm, [])
raw_tycons in
-- Do the class
let classes = map (mkClass tm2) $ G2.mgcc_cls_insts mgcc in
-- Do the rules
let rules = if G2.load_rewrite_rules tr_con
then mapMaybe (mkRewriteRule nm3 tm2 breaks) $ G2.mgcc_rules mgcc
else [] in
-- Do the exports
let exports = G2.mgcc_exports mgcc in
let deps = fmap T.pack $ G2.mgcc_deps mgcc in
(nm3, tm2,
G2.ExtractedG2
{ G2.exg2_mod_names = maybeToList $ 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 = 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
parsed_mods <- mapM parseModule mod_graph
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 (hscSimplify env) modgutss
closures <- mapM (mkModGutsClosure env) simpls
return closures
else do
closures <- mapM (mkModGutsClosure env) modgutss
return closures
-- This one will need to do the Tidy program stuff
mkModGutsClosure :: HscEnv -> ModGuts -> IO G2.ModGutsClosure
mkModGutsClosure env modguts = do
(cgguts, moddets) <- tidyProgram env modguts
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 = md_insts moddets
, G2.mgcc_type_env = md_types moddets
, G2.mgcc_exports = exportedNames moddets
, G2.mgcc_deps = map (moduleNameString . fst) $ dep_mods $ mg_deps modguts
, G2.mgcc_rules = mg_rules modguts
}
-- 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 ++ G2.exg2_binds g2'
, G2.exg2_tycons = G2.exg2_tycons g2 ++ 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 :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> CoreBind -> (G2.NameMap, [(G2.Id, G2.Expr)])
mkBinds nm tm mb (NonRec var expr) =
let
(i, nm') = mkIdUpdatingNM var nm tm
in
(nm', [(i, mkExpr nm' tm mb expr)])
mkBinds nm tm mb (Rec ves) =
mapAccumR (\nm' (v, e) ->
let
(i, nm'') = mkIdUpdatingNM v nm' tm
in
(nm'', (i, mkExpr nm'' tm mb e))
) nm ves
mkExpr :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> CoreExpr -> G2.Expr
mkExpr nm tm _ (Var var) = G2.Var (mkIdLookup var nm tm)
mkExpr _ _ _ (Lit lit) = G2.Lit (mkLit lit)
mkExpr nm tm mb (App fxpr axpr) = G2.App (mkExpr nm tm mb fxpr) (mkExpr nm tm mb axpr)
mkExpr nm tm mb (Lam var expr) = G2.Lam (mkLamUse var) (mkId tm var) (mkExpr nm tm mb expr)
mkExpr nm tm mb (Let bnd expr) = G2.Let (mkBind nm tm mb bnd) (mkExpr nm tm mb expr)
mkExpr nm tm mb (Case mxpr var _ alts) = G2.Case (mkExpr nm tm mb mxpr) (mkId tm var) (mkAlts nm tm mb alts)
mkExpr nm tm mb (Cast expr c) = G2.Cast (mkExpr nm tm mb expr) (mkCoercion tm c)
mkExpr _ tm _ (Coercion c) = G2.Coercion (mkCoercion tm c)
mkExpr nm tm mb (Tick t expr) =
case createTickish mb t of
Just t' -> G2.Tick t' $ mkExpr nm tm mb expr
Nothing -> mkExpr nm tm mb expr
mkExpr _ tm _ (Type ty) = G2.Type (mkType tm ty)
createTickish :: Maybe ModBreaks -> Tickish i -> Maybe G2.Tickish
createTickish (Just mb) (Breakpoint {breakpointId = bid}) =
case mkSpan $ modBreaks_locs mb A.! bid of
Just s -> Just $ G2.Breakpoint $ s
Nothing -> Nothing
createTickish _ _ = Nothing
mkLamUse :: Id -> G2.LamUse
mkLamUse v
| isTyVar v = G2.TypeL
| otherwise = G2.TermL
mkId :: G2.TypeNameMap -> Id -> G2.Id
mkId tm vid = G2.Id ((mkName . V.varName) vid) ((mkType tm . varType) vid)
-- Makes an Id, not respecting UniqueIds
mkIdUnsafe :: Id -> G2.Id
mkIdUnsafe vid = G2.Id ((mkName . V.varName) vid) (mkType HM.empty . varType $ vid)
mkIdLookup :: Id -> G2.NameMap -> G2.TypeNameMap -> G2.Id
mkIdLookup i nm tm =
let
n = mkNameLookup (V.varName i) nm
t = mkType tm . varType $ i
in
G2.Id n t
mkIdUpdatingNM :: Id -> G2.NameMap -> G2.TypeNameMap -> (G2.Id, G2.NameMap)
mkIdUpdatingNM vid nm tm =
let
n@(G2.Name n' m _ _) = flip mkNameLookup nm . V.varName $ vid
i = G2.Id n ((mkType tm . varType) vid)
nm' = HM.insert (n', m) n nm
in
(i, nm')
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
mkNameLookup :: Name -> G2.NameMap -> G2.Name
mkNameLookup name nm =
-- 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
case mdl of
Nothing -> G2.Name occ mdl unq sp
_ -> case HM.lookup (occ, mdl) nm of
Just (G2.Name n' m i _) -> G2.Name n' m i sp
Nothing -> 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
mkSpan :: SrcSpan -> Maybe G2.Span
mkSpan (RealSrcSpan s) = Just $ mkRealSpan s
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
mkLit (MachChar chr) = G2.LitChar chr
mkLit (MachStr bstr) = G2.LitString (C.unpack bstr)
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 (MachFloat rat) = G2.LitFloat rat
mkLit (MachDouble rat) = G2.LitDouble rat
mkLit (LitInteger i _) = G2.LitInteger (fromInteger i)
mkLit _ = error "mkLit: unhandled Lit"
-- mkLit (MachNullAddr) = error "mkLit: MachNullAddr"
-- mkLit (MachLabel _ _ _ ) = error "mkLit: MachLabel"
mkBind :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> CoreBind -> [(G2.Id, G2.Expr)]
mkBind nm tm mb (NonRec var expr) = [(mkId tm var, mkExpr nm tm mb expr)]
mkBind nm tm mb (Rec ves) = map (\(v, e) -> (mkId tm v, mkExpr nm tm mb e)) ves
mkAlts :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> [CoreAlt] -> [G2.Alt]
mkAlts nm tm mb = map (mkAlt nm tm mb)
mkAlt :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> CoreAlt -> G2.Alt
mkAlt nm tm mb (acon, prms, expr) = G2.Alt (mkAltMatch nm tm acon prms) (mkExpr nm tm mb expr)
mkAltMatch :: G2.NameMap -> G2.TypeNameMap -> AltCon -> [Var] -> G2.AltMatch
mkAltMatch nm tm (DataAlt dcon) params = G2.DataAlt (mkData nm tm dcon) (map (mkId tm) params)
mkAltMatch _ _ (LitAlt lit) _ = G2.LitAlt (mkLit lit)
mkAltMatch _ _ (DEFAULT) _ = G2.Default
mkType :: G2.TypeNameMap -> Type -> G2.Type
mkType tm (TyVarTy v) = G2.TyVar $ mkId tm v
mkType tm (AppTy t1 t2) = G2.TyApp (mkType tm t1) (mkType tm t2)
mkType tm (FunTy t1 t2) = G2.TyFun (mkType tm t1) (mkType tm t2)
mkType tm (ForAllTy b ty) = G2.TyForAll (mkTyBinder tm b) (mkType tm ty)
mkType _ (LitTy _) = G2.TyBottom
-- mkType _ (CastTy _ _) = error "mkType: CastTy"
mkType _ (CastTy _ _) = G2.TyUnknown
mkType _ (CoercionTy _) = G2.TyUnknown
-- mkType _ (CoercionTy _) = error "mkType: Coercion"
mkType tm (TyConApp tc ts)
| isFunTyCon tc
, length ts == 2 =
case ts of
(t1:t2:[]) -> G2.TyFun (mkType tm t1) (mkType tm t2)
_ -> error "mkType: non-arity 2 FunTyCon from GHC"
| G2.Name n _ _ _ <- mkName $ tyConName tc
, n == "TYPE" = G2.TYPE
| otherwise = mkG2TyCon (mkTyConName tm tc) (map (mkType tm) ts) (mkType tm $ tyConKind tc)
mkTyCon :: G2.NameMap -> G2.TypeNameMap -> TyCon -> ((G2.NameMap, G2.TypeNameMap), Maybe G2.ProgramType)
mkTyCon nm tm t = case dcs of
Just dcs' -> ((nm'', tm''), Just (n, dcs'))
Nothing -> ((nm'', tm''), Nothing)
where
n@(G2.Name n' m _ _) = flip mkNameLookup tm . tyConName $ t
tm' = HM.insert (n', m) n tm
nm' = foldr (uncurry HM.insert) nm
$ map (\n_@(G2.Name n'_ m_ _ _) -> ((n'_, m_), n_))
$ map (flip mkNameLookup nm . dataConName) $ visibleDataCons (algTyConRhs t)
bv = map (mkId tm) $ tyConTyVars t
(nm'', tm'', dcs, dcsf) =
case isAlgTyCon t of
True -> case algTyConRhs t of
DataTyCon { data_cons = dc } ->
( nm'
, tm'
, Just $ G2.DataTyCon bv $ map (mkData nm' tm) dc
, Just $ map (mkId tm'' . dataConWorkId) dc)
NewTyCon { data_con = dc
, nt_rhs = rhst} ->
( nm'
, tm'
, Just $ G2.NewTyCon { G2.bound_ids = bv
, G2.data_con = mkData nm' tm dc
, G2.rep_type = mkType tm rhst}
, Just $ [(mkId tm'' . dataConWorkId) dc])
AbstractTyCon {} -> error "Unhandled TyCon AbstractTyCon"
-- TupleTyCon {} -> error "Unhandled TyCon TupleTyCon"
TupleTyCon { data_con = dc } ->
( nm'
, tm'
, Just $ G2.DataTyCon bv $ [mkData nm' tm dc]
, Nothing)
SumTyCon {} -> error "Unhandled TyCon SumTyCon"
False -> case isTypeSynonymTyCon t of
True ->
let
(tv, st) = fromJust $ synTyConDefn_maybe t
st' = mkType tm st
tv' = map (mkId tm) tv
in
(nm, tm', Just $ G2.TypeSynonym { G2.bound_ids = tv'
, G2.synonym_of = st'}, Nothing)
False -> (nm, tm, Nothing, Nothing)
-- dcs = if isDataTyCon t then map mkData . data_cons . algTyConRhs $ t else []
mkTyConName :: G2.TypeNameMap -> TyCon -> G2.Name
mkTyConName tm tc =
let
n@(G2.Name n' m _ l) = mkName $ tyConName tc
in
case HM.lookup (n', m) tm of
Just (G2.Name n'' m' i _) -> G2.Name n'' m' i l
Nothing -> n
mkData :: G2.NameMap -> G2.TypeNameMap -> DataCon -> G2.DataCon
mkData nm tm datacon = G2.DataCon name ty
where
name = mkDataName nm datacon
ty = (mkType tm . dataConRepType) datacon
mkDataName :: G2.NameMap -> DataCon -> G2.Name
mkDataName nm datacon = (flip mkNameLookup nm . dataConName) datacon
mkTyBinder :: G2.TypeNameMap -> TyVarBinder -> G2.TyBinder
mkTyBinder tm (TvBndr v _) = G2.NamedTyBndr (mkId tm v)
prim_list :: [String]
prim_list = [">=", ">", "==", "/=", "<=", "<",
"&&", "||", "not",
"+", "-", "*", "/", "implies", "negate", "error", "iff" ]
mkCoercion :: G2.TypeNameMap -> Coercion -> G2.Coercion
mkCoercion tm c =
let
k = fmap (mkType tm) $ coercionKind c
in
(pFst k) G2.:~ (pSnd k)
mkClass :: G2.TypeNameMap -> ClsInst -> (G2.Name, G2.Id, [G2.Id])
mkClass tm (ClsInst { is_cls = c, is_dfun = dfun }) =
(flip mkNameLookup tm . C.className $ c, mkId tm dfun, map (mkId tm) $ C.classTyVars c)
mkRewriteRule :: G2.NameMap -> G2.TypeNameMap -> Maybe ModBreaks -> CoreRule -> Maybe G2.RewriteRule
mkRewriteRule nm tm breaks (Rule { ru_name = n
, ru_fn = fn
, ru_rough = rough
, ru_bndrs = bndrs
, ru_args = args
, ru_rhs = rhs }) =
let
r = G2.RewriteRule { G2.ru_name = T.pack $ unpackFS n
, G2.ru_head = mkNameLookup fn nm
, G2.ru_rough = map (fmap (flip mkNameLookup nm)) rough
, G2.ru_bndrs = map (mkId tm) bndrs
, G2.ru_args = map (mkExpr nm tm breaks) args
, G2.ru_rhs = mkExpr nm tm breaks rhs }
in
Just r
mkRewriteRule _ _ _ _ = Nothing
exportedNames :: ModDetails -> [G2.ExportedName]
exportedNames = concatMap availInfoNames . md_exports
availInfoNames :: AvailInfo -> [G2.ExportedName]
availInfoNames (Avail n) = [mkName n]
availInfoNames (AvailTC n ns _) = mkName n:map mkName ns
-- | absVarLoc'
-- Switches all file paths in Var namesand Ticks to be absolute
absVarLoc :: G2.Program -> IO G2.Program
absVarLoc =
mapM
(mapM (\(i, e) -> do
e' <- absVarLoc' e
return (i, e')
)
)
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 as) = do
e' <- absVarLoc' e
as' <- mapM (\(G2.Alt a ae) -> return . G2.Alt a =<< absVarLoc' ae) as
return $ G2.Case e' i 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 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