This module converts Template Haskell syntax into HsSyn
\begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
convertToHsType, thRdrNameGuesses ) where
import Char
import List
import Unique
+import MonadUtils
import ErrUtils
import Bag
import FastString
-------------------------------------------------------------------
cvtTop :: TH.Dec -> CvtM (LHsDecl RdrName)
-cvtTop d@(TH.ValD _ _ _) = do { L loc d' <- cvtBind d; return (L loc $ Hs.ValD d') }
-cvtTop d@(TH.FunD _ _) = do { L loc d' <- cvtBind d; return (L loc $ Hs.ValD d') }
-cvtTop (TH.SigD nm typ) = do { nm' <- vNameL nm
- ; ty' <- cvtType typ
- ; returnL $ Hs.SigD (TypeSig nm' ty') }
+cvtTop d@(TH.ValD _ _ _)
+ = do { L loc d' <- cvtBind d
+ ; return (L loc $ Hs.ValD d') }
+
+cvtTop d@(TH.FunD _ _)
+ = do { L loc d' <- cvtBind d
+ ; return (L loc $ Hs.ValD d') }
+
+cvtTop (TH.SigD nm typ)
+ = do { nm' <- vNameL nm
+ ; ty' <- cvtType typ
+ ; returnL $ Hs.SigD (TypeSig nm' ty') }
cvtTop (TySynD tc tvs rhs)
- = do { tc' <- tconNameL tc
- ; tvs' <- cvtTvs tvs
+ = do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs
; rhs' <- cvtType rhs
; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
; derivs' <- cvtDerivs derivs
; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs') }
-
cvtTop (NewtypeD ctxt tc tvs constr derivs)
= do { stuff <- cvt_tycl_hdr ctxt tc tvs
; con' <- cvtConstr constr
cvtTop (ClassD ctxt cl tvs fds decs)
= do { (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs
; fds' <- mapM cvt_fundep fds
- ; (binds', sigs') <- cvtBindsAndSigs decs
- ; returnL $ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' [] []
- -- no ATs or docs in TH ^^ ^^
+ ; let (ats, bind_sig_decs) = partition isFamilyD decs
+ ; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs
+ ; ats' <- mapM cvtTop ats
+ ; let ats'' = map unTyClD ats'
+ ; returnL $
+ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' ats'' []
+ -- no docs in TH ^^
}
+ where
+ isFamilyD (FamilyD _ _ _) = True
+ isFamilyD _ = False
cvtTop (InstanceD tys ty decs)
- = do { (binds', sigs') <- cvtBindsAndSigs decs
+ = do { let (ats, bind_sig_decs) = partition isFamInstD decs
+ ; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs
+ ; ats' <- mapM cvtTop ats
+ ; let ats'' = map unTyClD ats'
; ctxt' <- cvtContext tys
; L loc pred' <- cvtPred ty
- ; inst_ty' <- returnL $ mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred'))
- ; returnL $ InstD (InstDecl inst_ty' binds' sigs' [])
- -- no ATs in TH ^^
+ ; inst_ty' <- returnL $
+ mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred'))
+ ; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats'')
}
+ where
+ isFamInstD (DataInstD _ _ _ _ _) = True
+ isFamInstD (NewtypeInstD _ _ _ _ _) = True
+ isFamInstD (TySynInstD _ _ _) = True
+ isFamInstD _ = False
cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' }
+cvtTop (FamilyD flav tc tvs)
+ = do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs
+ ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' Nothing)
+ -- FIXME: kinds
+ }
+ where
+ cvtFamFlavour TypeFam = TypeFamily
+ cvtFamFlavour DataFam = DataFamily
+
+cvtTop (DataInstD ctxt tc tys constrs derivs)
+ = do { stuff <- cvt_tyinst_hdr ctxt tc tys
+ ; cons' <- mapM cvtConstr constrs
+ ; derivs' <- cvtDerivs derivs
+ ; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs')
+ }
+
+cvtTop (NewtypeInstD ctxt tc tys constr derivs)
+ = do { stuff <- cvt_tyinst_hdr ctxt tc tys
+ ; con' <- cvtConstr constr
+ ; derivs' <- cvtDerivs derivs
+ ; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs')
+ }
+
+cvtTop (TySynInstD tc tys rhs)
+ = do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys
+ ; rhs' <- cvtType rhs
+ ; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') }
+
+-- FIXME: This projection is not nice, but to remove it, cvtTop should be
+-- refactored.
+unTyClD :: LHsDecl a -> LTyClDecl a
+unTyClD (L l (TyClD d)) = L l d
+unTyClD _ = panic "Convert.unTyClD: internal error"
+
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.Name]
- -> CvtM (LHsContext RdrName
- ,Located RdrName
- ,[LHsTyVarBndr RdrName]
- ,Maybe [LHsType RdrName])
+ -> CvtM ( LHsContext RdrName
+ , Located RdrName
+ , [LHsTyVarBndr RdrName]
+ , Maybe [LHsType RdrName])
cvt_tycl_hdr cxt tc tvs
- = do { cxt' <- cvtContext cxt
- ; tc' <- tconNameL tc
- ; tvs' <- cvtTvs tvs
- ; return (cxt', tc', tvs', Nothing) }
+ = do { cxt' <- cvtContext cxt
+ ; tc' <- tconNameL tc
+ ; tvs' <- cvtTvs tvs
+ ; return (cxt', tc', tvs', Nothing)
+ }
+
+cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
+ -> CvtM ( LHsContext RdrName
+ , Located RdrName
+ , [LHsTyVarBndr RdrName]
+ , Maybe [LHsType RdrName])
+cvt_tyinst_hdr cxt tc tys
+ = do { cxt' <- cvtContext cxt
+ ; tc' <- tconNameL tc
+ ; tvs <- concatMapM collect tys
+ ; tvs' <- cvtTvs tvs
+ ; tys' <- mapM cvtType tys
+ ; return (cxt', tc', tvs', Just tys')
+ }
+ where
+ collect (ForallT _ _ _)
+ = failWith $ text "Forall type not allowed as type parameter"
+ collect (VarT tv) = return [tv]
+ collect (ConT _) = return []
+ collect (TupleT _) = return []
+ collect ArrowT = return []
+ collect ListT = return []
+ collect (AppT t1 t2)
+ = do { tvs1 <- collect t1
+ ; tvs2 <- collect t2
+ ; return $ tvs1 ++ tvs2
+ }
---------------------------------------------------
-- Data types
cvtSig :: TH.Dec -> CvtM (LSig RdrName)
cvtSig (TH.SigD nm ty)
= do { nm' <- vNameL nm; ty' <- cvtType ty; returnL (Hs.TypeSig nm' ty') }
+cvtSig _ = panic "Convert.cvtSig: Signature expected"
cvtBind :: TH.Dec -> CvtM (LHsBind RdrName)
-- Used only for declarations in a 'let/where' clause,
; 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' }
+ ; sec <- returnL $ SectionR s' y'
+ ; return $ HsPar sec }
cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
- ; return $ SectionL x' s' }
+ ; sec <- returnL $ SectionL x' s'
+ ; return $ HsPar sec }
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
= do { stmts' <- cvtStmts stmts
; let body = case last stmts' of
L _ (ExprStmt body _ _) -> body
+ _ -> panic "Malformed body"
; return $ HsDo do_or_lc (init stmts') body void }
cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
; returnL $ GRHS gs' rhs' }
cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
-cvtOverLit (IntegerL i) = do { force i; return $ mkHsIntegral i placeHolderType}
-cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r placeHolderType}
-cvtOverLit (StringL s) = do { let { s' = mkFastString s }; force s'; return $ mkHsIsString s' placeHolderType }
--- An Integer is like an an (overloaded) '3' in a Haskell source program
+cvtOverLit (IntegerL i)
+ = do { force i; return $ mkHsIntegral i placeHolderType}
+cvtOverLit (RationalL r)
+ = do { force r; return $ mkHsFractional r placeHolderType}
+cvtOverLit (StringL s)
+ = do { let { s' = mkFastString s }
+ ; force s'
+ ; return $ mkHsIsString s' placeHolderType
+ }
+cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
+-- An Integer is like an (overloaded) '3' in a Haskell source program
-- Similarly 3.5 for fractionals
cvtLit :: Lit -> CvtM HsLit
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' }
+cvtLit (StringL s)
+ = do { let { s' = mkFastString s }
+ ; force s'
+ ; return $ HsString s'
+ }
+cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
cvtPats pats = mapM cvtPat pats
projects / ghc-hetmet.git / blobdiff