Template Haskell: support for type family declarations
authorManuel M T Chakravarty <chak@cse.unsw.edu.au>
Thu, 19 Mar 2009 08:43:06 +0000 (08:43 +0000)
committerManuel M T Chakravarty <chak@cse.unsw.edu.au>
Thu, 19 Mar 2009 08:43:06 +0000 (08:43 +0000)
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsDecls.lhs
compiler/utils/MonadUtils.hs

index 554a945..5fb13df 100644 (file)
@@ -64,6 +64,7 @@ import Outputable
 import Bag
 import FastString
 import ForeignCall
+import MonadUtils
 
 import Data.Maybe
 import Control.Monad
@@ -138,11 +139,13 @@ repTopDs group
 
 groupBinders :: HsGroup Name -> [Located Name]
 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
-                       hs_fords = foreign_decls })
+                        hs_instds = inst_decls, hs_fords = foreign_decls })
 -- Collect the binders of a Group
   = collectHsValBinders val_decls ++
-    [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++
+    [n | d <- tycl_decls ++ assoc_tycl_decls, n <- tyClDeclNames (unLoc d)] ++
     [n | L _ (ForeignImport n _ _) <- foreign_decls]
+  where
+    assoc_tycl_decls = concat [ats | L _ (InstDecl _ _ _ ats) <- inst_decls]
 
 
 {-     Note [Binders and occurrences]
@@ -171,59 +174,99 @@ in repTyClD and repC.
 
 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
 
+repTyClD tydecl@(L _ (TyFamily {}))
+  = repTyFamily tydecl addTyVarBinds
+
 repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, 
-                   tcdLName = tc, tcdTyVars = tvs, 
-                   tcdCons = cons, tcdDerivs = mb_derivs }))
- = do { tc1 <- lookupLOcc tc ;         -- See note [Binders and occurrences] 
-        dec <- addTyVarBinds tvs $ \bndrs -> do {
-              cxt1    <- repLContext cxt ;
-               cons1   <- mapM repC cons ;
-              cons2   <- coreList conQTyConName cons1 ;
-              derivs1 <- repDerivs mb_derivs ;
-              bndrs1  <- coreList nameTyConName bndrs ;
-              repData cxt1 tc1 bndrs1 cons2 derivs1 } ;
-        return $ Just (loc, dec) }
+                         tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
+                         tcdCons = cons, tcdDerivs = mb_derivs }))
+  = do { tc1 <- lookupLOcc tc          -- See note [Binders and occurrences] 
+       ; dec <- addTyVarBinds tvs $ \bndrs -> 
+           do { cxt1     <- repLContext cxt
+              ; opt_tys1 <- maybeMapM repLTys opt_tys   -- only for family insts
+              ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
+              ; cons1    <- mapM repC cons
+             ; cons2    <- coreList conQTyConName cons1
+             ; derivs1  <- repDerivs mb_derivs
+             ; bndrs1   <- coreList nameTyConName bndrs
+             ; repData cxt1 tc1 bndrs1 opt_tys2 cons2 derivs1 
+              }
+       ; return $ Just (loc, dec) 
+       }
 
 repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, 
-                   tcdLName = tc, tcdTyVars = tvs, 
-                   tcdCons = [con], tcdDerivs = mb_derivs }))
- = do { tc1 <- lookupLOcc tc ;         -- See note [Binders and occurrences] 
-        dec <- addTyVarBinds tvs $ \bndrs -> do {
-              cxt1   <- repLContext cxt ;
-               con1   <- repC con ;
-              derivs1 <- repDerivs mb_derivs ;
-              bndrs1  <- coreList nameTyConName bndrs ;
-              repNewtype cxt1 tc1 bndrs1 con1 derivs1 } ;
-        return $ Just (loc, dec) }
-
-repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdSynRhs = ty }))
- = do { tc1 <- lookupLOcc tc ;         -- See note [Binders and occurrences] 
-        dec <- addTyVarBinds tvs $ \bndrs -> do {
-              ty1     <- repLTy ty ;
-              bndrs1  <- coreList nameTyConName bndrs ;
-              repTySyn tc1 bndrs1 ty1 } ;
-       return (Just (loc, dec)) }
+                         tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
+                         tcdCons = [con], tcdDerivs = mb_derivs }))
+  = do { tc1 <- lookupLOcc tc          -- See note [Binders and occurrences] 
+       ; dec <- addTyVarBinds tvs $ \bndrs -> 
+           do { cxt1     <- repLContext cxt
+              ; opt_tys1 <- maybeMapM repLTys opt_tys   -- only for family insts
+              ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
+              ; con1     <- repC con
+             ; derivs1  <- repDerivs mb_derivs
+             ; bndrs1   <- coreList nameTyConName bndrs
+             ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1
+              }
+       ; return $ Just (loc, dec) 
+       }
+
+repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
+                             tcdSynRhs = ty }))
+  = do { tc1 <- lookupLOcc tc          -- See note [Binders and occurrences] 
+       ; dec <- addTyVarBinds tvs $ \bndrs -> 
+           do { opt_tys1 <- maybeMapM repLTys opt_tys   -- only for family insts
+              ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
+             ; ty1      <- repLTy ty
+             ; bndrs1   <- coreList nameTyConName bndrs
+             ; repTySyn tc1 bndrs1 opt_tys2 ty1 
+              }
+       ; return (Just (loc, dec)) 
+       }
 
 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, 
