Use family and instance keyword to identify indexed types

Tue Aug 15 20:16:00 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Use family and instance keyword to identify indexed types

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index aed9cfb..fdbaeef 100644 (file)
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -377,6 +377,7 @@ data Token
   | ITdotnet
   | ITmdo
   | ITiso
   | ITdotnet
   | ITmdo
   | ITiso

+  | ITfamily

 
        -- Pragmas
   | ITinline_prag Bool         -- True <=> INLINE, False <=> NOINLINE
 
        -- Pragmas
   | ITinline_prag Bool         -- True <=> INLINE, False <=> NOINLINE

@@ -501,6 +502,7 @@ isSpecial ITccallconv   = True
 isSpecial ITstdcallconv = True
 isSpecial ITmdo                = True
 isSpecial ITiso                = True
 isSpecial ITstdcallconv = True
 isSpecial ITmdo                = True
 isSpecial ITiso                = True

+isSpecial ITfamily     = True

 isSpecial _             = False
 
 -- the bitmap provided as the third component indicates whether the
 isSpecial _             = False
 
 -- the bitmap provided as the third component indicates whether the

@@ -542,6 +544,7 @@ reservedWordsFM = listToUFM $
        ( "forall",     ITforall,        bit tvBit),
        ( "mdo",        ITmdo,           bit glaExtsBit),
        ( "iso",        ITiso,           bit glaExtsBit),
        ( "forall",     ITforall,        bit tvBit),
        ( "mdo",        ITmdo,           bit glaExtsBit),
        ( "iso",        ITiso,           bit glaExtsBit),

+       ( "family",     ITfamily,        bit glaExtsBit),

 
        ( "foreign",    ITforeign,       bit ffiBit),
        ( "export",     ITexport,        bit ffiBit),
 
        ( "foreign",    ITforeign,       bit ffiBit),
        ( "export",     ITexport,        bit ffiBit),

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index dc86c00..0a8b0b6 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -186,6 +186,7 @@ incorrect.
  'unsafe'      { L _ ITunsafe }
  'mdo'         { L _ ITmdo }
  'iso'         { L _ ITiso }
  'unsafe'      { L _ ITunsafe }
  'mdo'         { L _ ITmdo }
  'iso'         { L _ ITiso }

+ 'family'      { L _ ITfamily }

  'stdcall'      { L _ ITstdcallconv }
  'ccall'        { L _ ITccallconv }
  'dotnet'       { L _ ITdotnet }
  'stdcall'      { L _ ITstdcallconv }
  'ccall'        { L _ ITccallconv }
  'dotnet'       { L _ ITdotnet }

