Skip to content

Commit

Permalink
Parse forall in provided constraints
Browse files Browse the repository at this point in the history 
Fixes #403
  • Loading branch information
@mpickering
mpickering committed Aug 10, 2018
1 parent 756e7f3 commit d97e3bb
Show file tree
Hide file tree
Showing 13 changed files with 584 additions and 14 deletions.
2 changes: 1 addition & 1 deletion src/Language/Haskell/Exts/ExactPrint.hs
View file
Expand Up @@ -733,7 +733,7 @@ instance ExactP Decl where
let pts = srcInfoPoints l
printInterleaved' (zip pts (replicate (length pts - 1) "," ++ ["::"])) ns
exactPC t
PatSynSig l ns dh c1 c2 t -> do
PatSynSig l ns dh c1 _ c2 t -> do
let (pat:pts) = srcInfoPoints l
printStringAt (pos pat) "pattern"
printInterleaved' (zip pts (replicate (length ns - 1) "," ++ ["::"])) ns
Expand Down
22 changes: 14 additions & 8 deletions src/Language/Haskell/Exts/InternalParser.ly
View file
Expand Up @@ -2091,25 +2091,31 @@ Pattern Synonyms
> pattern_synonym_sig :: { Decl L }
> : 'pattern' con_list '::' pstype
> {% do { checkEnabled PatternSynonyms ;
> let {(qtvs, ps, prov, req, ty) = $4} ;
> let {sig = PatSynSig (nIS $1 <++> ann ty <** [$1] ++ fst $2 ++ [$3] ++ ps) (snd $2) qtvs prov req ty} ;
> let {(qtvs, ps, prov, req_vars, req, ty) = $4} ;
> let {sig = PatSynSig (nIS $1 <++> ann ty <** [$1] ++ fst $2 ++ [$3] ++ ps) (snd $2) qtvs prov req_vars req ty} ;
> return sig } }

> pstype :: { (Maybe [TyVarBind L], [S], Maybe (Context L), Maybe (Context L), Type L )}
> pstype :: { (Maybe [TyVarBind L], [S], Maybe (Context L), Maybe [TyVarBind L]
> , Maybe (Context L), Type L )}
> : 'forall' ktyvars '.' pstype
> { let (qtvs, ps, prov, req, ty) = $4
> in (Just (reverse (fst $2) ++ fromMaybe [] qtvs), ($1 : $3 : ps), prov, req, ty) }
> { let (qtvs, ps, prov, req_vars, req, ty) = $4
> in (Just (reverse (fst $2) ++ fromMaybe [] qtvs), ($1 : $3 : ps), prov, req_vars, req, ty) }
> | context context type
> {% do { c1 <- checkContext (Just $1) ;
> c2 <- checkContext (Just $2) ;
> t <- checkType $3 ;
> return $ (Nothing, [], c1, c2, t) }}
> return $ (Nothing, [], c1, Nothing, c2, t) }}
> | context 'forall' ktyvars '.' context type
> {% do { c1 <- checkContext (Just $1) ;
> c2 <- checkContext (Just $5) ;
> t <- checkType $6 ;
> return $ (Nothing, [], c1, Just (reverse (fst $3)), c2, t) }}
> | context type
> {% do { c1 <- checkContext (Just $1);
> t <- checkType $2;
> return (Nothing, [], c1, Nothing, t) } }
> return (Nothing, [], c1, Nothing, Nothing, t) } }
> | type
> {% checkType $1 >>= \t -> return (Nothing, [], Nothing, Nothing, t) }
> {% checkType $1 >>= \t -> return (Nothing, [], Nothing, Nothing, Nothing, t) }

-----------------------------------------------------------------------------
Deriving strategies
Expand Down
4 changes: 2 additions & 2 deletions src/Language/Haskell/Exts/Pretty.hs
View file
Expand Up @@ -486,8 +486,8 @@ instance Pretty (Decl l) where