-                     tcdTyVars = tvs, 
-                     tcdFDs = fds,
-                     tcdSigs = sigs, tcdMeths = meth_binds }))
- = do { cls1 <- lookupLOcc cls ;               -- See note [Binders and occurrences] 
-       dec  <- addTyVarBinds tvs $ \bndrs -> do {
-                 cxt1   <- repLContext cxt ;
-                 sigs1  <- rep_sigs sigs ;
-                 binds1 <- rep_binds meth_binds ;
-                 fds1 <- repLFunDeps fds;
-                 decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
-                 bndrs1 <- coreList nameTyConName bndrs ;
-                 repClass cxt1 cls1 bndrs1 fds1 decls1 } ;
-       return $ Just (loc, dec) }
+                            tcdTyVars = tvs, tcdFDs = fds,
+                            tcdSigs = sigs, tcdMeths = meth_binds, 
+                             tcdATs = ats }))
+  = do { cls1 <- lookupLOcc cls        -- See note [Binders and occurrences] 
+       ; dec  <- addTyVarBinds tvs $ \bndrs -> 
+           do { cxt1   <- repLContext cxt
+             ; sigs1  <- rep_sigs sigs
+             ; binds1 <- rep_binds meth_binds
+             ; fds1   <- repLFunDeps fds
+              ; ats1   <- repLAssocFamilys ats
+             ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
+             ; bndrs1 <- coreList nameTyConName bndrs
+             ; repClass cxt1 cls1 bndrs1 fds1 decls1 
+              }
+       ; return $ Just (loc, dec) 
+       }
 
 -- Un-handled cases
 repTyClD (L loc d) = putSrcSpanDs loc $
                     do { warnDs (hang ds_msg 4 (ppr d))
                        ; return Nothing }
 
+-- The type variables in the head of families are treated differently when the
+-- family declaration is associated.  In that case, they are usage, not binding
+-- occurences.
+--
+repTyFamily :: LTyClDecl Name 
+            -> ProcessTyVarBinds TH.Dec
+            -> DsM (Maybe (SrcSpan, Core TH.DecQ))
+repTyFamily (L loc (TyFamily { tcdFlavour = flavour,
+                              tcdLName = tc, tcdTyVars = tvs, 
+                              tcdKind = _kind }))
+            tyVarBinds
+  = do { tc1 <- lookupLOcc tc          -- See note [Binders and occurrences] 
+       ; dec <- tyVarBinds tvs $ \bndrs ->
+           do { flav   <- repFamilyFlavour flavour
+             ; bndrs1 <- coreList nameTyConName bndrs
+              ; repFamily flav tc1 bndrs1
+              }
+       ; return $ Just (loc, dec)
+       }
+repTyFamily _ _ = panic "DsMeta.repTyFamily: internal error"
+
 -- represent fundeps
 --
 repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
@@ -238,22 +281,49 @@ repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
                                ys_list <- coreList nameTyConName ys'
                                repFunDep xs_list ys_list
 
+-- represent family declaration flavours
+--
+repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
+repFamilyFlavour TypeFamily = rep2 typeFamName []
+repFamilyFlavour DataFamily = rep2 dataFamName []
+
+-- represent associated family declarations
+--
+repLAssocFamilys :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
+repLAssocFamilys = mapM repLAssocFamily
+  where
+    repLAssocFamily tydecl@(L _ (TyFamily {})) 
+      = liftM (snd . fromJust) $ repTyFamily tydecl lookupTyVarBinds
+    repLAssocFamily tydecl
+      = failWithDs msg
+      where
+        msg = ptext (sLit "Illegal associated declaration in class:") <+> 
+              ppr tydecl
+
+-- represent associated family instances
+--
+repLAssocFamInst :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
+repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD
+
+-- represent instance declarations
+--
 repInstD' :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
