1 -----------------------------------------------------------------------------
2 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
3 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
4 -- input HsExpr. We do this in the DsM monad, which supplies access to
5 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
6 -----------------------------------------------------------------------------
9 module DsMeta( dsBracket ) where
11 #include "HsVersions.h"
13 import {-# SOURCE #-} DsExpr ( dsExpr )
15 import DsUtils ( mkListExpr, mkStringLit, mkCoreTup,
16 mkIntExpr, mkCharExpr )
19 import qualified Language.Haskell.THSyntax as M
21 import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
22 Match(..), GRHSs(..), GRHS(..), HsBracket(..),
23 HsDoContext(ListComp,DoExpr), ArithSeqInfo(..),
24 HsBinds(..), MonoBinds(..), HsConDetails(..),
25 HsDecl(..), TyClDecl(..), ForeignDecl(..),
27 placeHolderType, tyClDeclNames,
28 collectHsBinders, collectMonoBinders,
29 collectPatBinders, collectPatsBinders
32 import Name ( Name, nameOccName, nameModule )
33 import OccName ( isDataOcc, occNameUserString )
34 import Module ( moduleUserString )
35 import PrelNames ( intLName,charLName,
36 plitName, pvarName, ptupName, pconName,
37 ptildeName, paspatName, pwildName,
38 varName, conName, litName, appName, lamName,
39 tupName, doEName, compName,
40 listExpName, condName, letEName, caseEName,
41 infixAppName, guardedName, normalName,
42 bindStName, letStName, noBindStName,
43 fromName, fromThenName, fromToName, fromThenToName,
44 funName, valName, matchName, clauseName,
45 liftName, gensymName, bindQName,
46 matTyConName, expTyConName, clsTyConName,
47 pattTyConName, exprTyConName, declTyConName
52 import Type ( Type, mkGenTyConApp )
53 import TysWiredIn ( stringTy )
55 import CoreUtils ( exprType )
56 import Panic ( panic )
59 import FastString ( mkFastString )
61 -----------------------------------------------------------------------------
62 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
63 -- Returns a CoreExpr of type M.Expr
64 -- The quoted thing is parameterised over Name, even though it has
65 -- been type checked. We don't want all those type decorations!
67 dsBracket (ExpBr e) splices
68 = dsExtendMetaEnv new_bit (repE e) `thenDs` \ (MkC new_e) ->
71 new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices]
74 {- -------------- Examples --------------------
78 gensym (unpackString "x"#) `bindQ` \ x1::String ->
79 lam (pvar x1) (var x1)
82 [| \x -> $(f [| x |]) |]
84 gensym (unpackString "x"#) `bindQ` \ x1::String ->
85 lam (pvar x1) (f (var x1))
89 -----------------------------------------------------------------------------
93 repDs :: [HsDecl Name] -> DsM (Core [M.Decl])
95 = do { ds' <- mapM repD ds ;
96 coreList declTyConName ds' }
98 repD :: HsDecl Name -> DsM (Core M.Decl)
99 repD (TyClD (TyData { tcdND = DataType, tcdCtxt = [],
100 tcdName = tc, tcdTyVars = tvs,
101 tcdCons = cons, tcdDerivs = mb_derivs }))
102 = do { tc1 <- localVar tc ;
103 cons1 <- mapM repCon cons ;
105 cons2 <- coreList consTyConName cons1 ;
106 derivs1 <- repDerivs mb_derivs ;
107 derivs2 <- coreList stringTyConName derivs1 ;
108 repData tc1 tvs1 cons2 derivs2 }
110 repD (TyClD (ClassD { tcdCtxt = cxt, tcdName = cls,
111 tcdTyVars = tvs, tcdFDs = [],
112 tcdSigs = sigs, tcdMeths = Just decls
114 = do { cls1 <- localVar cls ;
116 cxt1 <- repCtxt cxt ;
117 sigs1 <- repSigs sigs ;
118 repClass cxt1 cls1 tvs1 sigs1 }
120 repD (InstD (InstDecl ty binds _ _ loc))
121 -- Ignore user pragmas for now
122 = do { cls1 <- localVar cls ;
123 cxt1 <- repCtxt cxt ;
125 binds1 <- repMonoBind binds ;
126 binds2 <- coreList declTyConName binds1 ;
129 (tvs, cxt, cls, tys) = splitHsInstDeclTy ty
132 repD d = do { dsWarn (hang (ptext SLIT("Cannot desugar this Template Haskell declaration:"))
134 return (ValD EmptyBinds) -- A sort of empty decl
137 repTvs :: [HsTyVarBndr Name] -> DsM (Core [String])
138 repTvs tvs = do { tvs1 <- mapM (localVar . hsTyVarName) tvs ;
139 coreList stringTyConName tvs1 }
141 repCtxt :: HsContext Name -> DsM (Core M.Ctxt)
145 repTy :: HsType Name -> DsM (Core M.Type)
146 repTy ty@(HsForAllTy _ cxt ty)
147 = pprPanic "repTy" (ppr ty)
150 = do { tv1 <- localVar tv ; repTvar tv1 }
152 repTy (HsAppTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; repTapp f1 a2 }
153 repTy (HsFunTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; tcon <- repArrowTyCon ; repTapps tcon [f1,a1] }
154 repTy (HsListTy t) = do { t1 <- repTy t ; list <- repListTyCon ; repTapp tcon t1 }
156 repTy (HsTupleTy tc tys)
158 repTy (HsOpTy ty1 HsArrow ty2) = repTy (HsFunTy ty1 ty2)
159 repTy (HsOpTy ty1 (HsTyOp n) = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2)
160 repTy (HsParTy t) = repTy t
161 repTy (HsPredTy (HsClassP c tys)) = repTy (foldl HsApp (HsTyVar c) tys)
164 [HsType name] -- Element types (length gives arity)
166 | HsKindSig (HsType name) -- (ty :: kind)
167 Kind -- A type with a kind signature
170 -----------------------------------------------------------------------------
171 -- Using the phantom type constructors "repConstructor" we define repE
172 -- This ensures we keep the types of the CoreExpr objects we build are
173 -- consistent with their real types.
175 repEs :: [HsExpr Name] -> DsM (Core [M.Expr])
176 repEs es = do { es' <- mapM repE es ;
177 coreList exprTyConName es' }
179 repE :: HsExpr Name -> DsM (Core M.Expr)
181 = do { mb_val <- dsLookupMetaEnv x
183 Nothing -> do { str <- globalVar x
184 ; if constructor x then
188 Just (Bound y) -> repVar (coreVar y)
189 Just (Splice e) -> do { e' <- dsExpr e
190 ; return (MkC e') } }
192 repE (HsIPVar x) = panic "Can't represent implicit parameters"
193 repE (HsLit l) = do { a <- repLiteral l; repLit a }
194 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
197 = do { mb_val <- dsLookupMetaEnv n
199 Just (Splice e) -> do { e' <- dsExpr e
201 other -> pprPanic "HsSplice" (ppr n) }
204 repE (HsLam m) = repLambda m
205 repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b}
206 repE (NegApp x nm) = panic "No negate yet"
207 repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b }
208 repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b }
210 repE (OpApp e1 (HsVar op) fix e2) =
211 do { arg1 <- repE e1;
213 mb_val <- dsLookupMetaEnv op;
214 the_op <- case mb_val of {
215 Nothing -> globalVar op ;
216 Just (Bound x) -> return (coreVar x) ;
217 other -> pprPanic "repE:OpApp" (ppr op) } ;
218 repInfixApp arg1 the_op arg2 }
220 repE (HsCase e ms loc)
222 ; ms2 <- mapM repMatchTup ms
223 ; repCaseE arg (nonEmptyCoreList ms2) }
225 -- I havn't got the types here right yet
226 repE (HsDo DoExpr sts _ ty loc) = do { (ss,zs) <- repSts sts;
227 e <- repDoE (nonEmptyCoreList zs);
228 combine expTyConName ss e }
229 repE (HsDo ListComp sts _ ty loc) = do { (ss,zs) <- repSts sts;
230 e <- repComp (nonEmptyCoreList zs);
231 combine expTyConName ss e }
233 repE (ArithSeqIn (From e)) = do { ds1 <- repE e; repFrom ds1 }
234 repE (ArithSeqIn (FromThen e1 e2)) = do { ds1 <- repE e1; ds2 <- repE e2;
235 repFromThen ds1 ds2 }
236 repE (ArithSeqIn (FromTo e1 e2)) = do { ds1 <- repE e1; ds2 <- repE e2;
238 repE (ArithSeqIn (FromThenTo e1 e2 e3)) = do { ds1 <- repE e1; ds2 <- repE e2;
239 ds3 <- repE e3; repFromThenTo ds1 ds2 ds3 }
241 repE (HsIf x y z loc)
242 = do { a <- repE x; b <- repE y; c <- repE z; repCond a b c }
245 do { (ss,ds) <- repDecs bs
246 ; e2 <- addBinds ss (repE e)
248 ; combine expTyConName ss z }
249 repE (HsWith _ _ _) = panic "No with for implicit parameters yet"
250 repE (ExplicitList ty es) =
251 do { xs <- repEs es; repListExp xs }
252 repE (ExplicitTuple es boxed) =
253 do { xs <- repEs es; repTup xs }
254 repE (ExplicitPArr ty es) = panic "No parallel arrays yet"
255 repE (RecordConOut _ _ _) = panic "No record construction yet"
256 repE (RecordUpdOut _ _ _ _) = panic "No record update yet"
257 repE (ExprWithTySig e ty) = panic "No expressions with type signatures yet"
260 -----------------------------------------------------------------------------
261 -- Building representations of auxillary structures like Match, Clause, Stmt,
263 repMatchTup :: Match Name -> DsM (Core M.Mtch)
264 repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
265 do { ss1 <- mkGenSyms (collectPatBinders p)
266 ; addBinds ss1 $ do {
268 ; (ss2,ds) <- repDecs wheres
269 ; addBinds ss2 $ do {
270 ; gs <- repGuards guards
271 ; match <- repMatch p1 gs ds
272 ; combine matTyConName (ss1++ss2) match }}}
274 repClauseTup :: Match Name -> DsM (Core M.Clse)
275 repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
276 do { ss1 <- mkGenSyms (collectPatsBinders ps)
277 ; addBinds ss1 $ do {
279 ; (ss2,ds) <- repDecs wheres
280 ; addBinds ss2 $ do {
281 gs <- repGuards guards
282 ; clause <- repClause ps1 gs ds
283 ; combine clsTyConName (ss1++ss2) clause }}}
285 repGuards :: [GRHS Name] -> DsM (Core M.Rihs)
286 repGuards [GRHS[ResultStmt e loc] loc2]
287 = do {a <- repE e; repNormal a }
289 = do { zs <- mapM process other;
290 repGuarded (nonEmptyCoreList (map corePair zs)) }
292 process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _)
293 = do { x <- repE e1; y <- repE e2; return (x, y) }
294 process other = panic "Non Haskell 98 guarded body"
297 -----------------------------------------------------------------------------
298 -- Representing Stmt's is tricky, especially if bound variables
299 -- shaddow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
300 -- First gensym new names for every variable in any of the patterns.
301 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
302 -- if variables didn't shaddow, the static gensym wouldn't be necessary
303 -- and we could reuse the original names (x and x).
305 -- do { x'1 <- gensym "x"
306 -- ; x'2 <- gensym "x"
307 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
308 -- , BindSt (pvar x'2) [| f x |]
309 -- , NoBindSt [| g x |]
313 -- The strategy is to translate a whole list of do-bindings by building a
314 -- bigger environment, and a bigger set of meta bindings
315 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
316 -- of the expressions within the Do
318 -----------------------------------------------------------------------------
319 -- The helper function repSts computes the translation of each sub expression
320 -- and a bunch of prefix bindings denoting the dynamic renaming.
322 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.Stmt])
323 repSts [ResultStmt e loc] =
325 ; e1 <- repNoBindSt a
326 ; return ([], [e1]) }
327 repSts (BindStmt p e loc : ss) =
329 ; ss1 <- mkGenSyms (collectPatBinders p)
330 ; addBinds ss1 $ do {
332 ; (ss2,zs) <- repSts ss
333 ; z <- repBindSt p1 e2
334 ; return (ss1++ss2, z : zs) }}
335 repSts (LetStmt bs : ss) =
336 do { (ss1,ds) <- repDecs bs
338 ; (ss2,zs) <- addBinds ss1 (repSts ss)
339 ; return (ss1++ss2, z : zs) }
340 repSts (ExprStmt e ty loc : ss) =
342 ; z <- repNoBindSt e2
343 ; (ss2,zs) <- repSts ss
344 ; return (ss2, z : zs) }
345 repSts other = panic "Exotic Stmt in meta brackets"
349 repDecs :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl])
351 = do { let { bndrs = collectHsBinders decs } ;
352 ss <- mkGenSyms bndrs ;
353 core <- addBinds ss (rep_decs decs) ;
354 core_list <- coreList declTyConName core ;
355 return (ss, core_list) }
357 rep_decs :: HsBinds Name -> DsM [Core M.Decl]
358 rep_decs EmptyBinds = return []
359 rep_decs (ThenBinds x y)
360 = do { core1 <- rep_decs x
361 ; core2 <- rep_decs y
362 ; return (core1 ++ core2) }
363 rep_decs (MonoBind bs sigs _)
364 = do { core1 <- repMonoBind bs
365 ; core2 <- rep_sigs sigs
366 ; return (core1 ++ core2) }
368 rep_sigs sigs = return [] -- Incomplete!
370 repMonoBind :: MonoBinds Name -> DsM [Core M.Decl]
371 repMonoBind EmptyMonoBinds = return []
372 repMonoBind (AndMonoBinds x y) = do { x1 <- repMonoBind x;
376 -- Note GHC treats declarations of a variable (not a pattern)
377 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
378 -- with an empty list of patterns
379 repMonoBind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
380 = do { (ss,wherecore) <- repDecs wheres
381 ; guardcore <- addBinds ss (repGuards guards)
382 ; fn' <- lookupBinder fn
384 ; ans <- repVal p guardcore wherecore
387 repMonoBind (FunMonoBind fn infx ms loc)
388 = do { ms1 <- mapM repClauseTup ms
389 ; fn' <- lookupBinder fn
390 ; ans <- repFun fn' (nonEmptyCoreList ms1)
393 repMonoBind (PatMonoBind pat (GRHSs guards wheres ty2) loc)
394 = do { patcore <- repP pat
395 ; (ss,wherecore) <- repDecs wheres
396 ; guardcore <- addBinds ss (repGuards guards)
397 ; ans <- repVal patcore guardcore wherecore
400 repMonoBind (VarMonoBind v e)
401 = do { v' <- lookupBinder v
404 ; patcore <- repPvar v'
405 ; empty_decls <- coreList declTyConName []
406 ; ans <- repVal patcore x empty_decls
409 -----------------------------------------------------------------------------
410 -- Since everything in a MonoBind is mutually recursive we need rename all
411 -- all the variables simultaneously. For example:
412 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
413 -- do { f'1 <- gensym "f"
414 -- ; g'2 <- gensym "g"
415 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
416 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
418 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
419 -- environment ( f |-> f'1 ) from each binding, and then unioning them
420 -- together. As we do this we collect GenSymBinds's which represent the renamed
421 -- variables bound by the Bindings. In order not to lose track of these
422 -- representations we build a shadow datatype MB with the same structure as
423 -- MonoBinds, but which has slots for the representations
425 -----------------------------------------------------------------------------
428 hsDeclsBinders :: [HsDecl Name] -> [Name]
429 hsDeclsBinders ds = concat (map hsDeclBinders ds)
431 hsDeclBinders (ValD b) = collectHsBinders b
432 hsDeclBinders (TyClD d) = map fst (tyClDeclNames d)
433 hsDeclBinders (ForD d) = forDeclBinders d
434 hsDeclBinders other = []
436 forDeclBinders (ForeignImport n _ _ _ _) = [n]
437 forDeclBinders other = []
440 -----------------------------------------------------------------------------
441 -- GHC seems to allow a more general form of lambda abstraction than specified
442 -- by Haskell 98. In particular it allows guarded lambda's like :
443 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
444 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
445 -- (\ p1 .. pn -> exp) by causing an error.
447 repLambda :: Match Name -> DsM (Core M.Expr)
448 repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
450 = do { let bndrs = collectPatsBinders ps ;
451 ; ss <- mkGenSyms bndrs
452 ; lam <- addBinds ss (
453 do { xs <- repPs ps; body <- repE e; repLam xs body })
454 ; combine expTyConName ss lam }
456 repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
459 -----------------------------------------------------------------------------
461 -- repP deals with patterns. It assumes that we have already
462 -- walked over the pattern(s) once to collect the binders, and
463 -- have extended the environment. So every pattern-bound
464 -- variable should already appear in the environment.
466 -- Process a list of patterns
467 repPs :: [Pat Name] -> DsM (Core [M.Patt])
468 repPs ps = do { ps' <- mapM repP ps ;
469 coreList pattTyConName ps' }
471 repP :: Pat Name -> DsM (Core M.Patt)
472 repP (WildPat _) = repPwild
473 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
474 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
475 repP (LazyPat p) = do { p1 <- repP p; repPtilde p1 }
476 repP (AsPat x p) = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 }
477 repP (ParPat p) = repP p
478 repP (ListPat ps _) = repListPat ps
479 repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs }
480 repP (ConPatIn dc details)
481 = do { con_str <- globalVar dc
483 PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs }
484 RecCon pairs -> error "No records in template haskell yet"
485 InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
487 repP other = panic "Exotic pattern inside meta brackets"
489 repListPat :: [Pat Name] -> DsM (Core M.Patt)
490 repListPat [] = do { nil_con <- coreStringLit "[]"
491 ; nil_args <- coreList pattTyConName []
492 ; repPcon nil_con nil_args }
493 repListPat (p:ps) = do { p2 <- repP p
494 ; ps2 <- repListPat ps
495 ; cons_con <- coreStringLit ":"
496 ; repPcon cons_con (nonEmptyCoreList [p2,ps2]) }
499 ----------------------------------------------------------
502 repLiteral :: HsLit -> DsM (Core M.Lit)
503 repLiteral (HsInt i) = rep2 intLName [mkIntExpr i]
504 repLiteral (HsChar c) = rep2 charLName [mkCharExpr c]
505 repLiteral x = panic "trying to represent exotic literal"
507 repOverloadedLiteral :: HsOverLit -> DsM(Core M.Lit)
508 repOverloadedLiteral (HsIntegral i _) = rep2 intLName [mkIntExpr i]
509 repOverloadedLiteral (HsFractional f _) = panic "Cant do fractional literals yet"
512 ----------------------------------------------------------
513 -- The meta-environment
515 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
516 -- I.e. (x, x_id) means
517 -- let x_id = gensym "x" in ...
519 addBinds :: [GenSymBind] -> DsM a -> DsM a
520 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
522 lookupBinder :: Name -> DsM (Core String)
524 = do { mb_val <- dsLookupMetaEnv n;
526 Just (Bound id) -> return (MkC (Var id))
527 other -> pprPanic "Failed binder lookup:" (ppr n) }
529 mkGenSym :: Name -> DsM GenSymBind
530 mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }
532 mkGenSyms :: [Name] -> DsM [GenSymBind]
533 mkGenSyms ns = mapM mkGenSym ns
535 lookupType :: Name -- Name of type constructor (e.g. M.Expr)
536 -> DsM Type -- The type
537 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
538 return (mkGenTyConApp tc []) }
540 -- combine[ x1 <- e1, x2 <- e2 ] y
541 -- --> bindQ e1 (\ x1 -> bindQ e2 (\ x2 -> y))
543 combine :: Name -- Name of the type (consructor) for 'a'
545 -> Core (M.Q a) -> DsM (Core (M.Q a))
546 combine tc_name binds body@(MkC b)
547 = do { elt_ty <- lookupType tc_name
550 go elt_ty [] = return body
551 go elt_ty ((name,id) : binds)
552 = do { MkC body' <- go elt_ty binds
553 ; lit_str <- localVar name
554 ; gensym_app <- repGensym lit_str
555 ; repBindQ stringTy elt_ty
556 gensym_app (MkC (Lam id body')) }
558 constructor :: Name -> Bool
559 constructor x = isDataOcc (nameOccName x)
561 void = placeHolderType
563 string :: String -> HsExpr Id
564 string s = HsLit (HsString (mkFastString s))
567 -- %*********************************************************************
571 -- %*********************************************************************
573 -----------------------------------------------------------------------------
574 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
575 -- we invent a new datatype which uses phantom types.
577 newtype Core a = MkC CoreExpr
580 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
581 rep2 n xs = do { id <- dsLookupGlobalId n
582 ; return (MkC (foldl App (Var id) xs)) }
584 -- Then we make "repConstructors" which use the phantom types for each of the
585 -- smart constructors of the Meta.Meta datatypes.
588 -- %*********************************************************************
590 -- The 'smart constructors'
592 -- %*********************************************************************
594 --------------- Patterns -----------------
595 repPlit :: Core M.Lit -> DsM (Core M.Patt)
596 repPlit (MkC l) = rep2 plitName [l]
598 repPvar :: Core String -> DsM (Core M.Patt)
599 repPvar (MkC s) = rep2 pvarName [s]
601 repPtup :: Core [M.Patt] -> DsM (Core M.Patt)
602 repPtup (MkC ps) = rep2 ptupName [ps]
604 repPcon :: Core String -> Core [M.Patt] -> DsM (Core M.Patt)
605 repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps]
607 repPtilde :: Core M.Patt -> DsM (Core M.Patt)
608 repPtilde (MkC p) = rep2 ptildeName [p]
610 repPaspat :: Core String -> Core M.Patt -> DsM (Core M.Patt)
611 repPaspat (MkC s) (MkC p) = rep2 paspatName [s, p]
613 repPwild :: DsM (Core M.Patt)
614 repPwild = rep2 pwildName []
616 --------------- Expressions -----------------
617 repVar :: Core String -> DsM (Core M.Expr)
618 repVar (MkC s) = rep2 varName [s]
620 repCon :: Core String -> DsM (Core M.Expr)
621 repCon (MkC s) = rep2 conName [s]
623 repLit :: Core M.Lit -> DsM (Core M.Expr)
624 repLit (MkC c) = rep2 litName [c]
626 repApp :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
627 repApp (MkC x) (MkC y) = rep2 appName [x,y]
629 repLam :: Core [M.Patt] -> Core M.Expr -> DsM (Core M.Expr)
630 repLam (MkC ps) (MkC e) = rep2 lamName [ps, e]
632 repTup :: Core [M.Expr] -> DsM (Core M.Expr)
633 repTup (MkC es) = rep2 tupName [es]
635 repCond :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
636 repCond (MkC x) (MkC y) (MkC z) = rep2 condName [x,y,z]
638 repLetE :: Core [M.Decl] -> Core M.Expr -> DsM (Core M.Expr)
639 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
641 repCaseE :: Core M.Expr -> Core [M.Mtch] -> DsM( Core M.Expr)
642 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
644 repDoE :: Core [M.Stmt] -> DsM (Core M.Expr)
645 repDoE (MkC ss) = rep2 doEName [ss]
647 repComp :: Core [M.Stmt] -> DsM (Core M.Expr)
648 repComp (MkC ss) = rep2 compName [ss]
650 repListExp :: Core [M.Expr] -> DsM (Core M.Expr)
651 repListExp (MkC es) = rep2 listExpName [es]
653 repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr)
654 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
656 repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
657 repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y]
659 repSectionR :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
660 repSectionR (MkC x) (MkC y) = rep2 infixAppName [x,y]
662 ------------ Right hand sides (guarded expressions) ----
663 repGuarded :: Core [(M.Expr, M.Expr)] -> DsM (Core M.Rihs)
664 repGuarded (MkC pairs) = rep2 guardedName [pairs]
666 repNormal :: Core M.Expr -> DsM (Core M.Rihs)
667 repNormal (MkC e) = rep2 normalName [e]
669 ------------- Statements -------------------
670 repBindSt :: Core M.Patt -> Core M.Expr -> DsM (Core M.Stmt)
671 repBindSt (MkC p) (MkC e) = rep2 bindStName [p,e]
673 repLetSt :: Core [M.Decl] -> DsM (Core M.Stmt)
674 repLetSt (MkC ds) = rep2 letStName [ds]
676 repNoBindSt :: Core M.Expr -> DsM (Core M.Stmt)
677 repNoBindSt (MkC e) = rep2 noBindStName [e]
679 -------------- DotDot (Arithmetic sequences) -----------
680 repFrom :: Core M.Expr -> DsM (Core M.Expr)
681 repFrom (MkC x) = rep2 fromName [x]
683 repFromThen :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
684 repFromThen (MkC x) (MkC y) = rep2 fromThenName [x,y]
686 repFromTo :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
687 repFromTo (MkC x) (MkC y) = rep2 fromToName [x,y]
689 repFromThenTo :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
690 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToName [x,y,z]
692 ------------ Match and Clause Tuples -----------
693 repMatch :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Mtch)
694 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
696 repClause :: Core [M.Patt] -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Clse)
697 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
699 -------------- Dec -----------------------------
700 repVal :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Decl)
701 repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds]
703 repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl)
704 repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
707 repData :: Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
708 repData (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [nm, tvs, cons, derivs]
710 repInst :: Core M.Ctxt -> Core M.Type -> Core [M.Decl]
711 repInst (MkC cxt) (MkC ty) (Core ds) = rep2 instanceDName [cxt, ty, ds]
713 repClass :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Decl] -> DsM (Core M.Decl)
714 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
716 repProto :: Core String -> Core M.Type -> DsM (Core M.Decl)
717 repProto (MkC s) (MkC ty) = rep2 protoName [s, ty]
719 ------------ Types -------------------
721 repTvar :: Core String -> DsM (Core M.Type)
722 repTvar (MkC s) = rep2 tvarName [s]
724 repTapp :: Core M.Type -> Core M.Type -> DsM (Core M.Type)
725 repTapp (MkC t1) (MkC t2) = rep2 tappName [t1,t2]
727 repTapps :: Core M.Type -> [Core M.Type] -> DsM (Core M.Type)
728 repTapps f [] = return f
729 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
732 repNamedTyCon :: Core String -> DsM (Core M.Type)
733 repNamedTyCon (MkC s) = rep2 namedTyConName [s]
735 repTupleTyCon :: Core Int -> DsM (Core M.Tag)
736 repTupleTyCon (MkC i) = rep2 tupleTyConName [i]
738 repArrowTyCon :: DsM (Core M.Type)
739 repArrowTyCon = rep2 arrowTyConName []
741 repListTyCon :: DsM (Core M.Tag)
742 repListTyCon = rep2 listTyConName []
746 --------------- Miscellaneous -------------------
748 repLift :: Core e -> DsM (Core M.Expr)
749 repLift (MkC x) = rep2 liftName [x]
751 repGensym :: Core String -> DsM (Core (M.Q String))
752 repGensym (MkC lit_str) = rep2 gensymName [lit_str]
754 repBindQ :: Type -> Type -- a and b
755 -> Core (M.Q a) -> Core (a -> M.Q b) -> DsM (Core (M.Q b))
756 repBindQ ty_a ty_b (MkC x) (MkC y)
757 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
759 ------------ Lists and Tuples -------------------
760 -- turn a list of patterns into a single pattern matching a list
762 coreList :: Name -- Of the TyCon of the element type
763 -> [Core a] -> DsM (Core [a])
765 = do { elt_ty <- lookupType tc_name
766 ; let es' = map unC es
767 ; return (MkC (mkListExpr elt_ty es')) }
769 nonEmptyCoreList :: [Core a] -> Core [a]
770 -- The list must be non-empty so we can get the element type
771 -- Otherwise use coreList
772 nonEmptyCoreList [] = panic "coreList: empty argument"
773 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
775 corePair :: (Core a, Core b) -> Core (a,b)
776 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
778 globalVar :: Name -> DsM (Core String)
779 globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
781 name_mod = moduleUserString (nameModule n)
782 name_occ = occNameUserString (nameOccName n)
784 localVar :: Name -> DsM (Core String)
785 localVar n = coreStringLit (occNameUserString (nameOccName n))
787 coreStringLit :: String -> DsM (Core String)
788 coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
790 coreVar :: Id -> Core String -- The Id has type String
791 coreVar id = MkC (Var id)