-- Req can be ommitted if it is empty
-- We must print prov if req is nonempty
pretty (PatSynSig _ ns mtvs prov req t) =
let contexts = map (maybePP pretty) [prov, req]
pretty (PatSynSig _ ns mtvs prov mtvs2 req t) =
let contexts = [maybePP pretty prov, ppForall mtvs2, maybePP pretty req]
in
mySep ( [text "pattern" ]
++ punctuate comma (map pretty ns)
Expand Down
8 changes: 5 additions & 3 deletions src/Language/Haskell/Exts/Syntax.hs
View file
Expand Up @@ -301,7 +301,9 @@ data Decl l
-- ^ A Template Haskell splicing declaration
| TypeSig l [Name l] (Type l)
-- ^ A type signature declaration
| PatSynSig l [Name l] (Maybe [TyVarBind l]) (Maybe (Context l)) (Maybe (Context l)) (Type l)
| PatSynSig l [Name l] (Maybe [TyVarBind l]) (Maybe (Context l))
(Maybe [TyVarBind l]) (Maybe (Context l))
(Type l)
-- ^ A pattern synonym signature declation
| FunBind l [Match l]
-- ^ A set of function binding clauses
Expand Down Expand Up @@ -1286,7 +1288,7 @@ instance Annotated Decl where
DefaultDecl l _ -> l
SpliceDecl l _ -> l
TypeSig l _ _ -> l
PatSynSig l _ _ _ _ _ -> l
PatSynSig l _ _ _ _ _ _ -> l
FunBind l _ -> l
PatBind l _ _ _ -> l
ForImp l _ _ _ _ _ -> l
Expand Down Expand Up @@ -1323,7 +1325,7 @@ instance Annotated Decl where
DefaultDecl l ts -> DefaultDecl (f l) ts
SpliceDecl l sp -> SpliceDecl (f l) sp
TypeSig l ns t -> TypeSig (f l) ns t
PatSynSig l n dh c1 c2 t -> PatSynSig (f l) n dh c1 c2 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
ForImp l cc msf s n t -> ForImp (f l) cc msf s n t
Expand Down
6 changes: 6 additions & 0 deletions tests/examples/PatternSynonymSignatures.hs.parser.golden
View file
Expand Up @@ -57,6 +57,7 @@ ParseOk
Nothing
Nothing
Nothing
Nothing
(TyCon
SrcSpanInfo
{ srcInfoSpan =
Expand Down Expand Up @@ -105,6 +106,7 @@ ParseOk
, SrcSpan "tests/examples/PatternSynonymSignatures.hs" 6 19 6 21
]
}))
Nothing
(Just
(CxEmpty
SrcSpanInfo
Expand Down Expand Up @@ -195,6 +197,7 @@ ParseOk
}
"a")
])))
Nothing
(Just
(CxSingle
SrcSpanInfo
Expand Down Expand Up @@ -319,6 +322,7 @@ ParseOk
"b")
])))
Nothing
Nothing
(TyCon
SrcSpanInfo
{ srcInfoSpan =
Expand Down Expand Up @@ -400,6 +404,7 @@ ParseOk
}
"b")
])))
Nothing
(Just
(CxEmpty
SrcSpanInfo
Expand Down Expand Up @@ -459,6 +464,7 @@ ParseOk
, SrcSpan "tests/examples/PatternSynonymSignatures.hs" 14 19 14 21
]
}))
Nothing
(Just
(CxSingle
SrcSpanInfo
Expand Down
8 changes: 8 additions & 0 deletions tests/examples/PatternSynonyms3.hs.parser.golden
View file
Expand Up @@ -464,6 +464,7 @@ ParseOk
Nothing
Nothing
Nothing
Nothing
(TyFun
SrcSpanInfo
{ srcInfoSpan =
Expand Down Expand Up @@ -601,6 +602,7 @@ ParseOk
, SrcSpan "tests/examples/PatternSynonyms3.hs" 16 22 16 24
]
}))
Nothing
(Just
(CxSingle
SrcSpanInfo
Expand Down Expand Up @@ -991,6 +993,7 @@ ParseOk
Nothing
Nothing
Nothing
Nothing
(TyFun
SrcSpanInfo
{ srcInfoSpan =
Expand Down Expand Up @@ -1483,6 +1486,7 @@ ParseOk
Nothing
Nothing
Nothing
Nothing
(TyFun
SrcSpanInfo
{ srcInfoSpan =
Expand Down Expand Up @@ -1776,6 +1780,7 @@ ParseOk
, SrcSpan "tests/examples/PatternSynonyms3.hs" 34 37 34 39
]
}))
Nothing
(Just
(CxEmpty
SrcSpanInfo
Expand Down Expand Up @@ -1910,6 +1915,7 @@ ParseOk
]
]))))
Nothing
Nothing
(TyFun
SrcSpanInfo
{ srcInfoSpan =
Expand Down Expand Up @@ -2215,6 +2221,7 @@ ParseOk
Nothing
Nothing
Nothing
Nothing
(TyApp
SrcSpanInfo
{ srcInfoSpan =
Expand Down Expand Up @@ -2368,6 +2375,7 @@ ParseOk
Nothing
Nothing
Nothing
Nothing
(TyFun
SrcSpanInfo
{ srcInfoSpan =
Expand Down
1 change: 1 addition & 0 deletions tests/examples/T11727.hs.parser.golden
View file
Expand Up @@ -72,6 +72,7 @@ ParseOk
Nothing
Nothing
Nothing
Nothing
(TyCon
SrcSpanInfo
{ srcInfoSpan = SrcSpan "tests/examples/T11727.hs" 5 16 5 19
Expand Down
1 change: 1 addition & 0 deletions tests/examples/completesig01.hs.parser.golden
View file
Expand Up @@ -101,6 +101,7 @@ ParseOk
Nothing
Nothing
Nothing
Nothing
(TyCon
SrcSpanInfo
{ srcInfoSpan = SrcSpan "tests/examples/completesig01.hs" 6 16 6 18
Expand Down
9 changes: 9 additions & 0 deletions tests/examples/t403.hs
View file
@@ -0,0 +1,9 @@
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
module T403 where

pattern (:&&:) :: () => forall k. ((k :+ 1) ~ n) => a -> HoHeList k a -> HoHeList n a
pattern (:&&:) x rest <- (matchNext -> Right (x, Refl, rest))
10 changes: 10 additions & 0 deletions tests/examples/t403.hs.exactprinter.golden
View file
@@ -0,0 +1,10 @@
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
module T403 where

pattern (:&&:) :: () => ((k :+ 1) ~ n) => a -> HoHeList k a -> HoHeList n a
pattern ((:&&:))xrest <- (matchNext -> Right (x, Refl, rest))

0 comments on commit d97e3bb

Please sign in to comment.