-repInstD' (L loc (InstDecl ty binds _ _))              -- Ignore user pragmas for now
= do  { i <- addTyVarBinds tvs $ \_ ->
-               -- We must bring the type variables into scope, so their occurrences
-               -- don't fail,  even though the binders don't appear in the resulting 
-               -- data structure
-               do {  cxt1 <- repContext cxt
+repInstD' (L loc (InstDecl ty binds _ ats))    -- Ignore user pragmas for now
 = do { i <- addTyVarBinds tvs $ \_ ->
+               -- We must bring the type variables into scope, so their
+               -- occurrences don't fail, even though the binders don't 
+                -- appear in the resulting data structure
+               do { cxt1 <- repContext cxt
                   ; inst_ty1 <- repPred (HsClassP cls tys)
                   ; ss <- mkGenSyms (collectHsBindBinders binds)
                   ; binds1 <- addBinds ss (rep_binds binds)
-                  ; decls1 <- coreList decQTyConName binds1
+                   ; ats1   <- repLAssocFamInst ats
+                  ; decls1 <- coreList decQTyConName (ats1 ++ binds1)
                   ; decls2 <- wrapNongenSyms ss decls1
-                  -- wrapNonGenSyms: do not clone the class op names!
+                  -- wrapNongenSyms: do not clone the class op names!
                   -- They must be called 'op' etc, not 'op34'
-                  ; repInst cxt1 inst_ty1 decls2 }
-
+                  ; repInst cxt1 inst_ty1 (decls2)
+                   }
        ; return (loc, i)}
  where
    (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
@@ -370,13 +440,20 @@ rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ;
 --                     Types
 -------------------------------------------------------
 
+-- We process type variable bindings in two ways, either by generating fresh
+-- names or looking up existing names.  The difference is crucial for type
+-- families, depending on whether they are associated or not.
+--
+type ProcessTyVarBinds a = 
+         [LHsTyVarBndr Name]                    -- the binders to be added
+      -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
+      -> DsM (Core (TH.Q a))
+
 -- gensym a list of type variables and enter them into the meta environment;
 -- the computations passed as the second argument is executed in that extended
 -- meta environment and gets the *new* names on Core-level as an argument
 --
-addTyVarBinds :: [LHsTyVarBndr Name]            -- the binders to be added
-             -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
-             -> DsM (Core (TH.Q a))
+addTyVarBinds :: ProcessTyVarBinds a
 addTyVarBinds tvs m =
   do
     let names = map (hsTyVarName.unLoc) tvs
@@ -386,6 +463,16 @@ addTyVarBinds tvs m =
                    m bndrs
     wrapGenSyns freshNames term
 
+-- Look up a list of type variables; the computations passed as the second 
+-- argument gets the *new* names on Core-level as an argument
+--
+lookupTyVarBinds :: ProcessTyVarBinds a
+lookupTyVarBinds tvs m =
+  do
+    let names = map (hsTyVarName.unLoc) tvs
+    bndrs <- mapM lookupBinder names 
+    m bndrs
+
 -- represent a type context
 --
 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
@@ -1185,16 +1272,29 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)  
 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
 
-repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
-repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs)
-    = rep2 dataDName [cxt, nm, tvs, cons, derivs]
-
-repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
-repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs)
-    = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
-
-repTySyn :: Core TH.Name -> Core [TH.Name] -> Core TH.TypeQ -> DsM (Core TH.DecQ)
-repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
+repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] 
+        -> Maybe (Core [TH.TypeQ])
+        -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
+repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
+  = rep2 dataDName [cxt, nm, tvs, cons, derivs]
+repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
+  = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
+
+repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] 
+           -> Maybe (Core [TH.TypeQ])
+           -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
+repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
+  = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
+repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
+  = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
+
+repTySyn :: Core TH.Name -> Core [TH.Name] 
+         -> Maybe (Core [TH.TypeQ])
+         -> Core TH.TypeQ -> DsM (Core TH.DecQ)
+repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs) 
+  = rep2 tySynDName [nm, tvs, rhs]
+repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs) 
+  = rep2 tySynInstDName [nm, tys, rhs]
 
 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
@@ -1202,6 +1302,11 @@ repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds]
 
+repFamily :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.Name] 
+          -> DsM (Core TH.DecQ)
+repFamily (MkC flav) (MkC nm) (MkC tvs)
+    = rep2 familyDName [flav, nm, tvs]
+
 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
 