@@ -468,7 +469,7 @@ cl_decl :: { LTyClDecl RdrName }
                {% do { let { (binds, sigs, ats)           = 
                                cvBindsAndSigs (unLoc $4)
                            ; (ctxt, tc, tvs, tparms) = unLoc $2}
                {% do { let { (binds, sigs, ats)           = 
                                cvBindsAndSigs (unLoc $4)
                            ; (ctxt, tc, tvs, tparms) = unLoc $2}

-                      ; checkTyVars tparms False  -- only type vars allowed
+                      ; checkTyVars tparms      -- only type vars allowed

                      ; checkKindSigs ats
                      ; return $ L (comb4 $1 $2 $3 $4) 
                                   (mkClassDecl (ctxt, tc, tvs) 
                      ; checkKindSigs ats
                      ; return $ L (comb4 $1 $2 $3 $4) 
                                   (mkClassDecl (ctxt, tc, tvs) 

@@ -477,79 +478,97 @@ cl_decl :: { LTyClDecl RdrName }
 -- Type declarations
 --
 ty_decl :: { LTyClDecl RdrName }
 -- Type declarations
 --
 ty_decl :: { LTyClDecl RdrName }

-        -- type function signature and equations (w/ type synonyms as special
-        -- case); we need to handle all this in one rule to avoid a large
-        -- number of shift/reduce conflicts
-        : 'type' opt_iso type kind_or_ctype
+           -- ordinary type synonyms
+        : 'type' type '=' ctype
+               -- Note ctype, not sigtype, on the right of '='
+               -- We allow an explicit for-all but we don't insert one
+               -- in   type Foo a = (b,b)
+               -- Instead we just say b is out of scope

                --
                -- Note the use of type for the head; this allows
                --
                -- Note the use of type for the head; this allows

-               -- infix type constructors to be declared and type
-               -- patterns for type function equations
-               -- 
-               -- We have that `typats :: Maybe [LHsType name]' is `Nothing'
-               -- (in the second case alternative) when all arguments are
-               -- variables (and we thus have a vanilla type synonym
-               -- declaration); otherwise, it contains all arguments as type
-               -- patterns.
+               -- infix type constructors to be declared 
+               {% do { (tc, tvs, _) <- checkSynHdr $2 False
+                     ; return (L (comb2 $1 $4) 
+                                 (TySynonym tc tvs Nothing $4)) 
+                      } }
+
+           -- type family declarations
+        | 'type' 'family' opt_iso type '::' kind
+               -- Note the use of type for the head; this allows
+               -- infix type constructors to be declared

                --
                --

-               {% case $4 of 
-                    Left kind -> 
-                      do { (tc, tvs, _) <- checkSynHdr $3 False
-                         ; return (L (comb3 $1 $3 kind) 
-                                     (TyFunction tc tvs $2 (unLoc kind)))
-                         } 
-                    Right ty | not $2 -> 
-                      do { (tc, tvs, typats) <- checkSynHdr $3 True
-                         ; return (L (comb2 $1 ty) 
-                                     (TySynonym tc tvs typats ty)) }
-                    Right ty | otherwise -> 
-                      parseError (comb2 $1 ty) 
-                        "iso tag is only allowed in kind signatures"
-                }
-
-        -- kind signature of indexed type
-        | data_or_newtype tycl_hdr '::' kind
-               {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
-                      ; checkTyVars tparms False  -- no type pattern
-                     ; return $
-                         L (comb3 $1 $2 $4)
-                           (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
-                            (Just (unLoc $4)) [] Nothing) } }
+               {% do { (tc, tvs, _) <- checkSynHdr $4 False
+                     ; return (L (comb3 $1 $4 $6) 
+                                 (TyFunction tc tvs $3 (unLoc $6)))
+                     } }
+
+           -- type instance declarations
+        | 'type' 'instance' type '=' ctype
+               -- Note the use of type for the head; this allows
+               -- infix type constructors and type patterns
+               --
+               {% do { (tc, tvs, typats) <- checkSynHdr $3 True
+                     ; return (L (comb2 $1 $5) 
+                                 (TySynonym tc tvs (Just typats) $5)) 
+                      } }

 
 

-        -- data type or newtype declaration
+        -- ordinary data type or newtype declaration

        | data_or_newtype tycl_hdr constrs deriving
                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
        | data_or_newtype tycl_hdr constrs deriving
                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}

-                      ; tpats <- checkTyVars tparms True  -- can have type pats
+                      ; checkTyVars tparms    -- no type pattern

                      ; return $
                          L (comb4 $1 $2 $3 $4)
                                   -- We need the location on tycl_hdr in case 
                                   -- constrs and deriving are both empty
                      ; return $
                          L (comb4 $1 $2 $3 $4)
                                   -- We need the location on tycl_hdr in case 
                                   -- constrs and deriving are both empty

-                           (mkTyData (unLoc $1) (ctxt, tc, tvs, tpats) 
-                            Nothing (reverse (unLoc $3)) (unLoc $4)) } }
+                           (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
+                              Nothing (reverse (unLoc $3)) (unLoc $4)) } }

 
 

-        -- GADT declaration
+        -- ordinary GADT declaration

         | data_or_newtype tycl_hdr opt_kind_sig 
                 'where' gadt_constrlist
                 deriving
                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
         | data_or_newtype tycl_hdr opt_kind_sig 
                 'where' gadt_constrlist
                 deriving
                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}

-                      ; tpats <- checkTyVars tparms True -- can have type pats
+                      ; checkTyVars tparms    -- can have type pats

                      ; return $
                          L (comb4 $1 $2 $4 $5)
                      ; return $
                          L (comb4 $1 $2 $4 $5)

