diff --git a/src/Language/Haskell/Exts/ExactPrint.hs b/src/Language/Haskell/Exts/ExactPrint.hs index 394b858b..2e940868 100644 --- a/src/Language/Haskell/Exts/ExactPrint.hs +++ b/src/Language/Haskell/Exts/ExactPrint.hs @@ -248,6 +248,9 @@ instance ExactP SpecialCon where FunCon l -> case srcInfoPoints l of [_,b,_] -> printStringAt (pos b) "->" _ -> errorEP "ExactP: SpecialCon is given wrong number of srcInfoPoints" + TyEqCon l -> case srcInfoPoints l of + [_,b,_] -> printStringAt (pos b) "~" + _ -> errorEP "ExactP: SpecialCon is given wrong number of srcInfoPoints" TupleCon l b n -> printPoints l $ case b of Unboxed -> "(#": replicate (n-1) "," ++ ["#)"] @@ -265,6 +268,7 @@ isSymbolQName (UnQual _ n) = isSymbolName n isSymbolQName (Qual _ _ n) = isSymbolName n isSymbolQName (Special _ Cons{}) = True isSymbolQName (Special _ FunCon{}) = True +isSymbolQName (Special _ TyEqCon{}) = True isSymbolQName _ = False instance ExactP QName where diff --git a/src/Language/Haskell/Exts/InternalParser.ly b/src/Language/Haskell/Exts/InternalParser.ly index 1c165bf6..8e7edd94 100644 --- a/src/Language/Haskell/Exts/InternalParser.ly +++ b/src/Language/Haskell/Exts/InternalParser.ly @@ -1037,6 +1037,7 @@ the (# and #) lexemes. Kinds will be handled at the kind rule. > : otycon_(ostar) { $1 } > | '(' ')' { unit_tycon_name ($1 <^^> $2 <** [$1,$2]) } > | '(' '->' ')' { fun_tycon_name ($1 <^^> $3 <** [$1,$2,$3]) } +> | '(' '~' ')' { tyeq_tycon_name ($1 <^^> $3 <** [$1,$2,$3]) } > | '[' ']' { list_tycon_name ($1 <^^> $2 <** [$1,$2]) } > | '(' commas ')' { tuple_tycon_name ($1 <^^> $3 <** ($1:reverse $2 ++ [$3])) Boxed (length $2) } > | '(#' '#)' { unboxed_singleton_tycon_name ($1 <^^> $2 <** [$1,$2]) } diff --git a/src/Language/Haskell/Exts/Pretty.hs b/src/Language/Haskell/Exts/Pretty.hs index dfe574eb..9349de46 100644 --- a/src/Language/Haskell/Exts/Pretty.hs +++ b/src/Language/Haskell/Exts/Pretty.hs @@ -1317,6 +1317,7 @@ instance Pretty (SpecialCon l) where pretty (UnitCon {}) = text "()" pretty (ListCon {}) = text "[]" pretty (FunCon {}) = text "->" + pretty (TyEqCon {}) = text "~" pretty (TupleCon _ b n) = listFun $ foldr (<>) empty (replicate (n-1) comma) where listFun = if b == Unboxed then hashParens else parens pretty (Cons {}) = text ":" @@ -1332,6 +1333,7 @@ isSymbolQName (UnQual _ n) = isSymbolName n isSymbolQName (Qual _ _ n) = isSymbolName n isSymbolQName (Special _ (Cons {})) = True isSymbolQName (Special _ (FunCon {})) = True +isSymbolQName (Special _ (TyEqCon {})) = True isSymbolQName _ = False --getSpecialName :: QName l -> Maybe (SpecialCon l) diff --git a/src/Language/Haskell/Exts/Syntax.hs b/src/Language/Haskell/Exts/Syntax.hs index e67c4ca1..b9f9a1cc 100644 --- a/src/Language/Haskell/Exts/Syntax.hs +++ b/src/Language/Haskell/Exts/Syntax.hs @@ -106,7 +106,7 @@ module Language.Haskell.Exts.Syntax ( javascript_name, capi_name, forall_name, family_name, role_name, hole_name, stock_name, anyclass_name, via_name, -- ** Type constructors - unit_tycon_name, fun_tycon_name, list_tycon_name, tuple_tycon_name, unboxed_singleton_tycon_name, + unit_tycon_name, fun_tycon_name, tyeq_tycon_name, list_tycon_name, tuple_tycon_name, unboxed_singleton_tycon_name, unit_tycon, fun_tycon, list_tycon, tuple_tycon, unboxed_singleton_tycon, -- * Source coordinates @@ -136,6 +136,7 @@ data SpecialCon l = UnitCon l -- ^ unit type and data constructor @()@ | ListCon l -- ^ list type and data constructor @[]@ | FunCon l -- ^ function type constructor @->@ + | TyEqCon l -- ^ type equality constructor @~@ | TupleCon l Boxed Int -- ^ /n/-ary tuple type and data -- constructors @(,)@ etc, possibly boxed @(\#,\#)@ | Cons l -- ^ list data constructor @(:)@ @@ -1074,10 +1075,11 @@ stock_name l = Ident l "stock" anyclass_name l = Ident l "anyclass" via_name l = Ident l "via" -unit_tycon_name, fun_tycon_name, list_tycon_name, unboxed_singleton_tycon_name :: l -> QName l +unit_tycon_name, fun_tycon_name, list_tycon_name, tyeq_tycon_name, unboxed_singleton_tycon_name :: l -> QName l unit_tycon_name l = unit_con_name l fun_tycon_name l = Special l (FunCon l) list_tycon_name l = Special l (ListCon l) +tyeq_tycon_name l = Special l (TyEqCon l) unboxed_singleton_tycon_name l = Special l (UnboxedSingleCon l) tuple_tycon_name :: l -> Boxed -> Int -> QName l @@ -1120,6 +1122,7 @@ instance Annotated SpecialCon where UnitCon l -> l ListCon l -> l FunCon l -> l + TyEqCon l -> l TupleCon l _ _ -> l Cons l -> l UnboxedSingleCon l -> l diff --git a/tests/examples/EqualityConstraints3.hs b/tests/examples/EqualityConstraints3.hs new file mode 100644 index 00000000..45109047 --- /dev/null +++ b/tests/examples/EqualityConstraints3.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE GADTs, FlexibleContexts #-} + +one :: (~) a Int => a +one = 1 diff --git a/tests/examples/EqualityConstraints3.hs.exactprinter.golden b/tests/examples/EqualityConstraints3.hs.exactprinter.golden new file mode 100644 index 00000000..1796dc27 --- /dev/null +++ b/tests/examples/EqualityConstraints3.hs.exactprinter.golden @@ -0,0 +1 @@ +Match diff --git a/tests/examples/EqualityConstraints3.hs.parser.golden b/tests/examples/EqualityConstraints3.hs.parser.golden new file mode 100644 index 00000000..4a673f05 --- /dev/null +++ b/tests/examples/EqualityConstraints3.hs.parser.golden @@ -0,0 +1,190 @@ +ParseOk + ( Module + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 1 1 5 1 + , srcInfoPoints = + [ SrcSpan "tests/examples/EqualityConstraints3.hs" 1 1 1 1 + , SrcSpan "tests/examples/EqualityConstraints3.hs" 3 1 3 1 + , SrcSpan "tests/examples/EqualityConstraints3.hs" 3 1 3 1 + , SrcSpan "tests/examples/EqualityConstraints3.hs" 3 1 3 1 + , SrcSpan "tests/examples/EqualityConstraints3.hs" 4 1 4 1 + , SrcSpan "tests/examples/EqualityConstraints3.hs" 5 1 5 1 + , SrcSpan "tests/examples/EqualityConstraints3.hs" 5 1 5 1 + ] + } + Nothing + [ LanguagePragma + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 1 1 1 41 + , srcInfoPoints = + [ SrcSpan "tests/examples/EqualityConstraints3.hs" 1 1 1 13 + , SrcSpan "tests/examples/EqualityConstraints3.hs" 1 19 1 20 + , SrcSpan "tests/examples/EqualityConstraints3.hs" 1 38 1 41 + ] + } + [ Ident + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 1 14 1 19 + , srcInfoPoints = [] + } + "GADTs" + , Ident + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 1 21 1 37 + , srcInfoPoints = [] + } + "FlexibleContexts" + ] + ] + [] + [ TypeSig + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 3 1 3 22 + , srcInfoPoints = + [ SrcSpan "tests/examples/EqualityConstraints3.hs" 3 5 3 7 ] + } + [ Ident + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 3 1 3 4 + , srcInfoPoints = [] + } + "one" + ] + (TyForall + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 3 8 3 22 + , srcInfoPoints = [] + } + Nothing + (Just + (CxSingle + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 3 8 3 20 + , srcInfoPoints = + [ SrcSpan "tests/examples/EqualityConstraints3.hs" 3 18 3 20 ] + } + (ClassA + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 3 8 3 20 + , srcInfoPoints = + [ SrcSpan "tests/examples/EqualityConstraints3.hs" 3 18 3 20 ] + } + (Special + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 3 8 3 11 + , srcInfoPoints = + [ SrcSpan "tests/examples/EqualityConstraints3.hs" 3 8 3 9 + , SrcSpan "tests/examples/EqualityConstraints3.hs" 3 9 3 10 + , SrcSpan "tests/examples/EqualityConstraints3.hs" 3 10 3 11 + ] + } + (TyEqCon + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 3 8 3 11 + , srcInfoPoints = + [ SrcSpan "tests/examples/EqualityConstraints3.hs" 3 8 3 9 + , SrcSpan "tests/examples/EqualityConstraints3.hs" 3 9 3 10 + , SrcSpan "tests/examples/EqualityConstraints3.hs" 3 10 3 11 + ] + })) + [ TyVar + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 3 12 3 13 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 3 12 3 13 + , srcInfoPoints = [] + } + "a") + , TyCon + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 3 14 3 17 + , srcInfoPoints = [] + } + (UnQual + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 3 14 3 17 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 3 14 3 17 + , srcInfoPoints = [] + } + "Int")) + ]))) + (TyVar + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 3 21 3 22 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 3 21 3 22 + , srcInfoPoints = [] + } + "a"))) + , PatBind + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 4 1 4 8 + , srcInfoPoints = [] + } + (PVar + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 4 1 4 4 + , srcInfoPoints = [] + } + (Ident + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 4 1 4 4 + , srcInfoPoints = [] + } + "one")) + (UnGuardedRhs + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 4 5 4 8 + , srcInfoPoints = + [ SrcSpan "tests/examples/EqualityConstraints3.hs" 4 5 4 6 ] + } + (Lit + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 4 7 4 8 + , srcInfoPoints = [] + } + (Int + SrcSpanInfo + { srcInfoSpan = + SrcSpan "tests/examples/EqualityConstraints3.hs" 4 7 4 8 + , srcInfoPoints = [] + } + 1 + "1"))) + Nothing + ] + , [] + ) diff --git a/tests/examples/EqualityConstraints3.hs.prettyparser.golden b/tests/examples/EqualityConstraints3.hs.prettyparser.golden new file mode 100644 index 00000000..1796dc27 --- /dev/null +++ b/tests/examples/EqualityConstraints3.hs.prettyparser.golden @@ -0,0 +1 @@ +Match diff --git a/tests/examples/EqualityConstraints3.hs.prettyprinter.golden b/tests/examples/EqualityConstraints3.hs.prettyprinter.golden new file mode 100644 index 00000000..45109047 --- /dev/null +++ b/tests/examples/EqualityConstraints3.hs.prettyprinter.golden @@ -0,0 +1,4 @@ +{-# LANGUAGE GADTs, FlexibleContexts #-} + +one :: (~) a Int => a +one = 1