-cvtd (Val (Pvar s) body ds) = FunMonoBind (vName s) False
- (panic "what now?") loc0
-cvtd (Fun nm cls) = FunMonoBind (vName nm) False (map cvtclause cls) loc0
-cvtd (Val p body ds) = PatMonoBind (cvtp p) (GRHSs (cvtguard body)
- (cvtdecs ds)
- void) loc0
-cvtd x = panic "Illegal kind of declaration in where clause"
-
-
-cvtclause :: Meta.Clause (Meta.Pat) (Meta.Exp) (Meta.Dec) -> Hs.Match RdrName
-cvtclause (ps,body,wheres) = Match (map cvtp ps) Nothing
- (GRHSs (cvtguard body) (cvtdecs wheres) void)
-
-
-
-cvtdd :: Meta.DDt -> ArithSeqInfo RdrName
-cvtdd (Meta.From x) = (Hs.From (cvt x))
-cvtdd (Meta.FromThen x y) = (Hs.FromThen (cvt x) (cvt y))
-cvtdd (Meta.FromTo x y) = (Hs.FromTo (cvt x) (cvt y))
-cvtdd (Meta.FromThenTo x y z) = (Hs.FromThenTo (cvt x) (cvt y) (cvt z))
-
-
-cvtstmts :: [Meta.Stm] -> [Hs.Stmt RdrName]
-cvtstmts [] = [] -- this is probably an error as every [stmt] should end with ResultStmt
-cvtstmts [NoBindSt e] = [ResultStmt (cvt e) loc0] -- when its the last element use ResultStmt
-cvtstmts (NoBindSt e : ss) = ExprStmt (cvt e) void loc0 : cvtstmts ss
-cvtstmts (BindSt p e : ss) = BindStmt (cvtp p) (cvt e) loc0 : cvtstmts ss
-cvtstmts (LetSt ds : ss) = LetStmt (cvtdecs ds) : cvtstmts ss
-cvtstmts (ParSt dss : ss) = ParStmt(map cvtstmts dss) : cvtstmts ss
-
-
-cvtm :: Meta.Mat -> Hs.Match RdrName
-cvtm (p,body,wheres) = Match [cvtp p] Nothing
- (GRHSs (cvtguard body) (cvtdecs wheres) void)
-
-cvtguard :: Meta.Rhs -> [GRHS RdrName]
-cvtguard (Guarded pairs) = map cvtpair pairs
-cvtguard (Normal e) = [GRHS [ ResultStmt (cvt e) loc0 ] loc0]
-
-cvtpair :: (Meta.Exp,Meta.Exp) -> GRHS RdrName
-cvtpair (x,y) = GRHS [BindStmt truePat (cvt x) loc0,
- ResultStmt (cvt y) loc0] loc0
-
-cvtOverLit :: Lit -> HsOverLit
-cvtOverLit (Int i) = mkHsIntegral (fromInt i)
--- An Int is like an an (overloaded) '3' in a Haskell source program
-
-cvtLit :: Lit -> HsLit
-cvtLit (Char c) = HsChar (ord c)
-cvtLit (CrossStage s) = error "What do we do about crossStage constants?"
-
-cvtp :: Meta.Pat -> Hs.Pat RdrName
-cvtp (Plit l)
- | overloadedLit l = NPatIn (cvtOverLit l) Nothing -- Not right for negative
- -- patterns; need to think
- -- about that!
- | otherwise = LitPat (cvtLit l)
-cvtp (Pvar s) = VarPat(vName s)
-cvtp (Ptup ps) = TuplePat (map cvtp ps) Boxed
-cvtp (Pcon s ps) = ConPatIn (cName s) (PrefixCon (map cvtp ps))
-cvtp (Ptilde p) = LazyPat (cvtp p)
-cvtp (Paspat s p) = AsPat (vName s) (cvtp p)
-cvtp Pwild = WildPat void
+cvtBind (TH.ValD (TH.VarP s) body ds)
+ = do { s' <- vNameL s
+ ; cl' <- cvtClause (Clause [] body ds)
+ ; returnL $ mkFunBind s' [cl'] }
+
+cvtBind (TH.FunD nm cls)
+ = do { nm' <- vNameL nm
+ ; cls' <- mapM cvtClause cls
+ ; returnL $ mkFunBind nm' cls' }
+
+cvtBind (TH.ValD p body ds)
+ = do { p' <- cvtPat p
+ ; g' <- cvtGuard body
+ ; ds' <- cvtDecs ds
+ ; returnL $ PatBind { pat_lhs = p', pat_rhs = GRHSs g' ds',
+ pat_rhs_ty = void, bind_fvs = placeHolderNames } }
+
+cvtBind d
+ = failWith (sep [ptext SLIT("Illegal kind of declaration in where clause"),
+ nest 2 (text (TH.pprint d))])
+
+cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
+cvtClause (Clause ps body wheres)
+ = do { ps' <- cvtPats ps
+ ; g' <- cvtGuard body
+ ; ds' <- cvtDecs wheres
+ ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
+
+
+-------------------------------------------------------------------
+-- Expressions
+-------------------------------------------------------------------
+
+cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
+cvtl e = wrapL (cvt e)
+ where
+ cvt (VarE s) = do { s' <- vName s; return $ HsVar s' }
+ cvt (ConE s) = do { s' <- cName s; return $ HsVar s' }
+ cvt (LitE l)
+ | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
+ | otherwise = do { l' <- cvtLit l; return $ HsLit l' }
+
+ cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
+ cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
+ ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
+ cvt (TupE [e]) = cvt e
+ cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple es' Boxed }
+ cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
+ ; return $ HsIf x' y' z' }
+ cvt (LetE ds e) = do { ds' <- cvtDecs ds; e' <- cvtl e; return $ HsLet ds' e' }
+ cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
+ ; return $ HsCase e' (mkMatchGroup ms') }
+ cvt (DoE ss) = cvtHsDo DoExpr ss
+ cvt (CompE ss) = cvtHsDo ListComp ss
+ cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
+ cvt (ListE xs) = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
+ cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
+ ; e' <- returnL $ OpApp x' s' undefined y'
+ ; return $ HsPar e' }
+ cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
+ ; return $ SectionR s' y' }
+ cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
+ ; return $ SectionL x' s' }
+ cvt (InfixE Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing?
+
+ cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
+ ; return $ ExprWithTySig e' t' }
+ cvt (RecConE c flds) = do { c' <- cNameL c
+ ; flds' <- mapM cvtFld flds
+ ; return $ RecordCon c' noPostTcExpr flds' }
+ cvt (RecUpdE e flds) = do { e' <- cvtl e
+ ; flds' <- mapM cvtFld flds
+ ; return $ RecordUpd e' flds' placeHolderType placeHolderType }
+
+cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e; return (v',e') }
+
+cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
+cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
+cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
+cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
+cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
+
+-------------------------------------
+-- Do notation and statements
+-------------------------------------
+
+cvtHsDo do_or_lc stmts
+ = do { stmts' <- cvtStmts stmts
+ ; let body = case last stmts' of
+ L _ (ExprStmt body _ _) -> body
+ ; return $ HsDo do_or_lc (init stmts') body void }
+
+cvtStmts = mapM cvtStmt
+
+cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
+cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkExprStmt e' }
+cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
+cvtStmt (TH.LetS ds) = do { ds' <- cvtDecs ds; returnL $ LetStmt ds' }
+cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
+ where
+ cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
+
+cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
+cvtMatch (TH.Match p body decs)
+ = do { p' <- cvtPat p
+ ; g' <- cvtGuard body
+ ; decs' <- cvtDecs decs
+ ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
+
+cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
+cvtGuard (GuardedB pairs) = mapM cvtpair pairs
+cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
+
+cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
+cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
+ ; g' <- returnL $ mkBindStmt truePat ge'
+ ; returnL $ GRHS [g'] rhs' }
+cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
+ ; returnL $ GRHS gs' rhs' }
+
+cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
+cvtOverLit (IntegerL i) = do { force i; return $ mkHsIntegral i }
+cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r }
+-- An Integer is like an an (overloaded) '3' in a Haskell source program
+-- Similarly 3.5 for fractionals
+
+cvtLit :: Lit -> CvtM HsLit
+cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i }
+cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f }
+cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
+cvtLit (CharL c) = do { force c; return $ HsChar c }
+cvtLit (StringL s) = do { let { s' = mkFastString s }; force s'; return $ HsString s' }
+
+cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
+cvtPats pats = mapM cvtPat pats
+
+cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
+cvtPat pat = wrapL (cvtp pat)
+
+cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
+cvtp (TH.LitP l)
+ | overloadedLit l = do { l' <- cvtOverLit l
+ ; return (mkNPat l' Nothing) }
+ -- Not right for negative patterns;
+ -- need to think about that!
+ | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
+cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' }
+cvtp (TupP [p]) = cvtp p
+cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
+cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
+cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
+ ; return $ ConPatIn s' (InfixCon p1' p2') }
+cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' }
+cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
+cvtp TH.WildP = return $ WildPat void
+cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
+ ; return $ ConPatIn c' $ Hs.RecCon fs' }
+cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void }
+cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
+
+cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p; return (s',p') }