-                           (mkTyData (unLoc $1) (ctxt, tc, tvs, tpats) $3
-                            (reverse (unLoc $5)) (unLoc $6)) } }
+                           (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) $3
+                             (reverse (unLoc $5)) (unLoc $6)) } }
+
+        -- data/newtype family
+        | data_or_newtype 'family' tycl_hdr '::' kind
+               {% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
+                      ; checkTyVars tparms    -- no type pattern
+                     ; return $
+                         L (comb3 $1 $2 $5)
+                           (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
+                             (Just (unLoc $5)) [] Nothing) } }
+
+        -- data/newtype instance declaration
+       | data_or_newtype 'instance' tycl_hdr constrs deriving
+               {% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
+                                             -- can have type pats
+                     ; return $
+                         L (comb4 $1 $3 $4 $5)
+                                  -- We need the location on tycl_hdr in case 
+                                  -- constrs and deriving are both empty
+                           (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) 
+                             Nothing (reverse (unLoc $4)) (unLoc $5)) } }
+
+        -- GADT instance declaration
+        | data_or_newtype 'instance' tycl_hdr opt_kind_sig 
+                'where' gadt_constrlist
+                deriving
+               {% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
+                                             -- can have type pats
+                     ; return $
+                         L (comb4 $1 $3 $6 $7)
+                           (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms) 
+                              $4 (reverse (unLoc $6)) (unLoc $7)) } }

 
 opt_iso :: { Bool }
        :       { False }
        | 'iso' { True  }
 
 
 opt_iso :: { Bool }
        :       { False }
        | 'iso' { True  }
 

-kind_or_ctype :: { Either (Located Kind) (LHsType RdrName) }
-        : '::' kind     { Left  (LL (unLoc $2)) }
-       | '=' ctype     { Right (LL (unLoc $2)) }
-               -- Note ctype, not sigtype, on the right of '='
-               -- We allow an explicit for-all but we don't insert one
-               -- in   type Foo a = (b,b)
-               -- Instead we just say b is out of scope
-

 data_or_newtype :: { Located NewOrData }
        : 'data'        { L1 DataType }
        | 'newtype'     { L1 NewType }
 data_or_newtype :: { Located NewOrData }
        : 'data'        { L1 DataType }
        | 'newtype'     { L1 NewType }

@@ -1444,6 +1463,8 @@ varid_no_unsafe :: { Located RdrName }
        : VARID                 { L1 $! mkUnqual varName (getVARID $1) }
        | special_id            { L1 $! mkUnqual varName (unLoc $1) }
        | 'forall'              { L1 $! mkUnqual varName FSLIT("forall") }
        : VARID                 { L1 $! mkUnqual varName (getVARID $1) }
        | special_id            { L1 $! mkUnqual varName (unLoc $1) }
        | 'forall'              { L1 $! mkUnqual varName FSLIT("forall") }

+       | 'iso'                 { L1 $! mkUnqual varName FSLIT("iso") }
+       | 'family'              { L1 $! mkUnqual varName FSLIT("family") }

 
 qvarsym :: { Located RdrName }
        : varsym                { $1 }
 
 qvarsym :: { Located RdrName }
        : varsym                { $1 }

@@ -1467,7 +1488,8 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-'
 
 -- These special_ids are treated as keywords in various places, 
 -- but as ordinary ids elsewhere.   'special_id' collects all these
 
 -- These special_ids are treated as keywords in various places, 
 -- but as ordinary ids elsewhere.   'special_id' collects all these

--- except 'unsafe' and 'forall' whose treatment differs depending on context
+-- except 'unsafe', 'forall', 'family', and 'iso' whose treatment differs
+-- depending on context 

 special_id :: { Located FastString }
 special_id
        : 'as'                  { L1 FSLIT("as") }
 special_id :: { Located FastString }
 special_id
        : 'as'                  { L1 FSLIT("as") }

@@ -1478,7 +1500,6 @@ special_id
        | 'dynamic'             { L1 FSLIT("dynamic") }
        | 'stdcall'             { L1 FSLIT("stdcall") }
        | 'ccall'               { L1 FSLIT("ccall") }
        | 'dynamic'             { L1 FSLIT("dynamic") }
        | 'stdcall'             { L1 FSLIT("stdcall") }
        | 'ccall'               { L1 FSLIT("ccall") }