@@ -1408,7 +1513,8 @@ templateHaskellNames = [
     bindSName, letSName, noBindSName, parSName,
     -- Dec
     funDName, valDName, dataDName, newtypeDName, tySynDName,
-    classDName, instanceDName, sigDName, forImpDName,
+    classDName, instanceDName, sigDName, forImpDName, familyDName, dataInstDName,
+    newtypeInstDName, tySynInstDName,
     -- Cxt
     cxtName,
     -- Strict
@@ -1430,6 +1536,8 @@ templateHaskellNames = [
     threadsafeName,
     -- FunDep
     funDepName,
+    -- FamFlavour
+    typeFamName, dataFamName,
 
     -- And the tycons
     qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
@@ -1583,16 +1691,21 @@ parSName    = libFun (fsLit "parS")    parSIdKey
 
 -- data Dec = ...
 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
-    instanceDName, sigDName, forImpDName :: Name
-funDName      = libFun (fsLit "funD")      funDIdKey
-valDName      = libFun (fsLit "valD")      valDIdKey
-dataDName     = libFun (fsLit "dataD")     dataDIdKey
-newtypeDName  = libFun (fsLit "newtypeD")  newtypeDIdKey
-tySynDName    = libFun (fsLit "tySynD")    tySynDIdKey
-classDName    = libFun (fsLit "classD")    classDIdKey
-instanceDName = libFun (fsLit "instanceD") instanceDIdKey
-sigDName      = libFun (fsLit "sigD")      sigDIdKey
-forImpDName   = libFun (fsLit "forImpD")   forImpDIdKey
+    instanceDName, sigDName, forImpDName, familyDName, dataInstDName, 
+    newtypeInstDName, tySynInstDName :: Name
+funDName         = libFun (fsLit "funD")         funDIdKey
+valDName         = libFun (fsLit "valD")         valDIdKey
+dataDName        = libFun (fsLit "dataD")        dataDIdKey
+newtypeDName     = libFun (fsLit "newtypeD")     newtypeDIdKey
+tySynDName       = libFun (fsLit "tySynD")       tySynDIdKey
+classDName       = libFun (fsLit "classD")       classDIdKey
+instanceDName    = libFun (fsLit "instanceD")    instanceDIdKey
+sigDName         = libFun (fsLit "sigD")         sigDIdKey
+forImpDName      = libFun (fsLit "forImpD")      forImpDIdKey
+familyDName      = libFun (fsLit "familyD")      familyDIdKey
+dataInstDName    = libFun (fsLit "dataInstD")    dataInstDIdKey
+newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
+tySynInstDName   = libFun (fsLit "tySynInstD")   tySynInstDIdKey
 
 -- type Ctxt = ...
 cxtName :: Name
@@ -1644,6 +1757,11 @@ threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
 funDepName :: Name
 funDepName     = libFun (fsLit "funDep") funDepIdKey
 
+-- data FamFlavour = ...
+typeFamName, dataFamName :: Name
+typeFamName = libFun (fsLit "typeFam") typeFamIdKey
+dataFamName = libFun (fsLit "dataFam") dataFamIdKey
+
 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
     decQTyConName, conQTyConName, strictTypeQTyConName,
     varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
@@ -1809,7 +1927,8 @@ parSIdKey        = mkPreludeMiscIdUnique 271
 
 -- data Dec = ...
 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
-    classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey :: Unique
+    classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, familyDIdKey,
+    dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique
 funDIdKey         = mkPreludeMiscIdUnique 272
 valDIdKey         = mkPreludeMiscIdUnique 273
 dataDIdKey        = mkPreludeMiscIdUnique 274
@@ -1819,6 +1938,10 @@ classDIdKey       = mkPreludeMiscIdUnique 277
 instanceDIdKey    = mkPreludeMiscIdUnique 278
 sigDIdKey         = mkPreludeMiscIdUnique 279
 forImpDIdKey      = mkPreludeMiscIdUnique 297
+familyDIdKey      = mkPreludeMiscIdUnique 340
+dataInstDIdKey    = mkPreludeMiscIdUnique 341
+newtypeInstDIdKey = mkPreludeMiscIdUnique 342
+tySynInstDIdKey   = mkPreludeMiscIdUnique 343
 
 -- type Cxt = ...
 cxtIdKey :: Unique
@@ -1870,6 +1993,11 @@ threadsafeIdKey = mkPreludeMiscIdUnique 307
 funDepIdKey :: Unique
 funDepIdKey = mkPreludeMiscIdUnique 320
 
+-- data FamFlavour = ...
+typeFamIdKey, dataFamIdKey :: Unique
+typeFamIdKey = mkPreludeMiscIdUnique 344
+dataFamIdKey = mkPreludeMiscIdUnique 345
+
 -- quasiquoting
 quoteExpKey, quotePatKey :: Unique
 quoteExpKey = mkPreludeMiscIdUnique 321
index 09ffafd..b48d361 100644 (file)
@@ -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
index 8ef3816..cd04a1a 100644 (file)
@@ -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
index 2064657..733eda1 100644 (file)
@@ -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