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