-       | 'iso'                 { L1 FSLIT("iso") }

 
 special_sym :: { Located FastString }
 special_sym : '!'      { L1 FSLIT("!") }
 
 special_sym :: { Located FastString }
 special_sym : '!'      { L1 FSLIT("!") }

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index b66c759..14ccd27 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -36,8 +36,8 @@ module RdrHsSyn (
        checkContext,         -- HsType -> P HsContext
        checkPred,            -- HsType -> P HsPred
        checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
        checkContext,         -- HsType -> P HsContext
        checkPred,            -- HsType -> P HsPred
        checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])

-       checkTyVars,          -- [LHsType RdrName] -> Bool -> P ()
-       checkSynHdr,          -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
+       checkTyVars,          -- [LHsType RdrName] -> P ()
+       checkSynHdr,          -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])

        checkKindSigs,        -- [LTyClDecl RdrName] -> P ()
        checkInstType,        -- HsType -> P HsType
        checkPattern,         -- HsExp -> P HsPat
        checkKindSigs,        -- [LTyClDecl RdrName] -> P ()
        checkInstType,        -- HsType -> P HsType
        checkPattern,         -- HsExp -> P HsPat

@@ -70,6 +70,7 @@ import FastString
 import Panic
 
 import List            ( isSuffixOf, nubBy )
 import Panic
 
 import List            ( isSuffixOf, nubBy )

+import Monad           ( unless )

 \end{code}
 
 
 \end{code}
 
 

@@ -378,25 +379,20 @@ checkInstType (L l t)
                   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 
 -- Check whether the given list of type parameters are all type variables
                   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
 
 -- Check whether the given list of type parameters are all type variables

--- (possibly with a kind signature).  If the second argument is `False', we
+-- (possibly with a kind signature).  If the second argument is `False',

 -- only type variables are allowed and we raise an error on encountering a
 -- only type variables are allowed and we raise an error on encountering a

--- non-variable; otherwise, we return the entire list parameters iff at least
--- one is not a variable.
+-- non-variable; otherwise, we allow non-variable arguments and return the
+-- entire list of parameters.

 --
 --

-checkTyVars :: [LHsType RdrName] -> Bool -> P (Maybe [LHsType RdrName])
-checkTyVars tparms nonVarsOk = 
-  do
-    areVars <- mapM chk tparms
-    return $ if and areVars then Nothing else Just tparms
+checkTyVars :: [LHsType RdrName] -> P ()
+checkTyVars tparms = mapM_ chk tparms

   where
        -- Check that the name space is correct!
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
   where
        -- Check that the name space is correct!
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))

-       | isRdrTyVar tv    = return True
+       | isRdrTyVar tv    = return ()

     chk (L l (HsTyVar tv))
     chk (L l (HsTyVar tv))

-        | isRdrTyVar tv    = return True
-    chk (L l other)
-        | nonVarsOk        = return False
-        | otherwise        = 
+        | isRdrTyVar tv    = return ()
+    chk (L l other)        =

          parseError l "Type found where type variable expected"
 
 -- Check whether the type arguments in a type synonym head are simply
          parseError l "Type found where type variable expected"
 
 -- Check whether the type arguments in a type synonym head are simply

@@ -405,14 +401,14 @@ checkTyVars tparms nonVarsOk =
 -- indicate a vanilla type synonym.
 --
 checkSynHdr :: LHsType RdrName 
 -- indicate a vanilla type synonym.
 --
 checkSynHdr :: LHsType RdrName 

-           -> Bool                             -- non-variables admitted?
+           -> Bool                             -- is type instance?

            -> P (Located RdrName,              -- head symbol
                  [LHsTyVarBndr RdrName],       -- parameters
            -> P (Located RdrName,              -- head symbol
                  [LHsTyVarBndr RdrName],       -- parameters

-                 Maybe [LHsType RdrName])      -- type patterns
-checkSynHdr ty nonVarsOk = 
+                 [LHsType RdrName])            -- type patterns
+checkSynHdr ty isTyInst = 

   do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
   do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty

-     ; typats <- checkTyVars tparms nonVarsOk
-     ; return (tc, tvs, typats) }
+     ; unless isTyInst $ checkTyVars tparms
+     ; return (tc, tvs, tparms) }

 
 
 -- Well-formedness check and decomposition of type and class heads.
 
 
 -- Well-formedness check and decomposition of type and class heads.