Commit 5e5a08eb authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Template Haskell: support for type family declarations

parent 2c8d42f3
This diff is collapsed.
......@@ -6,13 +6,6 @@
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
......@@ -32,6 +25,7 @@ import ForeignCall
import Char
import List
import Unique
import MonadUtils
import ErrUtils
import Bag
import FastString
......@@ -107,15 +101,21 @@ wrapL (CvtM m) = CvtM (\loc -> case m loc of
-------------------------------------------------------------------
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') }
......@@ -125,7 +125,6 @@ cvtTop (DataD ctxt tc tvs constrs derivs)
; 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
......@@ -135,32 +134,109 @@ cvtTop (NewtypeD ctxt tc tvs constr derivs)
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
......@@ -317,6 +393,7 @@ cvtBindsAndSigs ds
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,
......@@ -426,6 +503,7 @@ cvtHsDo do_or_lc stmts
= 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]
......@@ -458,10 +536,17 @@ 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 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
......@@ -470,7 +555,12 @@ cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w }
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
......
......@@ -406,8 +406,8 @@ data TyClDecl name
}
| -- | @type/data/newtype family T :: *->*@
TyFamily { tcdFlavour:: FamilyFlavour, -- type, new, or data
| -- | @type/data family T :: *->*@
TyFamily { tcdFlavour:: FamilyFlavour, -- type or data
tcdLName :: Located name, -- type constructor
tcdTyVars :: [LHsTyVarBndr name], -- type variables
tcdKind :: Maybe Kind -- result kind
......
......@@ -19,6 +19,7 @@ module MonadUtils
, mapMaybeM
, anyM, allM
, foldlM, foldrM
, maybeMapM
) where
----------------------------------------------------------------------------------------
......@@ -149,3 +150,8 @@ foldlM = foldM
foldrM :: (Monad m) => (b -> a -> m a) -> a -> [b] -> m a
foldrM _ z [] = return z
foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r }
-- | Monadic version of fmap specialised for Maybe
maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b))
maybeMapM _ Nothing = return Nothing
maybeMapM m (Just x) = liftM Just $ m x
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment