Support StandAloneKindSignatures and visible forall quantification

src/Language/Haskell/Exts/ExactPrint.hs

@@ -738,6 +738,13 @@ instance ExactP Decl where
         let pts = srcInfoPoints l
         printInterleaved' (zip pts (replicate (length pts - 1) "," ++ ["::"])) ns
         exactPC t
+    TypeKindSig     l ns t      ->
+        case srcInfoPoints l of
+         (a:pts) -> do
+            printStringAt (pos a) "type"
+            printInterleaved' (zip pts (replicate (length pts - 1) "," ++ ["::"])) ns
+            exactPC t
+         _ -> errorEP "ExactP: Decl: TypeKindSig is given wrong number of srcInfoPoints"
     PatSynSig l ns dh c1 _ c2 t -> do
         let (pat:pts) = srcInfoPoints l
         printStringAt (pos pat) "pattern"
@@ -1042,9 +1049,13 @@ instance ExactP TyVarBind where
                  [] -> exactPC n
                  _ -> errorEP "ExactP: TyVarBind: UnkindedVar is given wrong number of srcInfoPoints"
 
+exactQuantVisibility :: QuantVisibility -> String
+exactQuantVisibility InvisibleQuantification = "."
+exactQuantVisibility VisibleQuantification = "->"
+
 instance ExactP Type where
   exactP t' = case t' of
-    TyForall l mtvs mctxt t -> do
+    TyForall l mtvs q mctxt t -> do
         let pts = srcInfoPoints l
         _ <- case mtvs of
                 Nothing -> return pts
@@ -1053,7 +1064,7 @@ instance ExactP Type where
                      _:b:pts' -> do
                         printString "forall"
                         mapM_ exactPC tvs
-                        printStringAt (pos b) "."
+                        printStringAt (pos b) (exactQuantVisibility q)
                         return pts'
                      _ -> errorEP "ExactP: Type: TyForall is given too few srcInfoPoints"
         maybeEP exactPC mctxt

src/Language/Haskell/Exts/Extension.hs

@@ -560,6 +560,8 @@ data KnownExtension =
 
   | BlockArguments
 
+  | StandaloneKindSignatures
+
   deriving (Show, Read, Eq, Ord, Enum, Bounded, Data, Typeable)
 
 -- | Certain extensions imply other extensions, and this function

src/Language/Haskell/Exts/InternalParser.ly

@@ -580,13 +580,24 @@ shift/reduce-conflict, so we don't handle this case here, but in bodyaux.
 >       : topdecls1 semis topdecl       { ($3 : fst $1, snd $1 ++ reverse $2) }
 >       | topdecl                       { ([$1],[]) }
 
+> gtycons :: { [QName L] }
+>       : gtycon                        { [$1] }
+>       | gtycon ',' gtycons            { ($1 : $3) }
+
 > topdecl :: { Decl L }
 >       : role_annot                    {% checkEnabled RoleAnnotations >> return $1 }
 >       | 'type' dtype '=' truectype
 >                {% do { dh <- checkSimpleType $2;
 >                        let {l = nIS $1 <++> ann $4 <** [$1,$3]};
 >                        return (TypeDecl l dh $4) } }
 
+Requires the StandaloneKindSignatures extension.
+>       | 'type' gtycons '::' truectype
+>                {% do { checkEnabled StandaloneKindSignatures;
+>                        names <- mapM checkUnQual $2;
+>                        let {l = nIS $1 <++> ann $4 <** [$1,$3]};
+>                        return (TypeKindSig l names $4) } }
+
 Requires the TypeFamilies extension enabled, but the lexer will handle
 that through the 'family' keyword.
 >       | 'type' 'family' type opt_tyfam_kind_sig opt_injectivity_info where_type_family
@@ -819,7 +830,7 @@ Parsing the body of a closed type family, partially stolen from the source of GH
 >       | sigtype ',' sigtypes              { ($1 : fst $3, $2 : snd $3) }
 
 > sigtype :: { Type L }
->       : ctype                             {% checkType $ mkTyForall (ann $1) Nothing Nothing $1 }
+>       : ctype                             {% checkType $ mkTyForall (ann $1) Nothing InvisibleQuantification Nothing $1 }
 
 > name_boolformula :: { Maybe (BooleanFormula L) }
 >        : name_boolformula1         { Just $1 }
@@ -1086,9 +1097,13 @@ is any of the keyword-enabling ones, except ExistentialQuantification.
 > ctype :: { PType L }
 >       : ctype_('*',NEVER)             { $1 }
 
+> quantvis :: { (QuantVisibility,S) }
+>       : '.'                           { (InvisibleQuantification, $1) }
+>       | '->'                          { (VisibleQuantification, $1) }
+
 > ctype_(ostar,kstar) :: { PType L }
->       : 'forall' ktyvars '.' ctype_(ostar,kstar)      { mkTyForall (nIS $1 <++> ann $4 <** [$1,$3]) (Just (reverse (fst $2))) Nothing $4 }
->       | context_(ostar,kstar) ctype_(ostar,kstar)     { mkTyForall ($1 <> $2) Nothing (Just $1) $2 }
+>       : 'forall' ktyvars quantvis ctype_(ostar,kstar) { mkTyForall (nIS $1 <++> ann $4 <** [$1,snd $3]) (Just (reverse (fst $2))) (fst $3) Nothing $4 }
+>       | context_(ostar,kstar) ctype_(ostar,kstar)     { mkTyForall ($1 <> $2) Nothing InvisibleQuantification (Just $1) $2 }
 >       | type_(ostar,kstar)                            { $1 }
 
 Equality constraints require the TypeFamilies extension.

src/Language/Haskell/Exts/ParseSyntax.hs

@@ -301,6 +301,7 @@ instance Annotated PContext where
 data PType l
      = TyForall l
         (Maybe [TyVarBind l])
+        QuantVisibility
         (Maybe (PContext l))
         (PType l)
      | TyStar  l                                -- ^ @*@, the type of types
@@ -326,7 +327,7 @@ data PType l
 
 instance Annotated PType where
     ann t = case t of
-      TyForall l _ _ _              -> l
+      TyForall l _ _ _ _            -> l
       TyStar  l                     -> l
       TyFun   l _ _                 -> l
       TyTuple l _ _                 -> l
@@ -347,7 +348,7 @@ instance Annotated PType where
       TyWildCard  l _               -> l
       TyQuasiQuote l _ _            -> l
     amap f t' = case t' of
-      TyForall l mtvs mcx t         -> TyForall (f l) mtvs mcx t
+      TyForall l mtvs q mcx t       -> TyForall (f l) mtvs q mcx t
       TyStar  l                     -> TyStar (f l)
       TyFun   l t1 t2               -> TyFun (f l) t1 t2
       TyTuple l b ts                -> TyTuple (f l) b ts

src/Language/Haskell/Exts/ParseUtils.hs

@@ -298,7 +298,7 @@ checkAsst asst =
 
 
 checkDataHeader :: PType L -> P (Maybe (S.Context L), DeclHead L)
-checkDataHeader (TyForall _ Nothing cs t) = do
+checkDataHeader (TyForall _ Nothing _ cs t) = do
     dh <- checkSimple "data/newtype" t
     cs' <- checkContext cs
     return (cs',dh)
@@ -307,7 +307,7 @@ checkDataHeader t = do
     return (Nothing,dh)
 
 checkClassHeader :: PType L -> P (Maybe (S.Context L), DeclHead L)
-checkClassHeader (TyForall _ Nothing cs t) = do
+checkClassHeader (TyForall _ Nothing _ cs t) = do
     checkMultiParam t
     dh <- checkSimple "class" t
     cs' <- checkSContext cs
@@ -360,7 +360,7 @@ toTyVarBind (TyKind l (TyVar _ n) k) = KindedVar l n k
 
 checkInstHeader :: PType L -> P (InstRule L)
 checkInstHeader (TyParen l t) = checkInstHeader t >>= return . IParen l
-checkInstHeader (TyForall l mtvs cs t) = do
+checkInstHeader (TyForall l mtvs _ cs t) = do
     cs' <- checkSContext cs
     checkMultiParam t
     checkInsts (Just l) mtvs cs' t
@@ -1084,14 +1084,14 @@ checkType t = checkT t False
 
 checkT :: PType L -> Bool -> P (S.Type L)
 checkT t simple = case t of
-    TyForall l Nothing cs pt    -> do
+    TyForall l Nothing q cs pt    -> do
             when simple $ checkEnabled ExplicitForAll
             ctxt <- checkContext cs
-            check1Type pt (S.TyForall l Nothing ctxt)
-    TyForall l tvs cs pt -> do
+            check1Type pt (S.TyForall l Nothing q ctxt)
+    TyForall l tvs q cs pt -> do
             checkEnabled ExplicitForAll
             ctxt <- checkContext cs
-            check1Type pt (S.TyForall l tvs ctxt)
+            check1Type pt (S.TyForall l tvs q ctxt)
     TyStar  l         -> return $ S.TyStar l
     TyFun   l at rt   -> check2Types at rt (S.TyFun l)
     TyTuple l b pts   -> checkTypes pts >>= return . S.TyTuple l b
@@ -1198,11 +1198,11 @@ mkDVar = intercalate "-"
 --
 -- A valid type must have one for-all at the top of the type, or of the fn arg types
 
-mkTyForall :: L -> Maybe [TyVarBind L] -> Maybe (PContext L) -> PType L -> PType L
-mkTyForall l mtvs ctxt ty =
+mkTyForall :: L -> Maybe [TyVarBind L] -> QuantVisibility -> Maybe (PContext L) -> PType L -> PType L
+mkTyForall l mtvs qv ctxt ty =
     case (ctxt, ty) of
-        (Nothing, TyForall _ Nothing ctxt2 ty2) -> TyForall l mtvs ctxt2 ty2
-        _                                       -> TyForall l mtvs ctxt ty
+        (Nothing, TyForall _ Nothing qv2 ctxt2 ty2) -> TyForall l mtvs qv2 ctxt2 ty2
+        _                                           -> TyForall l mtvs qv ctxt ty
 
 -- Make a role annotation
 

src/Language/Haskell/Exts/Pretty.hs

@@ -487,14 +487,17 @@ instance  Pretty (Decl l) where
                 mySep ((punctuate comma . map pretty $ nameList)
                       ++ [text "::", pretty qualType])
 
+        pretty (TypeKindSig _ ns qualType) =
+                mySep ([text "type"] ++ punctuate comma (map pretty ns) ++ [text "::", pretty qualType])
+
         --  Req can be ommitted if it is empty
         --  We must print prov if req is nonempty
         pretty (PatSynSig _ ns mtvs prov mtvs2 req t) =
-                let contexts = [maybePP pretty prov, ppForall mtvs2, maybePP pretty req]
+                let contexts = [maybePP pretty prov, ppForall mtvs2 InvisibleQuantification, maybePP pretty req]
                  in
                   mySep ( [text "pattern" ]
                            ++ punctuate comma (map pretty ns)
-                           ++ [ text "::", ppForall mtvs] ++
+                           ++ [ text "::", ppForall mtvs InvisibleQuantification] ++
                           contexts ++ [pretty t] )
 
 
@@ -578,7 +581,7 @@ instance  Pretty (Decl l) where
 
 instance Pretty (InstRule l) where
     pretty (IRule _ tvs mctxt qn)  =
-            mySep [ppForall tvs
+            mySep [ppForall tvs InvisibleQuantification
                   , maybePP pretty mctxt, pretty qn]
     pretty (IParen _ ih)        = parens (pretty ih)
 
@@ -769,15 +772,15 @@ instance Pretty Tool where
 ------------------------- Data & Newtype Bodies -------------------------
 instance  Pretty (QualConDecl l) where
         pretty (QualConDecl _pos tvs ctxt con) =
-                myFsep [ppForall tvs, maybePP pretty ctxt, pretty con]
+                myFsep [ppForall tvs InvisibleQuantification, maybePP pretty ctxt, pretty con]
 
 instance  Pretty (GadtDecl l) where
         pretty (GadtDecl _pos name tvs ctxt names ty) =
             case names of
                 Nothing ->
                     myFsep [pretty name, text "::", pretty ty]
                 Just ts' ->
-                    myFsep [pretty name, text "::" , ppForall tvs, maybePP pretty ctxt,
+                    myFsep [pretty name, text "::" , ppForall tvs InvisibleQuantification, maybePP pretty ctxt,
                          braceList . map pretty $ ts', text "->", pretty ty]
 
 instance  Pretty (ConDecl l) where
@@ -850,8 +853,8 @@ prec_btype = 1  -- left argument of ->,
 prec_atype = 2  -- argument of type or data constructor, or of a class
 
 instance  Pretty (Type l) where
-        prettyPrec p (TyForall _ mtvs ctxt htype) = parensIf (p > 0) $
-                myFsep [ppForall mtvs, maybePP pretty ctxt, pretty htype]
+        prettyPrec p (TyForall _ mtvs q ctxt htype) = parensIf (p > 0) $
+                myFsep [ppForall mtvs q, maybePP pretty ctxt, pretty htype]
         prettyPrec _ (TyStar _) = text "*"
         prettyPrec p (TyFun _ a b) = parensIf (p > 0) $
                 myFsep [ppBType a, text "->", pretty b]
@@ -906,10 +909,14 @@ instance  Pretty (TyVarBind l) where
         pretty (KindedVar _ var kind) = parens $ myFsep [pretty var, text "::", pretty kind]
         pretty (UnkindedVar _ var)    = pretty var
 
-ppForall :: Maybe [TyVarBind l] -> Doc
-ppForall Nothing   = empty
-ppForall (Just []) = empty
-ppForall (Just vs) =    myFsep (text "forall" : map pretty vs ++ [char '.'])
+ppForall :: Maybe [TyVarBind l] -> QuantVisibility -> Doc
+ppForall Nothing _  = empty
+ppForall (Just []) _ = empty
+ppForall (Just vs) q =    myFsep (text "forall" : map pretty vs ++ [ppQuantVisibility q])
+
+ppQuantVisibility :: QuantVisibility -> Doc
+ppQuantVisibility InvisibleQuantification = text "."
+ppQuantVisibility VisibleQuantification = text " ->"
 
 ---------------------------- Kinds ----------------------------
 
@@ -1674,8 +1681,8 @@ instance SrcInfo loc => Pretty (P.PAsst loc) where
         pretty (P.ParenA _ a)      = parens (pretty a)
 
 instance SrcInfo loc => Pretty (P.PType loc) where
-        prettyPrec p (P.TyForall _ mtvs ctxt htype) = parensIf (p > 0) $
-                myFsep [ppForall mtvs, maybePP pretty ctxt, pretty htype]
+        prettyPrec p (P.TyForall _ mtvs q ctxt htype) = parensIf (p > 0) $
+                myFsep [ppForall mtvs q, maybePP pretty ctxt, pretty htype]
         prettyPrec _ (P.TyStar _) = text "*"
         prettyPrec p (P.TyFun _ a b) = parensIf (p > 0) $
                 myFsep [prettyPrec prec_btype a, text "->", pretty b]

src/Language/Haskell/Exts/Syntax.hs

@@ -65,7 +65,7 @@ module Language.Haskell.Exts.Syntax (
     -- * Class Assertions and Contexts
     Context(..), FunDep(..), Asst(..),
     -- * Types
-    Type(..), Boxed(..), Kind, TyVarBind(..), Promoted(..),
+    Type(..), Boxed(..), QuantVisibility(..), Kind, TyVarBind(..), Promoted(..),
     TypeEqn (..),
     -- * Expressions
     Exp(..), Stmt(..), QualStmt(..), FieldUpdate(..),
@@ -303,6 +303,8 @@ data Decl l
      -- ^ A typed Template Haskell splicing declaration
      | TypeSig      l [Name l] (Type l)
      -- ^ A type signature declaration
+     | TypeKindSig  l [Name l] (Type l)
+     -- ^ A stand-alone kind signature declaration of one or more type
      | PatSynSig    l [Name l] (Maybe [TyVarBind l]) (Maybe (Context l))
                                (Maybe [TyVarBind l]) (Maybe (Context l))
                                                      (Type l)
@@ -629,6 +631,7 @@ data GuardedRhs l
 data Type l
      = TyForall l
         (Maybe [TyVarBind l])
+        QuantVisibility
         (Maybe (Context l))
         (Type l)                                -- ^ qualified type
      | TyStar  l                                -- ^ @*@, the type of types
@@ -670,6 +673,11 @@ data Promoted l
 data Boxed = Boxed | Unboxed
   deriving (Eq,Ord,Show,Typeable,Data,Generic)
 
+data QuantVisibility
+    = InvisibleQuantification
+    | VisibleQuantification
+    deriving (Eq,Ord,Show,Typeable,Data,Generic)
+
 -- | A type variable declaration, optionally with an explicit kind annotation.
 data TyVarBind l
     = KindedVar   l (Name l) (Kind l)  -- ^ variable binding with kind annotation
@@ -1291,6 +1299,7 @@ instance Annotated Decl where
         SpliceDecl   l _                -> l
         TSpliceDecl  l _                -> l
         TypeSig      l _ _              -> l
+        TypeKindSig  l _ _              -> l
         PatSynSig    l _ _ _ _ _ _      -> l
         FunBind      l _                -> l
         PatBind      l _ _ _            -> l
@@ -1329,6 +1338,7 @@ instance Annotated Decl where
         SpliceDecl   l sp                -> SpliceDecl (f l) sp
         TSpliceDecl  l sp                -> TSpliceDecl (f l) sp
         TypeSig      l ns t              -> TypeSig (f l) ns t
+        TypeKindSig  l ns t              -> TypeKindSig (f l) ns t
         PatSynSig    l n dh c1 dh2 c2 t      -> PatSynSig (f l) n dh c1 dh2 c2 t
         FunBind      l ms                -> FunBind (f l) ms
         PatBind      l p rhs bs          -> PatBind (f l) p rhs bs
@@ -1501,7 +1511,7 @@ instance Annotated GuardedRhs where
 
 instance Annotated Type where
     ann t = case t of
-      TyForall l _ _ _              -> l
+      TyForall l _ _ _ _            -> l
       TyStar  l                     -> l
       TyFun   l _ _                 -> l
       TyTuple l _ _                 -> l
@@ -1521,7 +1531,7 @@ instance Annotated Type where
       TyWildCard l _                -> l
       TyQuasiQuote l _ _            -> l
     amap f t1 = case t1 of
-      TyForall l mtvs mcx t         -> TyForall (f l) mtvs mcx t
+      TyForall l mtvs q mcx t       -> TyForall (f l) mtvs q mcx t
       TyStar  l                     -> TyStar (f l)
       TyFun   l t1' t2              -> TyFun (f l) t1' t2
       TyTuple l b ts                -> TyTuple (f l) b ts

tests/examples/ClassContext.hs.parser.golden

@@ -33,6 +33,7 @@ ParseOk
                , srcInfoPoints = []
                }
              Nothing
+             InvisibleQuantification
              (Just
                 (CxSingle
                    SrcSpanInfo

tests/examples/ConstraintKinds.hs.parser.golden

@@ -334,6 +334,7 @@ ParseOk
                , srcInfoPoints = []
                }
              Nothing
+             InvisibleQuantification
              (Just
                 (CxSingle
                    SrcSpanInfo

tests/examples/ConstraintKinds2.hs.parser.golden

@@ -142,6 +142,7 @@ ParseOk
                    , srcInfoPoints = []
                    }
                  Nothing
+                 InvisibleQuantification
                  (Just
                     (CxSingle
                        SrcSpanInfo

tests/examples/ConstraintKinds3.hs.parser.golden

@@ -144,6 +144,7 @@ ParseOk
                          , srcInfoPoints = []
                          }
                        Nothing
+                       InvisibleQuantification
                        (Just
                           (CxSingle
                              SrcSpanInfo

tests/examples/ConstructorAndClassOperators.hs.parser.golden

@@ -66,6 +66,7 @@ ParseOk
                , srcInfoPoints = []
                }
              Nothing
+             InvisibleQuantification
              (Just
                 (CxSingle
                    SrcSpanInfo

tests/examples/ContextOrdering.hs.parser.golden

@@ -71,6 +71,7 @@ ParseOk
                , srcInfoPoints = []
                }
              Nothing
+             InvisibleQuantification
              (Just
                 (CxSingle
                    SrcSpanInfo