Don't try to inline non-normalizeable top level functions.
[matthijs/master-project/cλash.git] / cλash / CLasH / Utils / HsTools.hs
1 {-# LANGUAGE ViewPatterns #-}
2 module CLasH.Utils.HsTools where
3
4 -- Standard modules
5 import qualified Unsafe.Coerce
6 import qualified Maybe
7
8 -- GHC API
9 import qualified GHC
10 import qualified HscMain
11 import qualified HscTypes
12 import qualified DynFlags
13 import qualified FastString
14 import qualified StringBuffer
15 import qualified MonadUtils
16 import Outputable ( showSDoc, ppr )
17 import qualified Outputable
18 -- Lexer & Parser, i.e. up to HsExpr
19 import qualified Lexer
20 import qualified Parser
21 -- HsExpr representation, renaming, typechecking and desugaring
22 -- (i.e., everything up to Core).
23 import qualified HsSyn
24 import qualified HsExpr
25 import qualified HsTypes
26 import qualified HsBinds
27 import qualified TcRnMonad
28 import qualified TcRnTypes
29 import qualified RnExpr
30 import qualified RnEnv
31 import qualified TcExpr
32 import qualified TcEnv
33 import qualified TcSimplify
34 import qualified TcTyFuns
35 import qualified Desugar
36 import qualified InstEnv
37 import qualified FamInstEnv
38 import qualified PrelNames
39 import qualified Module
40 import qualified OccName
41 import qualified RdrName
42 import qualified Name
43 import qualified TysWiredIn
44 import qualified SrcLoc
45 import qualified LoadIface
46 import qualified BasicTypes
47 import qualified Bag
48 -- Core representation and handling
49 import qualified CoreSyn
50 import qualified Id
51 import qualified Type
52 import qualified TyCon
53
54
55 -- Local imports
56 import CLasH.Utils.GhcTools
57 import CLasH.Utils.Core.CoreShow
58
59 -- | Translate a HsExpr to a Core expression. This does renaming, type
60 -- checking, simplification of class instances and desugaring. The result is
61 -- a let expression that holds the given expression and a number of binds that
62 -- are needed for any type classes used to work. For example, the HsExpr:
63 --  \x = x == (1 :: Int)
64 -- will result in the CoreExpr
65 --  let 
66 --    $dInt = ...
67 --    (==) = Prelude.(==) Int $dInt 
68 --  in 
69 --    \x = (==) x 1
70 toCore ::
71   HsSyn.HsExpr RdrName.RdrName -- ^ The expression to translate to Core.
72   -> GHC.Ghc CoreSyn.CoreExpr -- ^ The resulting core expression.
73 toCore expr = do
74   env <- GHC.getSession
75   let icontext = HscTypes.hsc_IC env
76   
77   (binds, tc_expr) <- HscTypes.ioMsgMaybe $ MonadUtils.liftIO $ 
78     -- Translage the TcRn (typecheck-rename) monad into an IO monad
79     TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
80       (tc_expr, insts) <- TcRnMonad.getLIE $ do
81         -- Rename the expression, resulting in a HsExpr Name
82         (rn_expr, freevars) <- RnExpr.rnExpr expr
83         -- Typecheck the expression, resulting in a HsExpr Id and a list of
84         -- Insts
85         (res, _) <- TcExpr.tcInferRho (SrcLoc.noLoc rn_expr)
86         return res
87       -- Translate the instances into bindings
88       --(insts', binds) <- TcSimplify.tcSimplifyRuleLhs insts
89       binds <- TcSimplify.tcSimplifyTop insts
90       return (binds, tc_expr)
91   
92   -- Create a let expression with the extra binds (for polymorphism etc.) and
93   -- the resulting expression.
94   let letexpr = SrcLoc.noLoc $ HsExpr.HsLet 
95         (HsBinds.HsValBinds $ HsBinds.ValBindsOut [(BasicTypes.NonRecursive, binds)] [])
96         tc_expr
97   -- Desugar the expression, resulting in core.
98   let rdr_env  = HscTypes.ic_rn_gbl_env icontext
99   desugar_expr <- HscTypes.ioMsgMaybe $ Desugar.deSugarExpr env PrelNames.iNTERACTIVE rdr_env HscTypes.emptyTypeEnv letexpr
100
101   return desugar_expr
102
103 -- | Create an Id from a RdrName. Might not work for DataCons...
104 mkId :: RdrName.RdrName -> GHC.Ghc Id.Id
105 mkId rdr_name = do
106   env <- GHC.getSession
107   id <- HscTypes.ioMsgMaybe $ MonadUtils.liftIO $ 
108     -- Translage the TcRn (typecheck-rename) monad in an IO monad
109     TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ 
110       -- Automatically import all available modules, so fully qualified names
111       -- always work
112       TcRnMonad.setOptM DynFlags.Opt_ImplicitImportQualified $ do
113         -- Lookup a Name for the RdrName. This finds the package (version) in
114         -- which the name resides.
115         name <- RnEnv.lookupGlobalOccRn rdr_name
116         -- Lookup an Id for the Name. This finds out the the type of the thing
117         -- we're looking for.
118         --
119         -- Note that tcLookupId doesn't seem to work for DataCons. See source for
120         -- tcLookupId to find out.
121         TcEnv.tcLookupId name 
122   return id
123
124 normaliseType ::
125   HscTypes.HscEnv
126   -> Type.Type
127   -> IO Type.Type
128 normaliseType env ty = do
129    (err, nty) <- MonadUtils.liftIO $
130      -- Initialize the typechecker monad
131      TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do
132        -- Normalize the type
133        (_, nty) <- TcTyFuns.tcNormaliseFamInst ty
134        return nty
135    let normalized_ty = Maybe.fromJust nty
136    return normalized_ty
137
138 -- | Translate a core Type to an HsType. Far from complete so far.
139 coreToHsType :: Type.Type -> HsTypes.LHsType RdrName.RdrName
140 --  Translate TyConApps
141 coreToHsType ty = case Type.splitTyConApp_maybe ty of
142   Just (tycon, tys) ->
143     foldl (\t a -> SrcLoc.noLoc $ HsTypes.HsAppTy t a) tycon_ty (map coreToHsType tys)
144     where
145       tycon_name = TyCon.tyConName tycon
146       mod_name = Module.moduleName $ Name.nameModule tycon_name
147       occ_name = Name.nameOccName tycon_name
148       tycon_rdrname = RdrName.mkRdrQual mod_name occ_name
149       tycon_ty = SrcLoc.noLoc $ HsTypes.HsTyVar tycon_rdrname
150   Nothing -> error $ "HsTools.coreToHsType Cannot translate non-tycon type"
151
152 -- | Evaluate a CoreExpr and return its value. For this to work, the caller
153 --   should already know the result type for sure, since the result value is
154 --   unsafely coerced into this type.
155 execCore :: CoreSyn.CoreExpr -> GHC.Ghc a
156 execCore expr = do
157         -- Setup session flags (yeah, this seems like a noop, but
158         -- setSessionDynFlags really does some extra work...)
159         dflags <- GHC.getSessionDynFlags
160         GHC.setSessionDynFlags dflags
161         -- Compile the expressions. This runs in the IO monad, but really wants
162         -- to run an IO-monad-inside-a-GHC-monad for some reason. I don't really
163         -- understand what it means, but it works.
164         env <- GHC.getSession
165         let srcspan = SrcLoc.noSrcSpan
166         hval <- MonadUtils.liftIO $ HscMain.compileExpr env srcspan expr
167         let res = Unsafe.Coerce.unsafeCoerce hval :: Int
168         return $ Unsafe.Coerce.unsafeCoerce hval
169
170 -- These functions build (parts of) a LHSExpr RdrName.
171
172 -- | A reference to the Prelude.undefined function.
173 hsUndef :: HsExpr.LHsExpr RdrName.RdrName
174 hsUndef = SrcLoc.noLoc $ HsExpr.HsVar PrelNames.undefined_RDR
175
176 -- | A typed reference to the Prelude.undefined function.
177 hsTypedUndef :: HsTypes.LHsType RdrName.RdrName -> HsExpr.LHsExpr RdrName.RdrName
178 hsTypedUndef ty = SrcLoc.noLoc $ HsExpr.ExprWithTySig hsUndef ty
179
180 -- | Create a qualified RdrName from a module name and a variable name
181 mkRdrName :: String -> String -> RdrName.RdrName
182 mkRdrName mod var =
183     RdrName.mkRdrQual (Module.mkModuleName mod) (OccName.mkVarOcc var)
184
185 -- These three functions are simplified copies of those in HscMain, because
186 -- those functions are not exported. These versions have all error handling
187 -- removed.
188 hscParseType = hscParseThing Parser.parseType
189 hscParseStmt = hscParseThing Parser.parseStmt
190
191 hscParseThing :: Lexer.P thing -> DynFlags.DynFlags -> String -> GHC.Ghc thing
192 hscParseThing parser dflags str = do
193     buf <- MonadUtils.liftIO $ StringBuffer.stringToStringBuffer str
194     let loc  = SrcLoc.mkSrcLoc (FastString.fsLit "<interactive>") 1 0
195     let Lexer.POk _ thing = Lexer.unP parser (Lexer.mkPState buf loc dflags)
196     return thing
197
198 -- | This function imports the module with the given name, for the renamer /
199 -- typechecker to use. It also imports any "orphans" and "family instances"
200 -- from modules included by this module, but not the actual modules
201 -- themselves. I'm not 100% sure how this works, but it seems that any
202 -- functions defined in included modules are available just by loading the
203 -- original module, and by doing this orphan stuff, any (type family or class)
204 -- instances are available as well.
205 --
206 -- Most of the code is based on tcRnImports and rnImportDecl, but those
207 -- functions do a lot more (which I hope we won't need...).
208 importModule :: Module.ModuleName -> TcRnTypes.RnM ()
209 importModule mod = do
210   let reason = Outputable.text "Hardcoded import" -- Used for trace output
211   let pkg = Nothing
212   -- Load the interface.
213   iface <- LoadIface.loadSrcInterface reason mod False pkg
214   -- Load orphan an familiy instance dependencies as well. I think these
215   -- dependencies are needed for the type checker to know all instances. Any
216   -- other instances (on other packages) are only useful to the
217   -- linker, so we can probably safely ignore them here. Dependencies within
218   -- the same package are also listed in deps, but I'm not so sure what to do
219   -- with them.
220   let deps = HscTypes.mi_deps iface
221   let orphs = HscTypes.dep_orphs deps
222   let finsts = HscTypes.dep_finsts deps
223   LoadIface.loadOrphanModules orphs False
224   LoadIface.loadOrphanModules finsts True