Added type family declarations forms
authorManuel M T Chakravarty <chak@cse.unsw.edu.au>
Thu, 19 Mar 2009 05:40:03 +0000 (05:40 +0000)
committerManuel M T Chakravarty <chak@cse.unsw.edu.au>
Thu, 19 Mar 2009 05:40:03 +0000 (05:40 +0000)
- Adds type family and instance declarations, both on the top level and
  as associated types
- No equality constraints yet

Language/Haskell/TH.hs
Language/Haskell/TH/Lib.hs
Language/Haskell/TH/Ppr.hs
Language/Haskell/TH/Syntax.hs

index 75ab0e7..a339bfa 100644 (file)
@@ -21,8 +21,8 @@ module Language.Haskell.TH(
        Dec(..), Exp(..), Con(..), Type(..), Cxt, Match(..), 
        Clause(..), Body(..), Guard(..), Stmt(..), Range(..),
        Lit(..), Pat(..), FieldExp, FieldPat, 
-       Strict(..), Foreign(..), Callconv(..), Safety(..), FunDep(..),
-       Info(..), Loc(..),
+       Strict(..), Foreign(..), Callconv(..), Safety(..), FunDep(..), 
+       FamFlavour(..), Info(..), Loc(..),
        Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
 
        -- Library functions
@@ -40,10 +40,11 @@ module Language.Haskell.TH(
        fromE, fromThenE, fromToE, fromThenToE,
        listE, sigE, recConE, recUpdE, stringE, fieldExp,
        valD, funD, tySynD, dataD, newtypeD, classD, instanceD, sigD, forImpD,
+        familyD, dataInstD, newtypeInstD, tySynInstD,
        cxt, normalC, recC, infixC,
        forallT, varT, conT, appT, arrowT, listT, tupleT,
        isStrict, notStrict, strictType, varStrictType,
-       cCall, stdCall, unsafe, safe, threadsafe,
+       cCall, stdCall, unsafe, safe, threadsafe, typeFam, dataFam,
 
        -- Pretty-printer
        Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType
index fa15761..4a9de43 100644 (file)
@@ -317,6 +317,32 @@ forImpD cc s str n ty
  = do ty' <- ty
       return $ ForeignD (ImportF cc s str n ty')
 
+familyD :: FamFlavour -> Name -> [Name] -> DecQ
+familyD flav tc tvs = return $ FamilyD flav tc tvs
+
+dataInstD :: CxtQ -> Name -> [TypeQ] -> [ConQ] -> [Name] -> DecQ
+dataInstD ctxt tc tys cons derivs =
+  do
+    ctxt1 <- ctxt
+    tys1  <- sequence tys
+    cons1 <- sequence cons
+    return (DataInstD ctxt1 tc tys1 cons1 derivs)
+
+newtypeInstD :: CxtQ -> Name -> [TypeQ] -> ConQ -> [Name] -> DecQ
+newtypeInstD ctxt tc tys con derivs =
+  do
+    ctxt1 <- ctxt
+    tys1  <- sequence tys
+    con1  <- con
+    return (NewtypeInstD ctxt1 tc tys1 con1 derivs)
+
+tySynInstD :: Name -> [TypeQ] -> TypeQ -> DecQ
+tySynInstD tc tys rhs = 
+  do 
+    tys1 <- sequence tys
+    rhs1 <- rhs
+    return (TySynInstD tc tys1 rhs1)
+
 cxt :: [TypeQ] -> CxtQ
 cxt = sequence
 
@@ -397,6 +423,13 @@ threadsafe = Threadsafe
 funDep :: [Name] -> [Name] -> FunDep
 funDep = FunDep
 
+-------------------------------------------------------------------------------
+--     FamFlavour
+
+typeFam, dataFam :: FamFlavour
+typeFam = TypeFam
+dataFam = DataFam
+
 --------------------------------------------------------------
 -- Useful helper functions
 
index a771d72..4af7b74 100644 (file)
@@ -193,41 +193,79 @@ pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> text "::" <+> ppr t
 
 ------------------------------
 instance Ppr Dec where
-    ppr (FunD f cs)   = vcat $ map (\c -> ppr f <+> ppr c) cs
-    ppr (ValD p r ds) = ppr p <+> pprBody True r
-                     $$ where_clause ds
-    ppr (TySynD t xs rhs) = text "type" <+> ppr t <+> hsep (map ppr xs) 
-                        <+> text "=" <+> ppr rhs
-    ppr (DataD ctxt t xs cs decs)
-        = text "data"
-      <+> pprCxt ctxt
-      <+> ppr t <+> hsep (map ppr xs)
-      <+> sep (pref $ map ppr cs)
-       $$ if null decs
-          then empty
-          else nest nestDepth
-             $ text "deriving"
-           <+> parens (hsep $ punctuate comma $ map ppr decs)
-        where pref :: [Doc] -> [Doc]
-              pref [] = [char '='] -- Can't happen in H98
-              pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds
-    ppr (NewtypeD ctxt t xs c decs)
-        = text "newtype"
-      <+> pprCxt ctxt
-      <+> ppr t <+> hsep (map ppr xs)
-      <+> char '=' <+> ppr c
-       $$ if null decs
-          then empty
-          else nest nestDepth
-             $ text "deriving"
-           <+> parens (hsep $ punctuate comma $ map ppr decs)
-    ppr (ClassD ctxt c xs fds ds) = text "class" <+> pprCxt ctxt
-                                <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
-                                 $$ where_clause ds
-    ppr (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i
-                             $$ where_clause ds
-    ppr (SigD f t) = ppr f <+> text "::" <+> ppr t
-    ppr (ForeignD f) = ppr f
+    ppr = ppr_dec True
+
+ppr_dec :: Bool     -- declaration on the toplevel?
+        -> Dec 
+        -> Doc
+ppr_dec _ (FunD f cs)   = vcat $ map (\c -> ppr f <+> ppr c) cs
+ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r
+                          $$ where_clause ds
+ppr_dec _ (TySynD t xs rhs) 
+  = ppr_tySyn empty t (hsep (map ppr xs)) rhs
+ppr_dec _ (DataD ctxt t xs cs decs) 
+  = ppr_data empty ctxt t (hsep (map ppr xs)) cs decs
+ppr_dec _ (NewtypeD ctxt t xs c decs)
+  = ppr_newtype empty ctxt t (sep (map ppr xs)) c decs
+ppr_dec _  (ClassD ctxt c xs fds ds) 
+  = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
+    $$ where_clause ds
+ppr_dec _ (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i
+                                  $$ where_clause ds
+ppr_dec _ (SigD f t) = ppr f <+> text "::" <+> ppr t
+ppr_dec _ (ForeignD f) = ppr f
+ppr_dec isTop (FamilyD flav tc tvs) 
+  = ppr flav <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs)
+  where
+    maybeFamily | isTop     = text "family"
+                | otherwise = empty
+ppr_dec isTop (DataInstD ctxt tc tys cs decs) 
+  = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) cs decs
+  where
+    maybeInst | isTop     = text "instance"
+              | otherwise = empty
+ppr_dec isTop (NewtypeInstD ctxt tc tys c decs) 
+  = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) c decs
+  where
+    maybeInst | isTop     = text "instance"
+              | otherwise = empty
+ppr_dec isTop (TySynInstD tc tys rhs) 
+  = ppr_tySyn maybeInst tc (sep (map pprParendType tys)) rhs
+  where
+    maybeInst | isTop     = text "instance"
+              | otherwise = empty
+
+ppr_data :: Doc -> Cxt -> Name -> Doc -> [Con] -> [Name] -> Doc
+ppr_data maybeInst ctxt t argsDoc cs decs
+  = text "data" <+> maybeInst
+    <+> pprCxt ctxt
+    <+> ppr t <+> argsDoc
+    <+> sep (pref $ map ppr cs)
+    $$ if null decs
+       then empty
+       else nest nestDepth
+            $ text "deriving"
+              <+> parens (hsep $ punctuate comma $ map ppr decs)
+  where 
+    pref :: [Doc] -> [Doc]
+    pref []     = [char '='] -- Can't happen in H98
+    pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds
+
+ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Con -> [Name] -> Doc
+ppr_newtype maybeInst ctxt t argsDoc c decs
+  = text "newtype" <+> maybeInst
+    <+> pprCxt ctxt
+    <+> ppr t <+> argsDoc
+    <+> char '=' <+> ppr c
+    $$ if null decs
+       then empty
+       else nest nestDepth
+            $ text "deriving"
+              <+> parens (hsep $ punctuate comma $ map ppr decs)
+
+ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc
+ppr_tySyn maybeInst t argsDoc rhs
+  = text "type" <+> maybeInst <+> ppr t <+> argsDoc <+> text "=" <+> ppr rhs
 
 ------------------------------
 instance Ppr FunDep where
@@ -236,6 +274,11 @@ instance Ppr FunDep where
     ppr_list xs = char '|' <+> sep (punctuate (text ", ") (map ppr xs))
 
 ------------------------------
+instance Ppr FamFlavour where
+    ppr DataFam = text "data"
+    ppr TypeFam = text "type"
+
+------------------------------
 instance Ppr Foreign where
     ppr (ImportF callconv safety impent as typ)
        = text "foreign import"
@@ -333,7 +376,7 @@ instance Ppr Range where
 ------------------------------
 where_clause :: [Dec] -> Doc
 where_clause [] = empty
-where_clause ds = nest nestDepth $ text "where" <+> vcat (map ppr ds)
+where_clause ds = nest nestDepth $ text "where" <+> vcat (map (ppr_dec False) ds)
 
 showtextl :: Show a => a -> Doc
 showtextl = text . map toLower . show
index 4a80804..6cc5970 100644 (file)
@@ -34,7 +34,7 @@ module Language.Haskell.TH.Syntax(
        Clause(..), Body(..), Guard(..), Stmt(..), Range(..),
        Lit(..), Pat(..), FieldExp, FieldPat, 
        Strict(..), Foreign(..), Callconv(..), Safety(..),
-       StrictType, VarStrictType, FunDep(..),
+       StrictType, VarStrictType, FunDep(..), FamFlavour(..),
        Info(..), Loc(..), CharPos,
        Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
 
@@ -728,11 +728,25 @@ data Dec
                                   --       where ds }
   | SigD Name Type                -- { length :: [a] -> Int }
   | ForeignD Foreign
+  -- type families (may appear in [Dec] of 'ClassD' and 'InstanceD')
+  | FamilyD FamFlavour Name [Name] {- (Maybe Kind) -}
+                                  -- { type family T a b c }
+  | DataInstD Cxt Name [Type]
+         [Con] [Name]             -- { data instance Cxt x => T [x] = A x 
+                                  --                                | B (T x)
+                                  --       deriving (Z,W)}
+  | NewtypeInstD Cxt Name [Type]
+         Con [Name]               -- { newtype instance Cxt x => T [x] = A (B x)
+                                  --       deriving (Z,W)}
+  | TySynInstD Name [Type] Type   -- { type instance T (Maybe x) = (x,x) }
   deriving( Show, Eq, Data, Typeable )
 
 data FunDep = FunDep [Name] [Name]
   deriving( Show, Eq, Data, Typeable )
 
+data FamFlavour = TypeFam | DataFam
+  deriving( Show, Eq, Data, Typeable )
+
 data Foreign = ImportF Callconv Safety String Name Type
              | ExportF Callconv        String Name Type
          deriving( Show, Eq, Data, Typeable )
@@ -757,8 +771,6 @@ data Con = NormalC Name [StrictType]
 type StrictType = (Strict, Type)
 type VarStrictType = (Name, Strict, Type)
 
--- FIXME: Why this special status for "List" (even tuples might be handled
---      differently)? -=chak
 data Type = ForallT [Name] Cxt Type   -- forall <vars>. <ctxt> -> <type>
           | VarT Name                 -- a
           | ConT Name                 -- T