Skip to content

Commit 2970107

Browse files
pjonssonpjonsson
committed
Improve exact printing of (->).
The actual work consists of putting the right annotations in the AST so we can distinguish '(' thing ')' from just thing.
1 parent 52871ea commit 2970107

14 files changed

+42
-25
lines changed

‎src/Language/Haskell/Exts/Annotated/ExactPrint.hs

Lines changed: 13 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -231,7 +231,9 @@ instance ExactP SpecialCon where
231231
exactP sc = case sc of
232232
UnitCon l -> printPoints l ["(",")"]
233233
ListCon l -> printPoints l ["[","]"]
234-
FunCon l -> printPoints l ["(","->",")"]
234+
FunCon l -> case srcInfoPoints l of
235+
[_,b,_] -> printStringAt (pos b) "->"
236+
_ -> errorEP "ExactP: SpecialCon is given wrong number of srcInfoPoints"
235237
TupleCon l b n -> printPoints l $
236238
case b of
237239
Unboxed -> "(#": replicate (n-1) "," ++ ["#)"]
@@ -301,6 +303,7 @@ instance ExactP Name where
301303
printWhitespace (pos b)
302304
printString str
303305
printStringAt (pos c) ")"
306+
[] -> printString str
304307
_ -> errorEP "ExactP: Name is given wrong number of srcInfoPoints"
305308

306309
epName :: Name SrcSpanInfo -> EP ()
@@ -864,7 +867,14 @@ instance ExactP TyVarBind where
864867
exactPC k
865868
printStringAt (pos c) ")"
866869
_ -> errorEP "ExactP: TyVarBind: KindedVar is given wrong number of srcInfoPoints"
867-
exactP (UnkindedVar _ n) = exactP n
870+
exactP (UnkindedVar l n) =
871+
case srcInfoPoints l of
872+
[a,_,c] -> do
873+
printStringAt (pos a) "("
874+
exactPC n
875+
printStringAt (pos c) ")"
876+
[] -> exactPC n
877+
_ -> errorEP "ExactP: TyVarBind: UnkindedVar is given wrong number of srcInfoPoints"
868878

869879
instance ExactP Kind where
870880
exactP kd' = case kd' of
@@ -1656,7 +1666,7 @@ instance ExactP GuardedAlt where
16561666

16571667
instance ExactP Pat where
16581668
exactP pat = case pat of
1659-
PVar _ n -> exactP n
1669+
PVar l n -> exactPC (fmap (const l) n)
16601670
PLit _ lit -> exactP lit
16611671
PNeg _ p -> printString "-" >> exactPC p
16621672
PNPlusK l n k ->

‎src/Language/Haskell/Exts/InternalParser.ly

Lines changed: 7 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -871,8 +871,8 @@ type...
871871

872872
> otycon :: { QName L }
873873
> : qconid { $1 }
874-
> | '(' gconsym ')' { fmap (const ($1 <^^> $3 <** [$1, srcInfoSpan (ann $2), $3])) $2 }
875-
> | '(' qvarsym ')' { fmap (const ($1 <^^> $3 <** [$1, srcInfoSpan (ann $2), $3])) $2 }
874+
> | '(' gconsym ')' { updateQNameLoc ($1 <^^> $3 <** [$1, srcInfoSpan (ann $2), $3]) $2 }
875+
> | '(' qvarsym ')' { updateQNameLoc ($1 <^^> $3 <** [$1, srcInfoSpan (ann $2), $3]) $2 }
876876

877877
These are for infix types
878878

@@ -1680,7 +1680,7 @@ Variables, Constructors and Operators.
16801680

16811681
> qvar :: { QName L }
16821682
> : qvarid { $1 }
1683-
> | '(' qvarsym ')' { fmap (const ($1 <^^> $3 <** [$1, srcInfoSpan (ann $2), $3])) $2 }
1683+
> | '(' qvarsym ')' { updateQNameLoc ($1 <^^> $3 <** [$1, srcInfoSpan (ann $2), $3]) $2 }
16841684

16851685
Implicit parameter
16861686
> ivar :: { IPName L }
@@ -1692,27 +1692,27 @@ Implicit parameter
16921692

16931693
> qcon :: { QName L }
16941694
> : qconid { $1 }
1695-
> | '(' gconsym ')' { fmap (const ($1 <^^> $3 <** [$1, srcInfoSpan (ann $2), $3])) $2 }
1695+
> | '(' gconsym ')' { updateQNameLoc ($1 <^^> $3 <** [$1, srcInfoSpan (ann $2), $3]) $2 }
16961696

16971697
> varop :: { Name L }
16981698
> : varsym { $1 }
16991699
> | '`' varid '`' { fmap (const ($1 <^^> $3 <** [$1, srcInfoSpan (ann $2), $3])) $2 }
17001700

17011701
> qvarop :: { QName L }
17021702
> : qvarsym { $1 }
1703-
> | '`' qvarid '`' { fmap (const ($1 <^^> $3 <** [$1, srcInfoSpan (ann $2), $3])) $2 }
1703+
> | '`' qvarid '`' { updateQNameLoc ($1 <^^> $3 <** [$1, srcInfoSpan (ann $2), $3]) $2 }
17041704

17051705
> qvaropm :: { QName L }
17061706
> : qvarsymm { $1 }
1707-
> | '`' qvarid '`' { fmap (const ($1 <^^> $3 <** [$1, srcInfoSpan (ann $2), $3])) $2 }
1707+
> | '`' qvarid '`' { updateQNameLoc ($1 <^^> $3 <** [$1, srcInfoSpan (ann $2), $3]) $2 }
17081708

17091709
> conop :: { Name L }
17101710
> : consym { $1 }
17111711
> | '`' conid '`' { fmap (const ($1 <^^> $3 <** [$1, srcInfoSpan (ann $2), $3])) $2 }
17121712

17131713
> qconop :: { QName L }
17141714
> : gconsym { $1 }
1715-
> | '`' qconid '`' { fmap (const ($1 <^^> $3 <** [$1, srcInfoSpan (ann $2), $3])) $2 }
1715+
> | '`' qconid '`' { updateQNameLoc ($1 <^^> $3 <** [$1, srcInfoSpan (ann $2), $3]) $2 }
17161716

17171717
> op :: { Op L }
17181718
> : varop { VarOp (ann $1) $1 }

‎src/Language/Haskell/Exts/ParseUtils.hs

Lines changed: 11 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -57,6 +57,8 @@ module Language.Haskell.Exts.ParseUtils (
5757
-- Pragmas
5858
, checkRuleExpr -- PExp -> P Exp
5959
, readTool -- Maybe String -> Maybe Tool
60+
-- Helpers
61+
, updateQNameLoc -- l -> QName l -> QName l
6062

6163
-- Parsed expressions and types
6264
, PExp(..), PFieldUpdate(..), ParseXAttr(..), PType(..), PContext, PAsst(..)
@@ -288,7 +290,7 @@ checkSimple kw (TyInfix l t1 (UnQual _ t) t2) [] = do
288290
tv1 <- mkTyVarBind kw t1
289291
tv2 <- mkTyVarBind kw t2
290292
return (DHInfix l tv1 t tv2)
291-
checkSimple _kw (TyCon l (UnQual _ t)) xs = do
293+
checkSimple _kw (TyCon _ (UnQual l t)) xs = do
292294
case t of
293295
Symbol _ _ -> checkEnabled TypeOperators
294296
_ -> return ()
@@ -366,7 +368,7 @@ checkPat (InfixApp _ l op r) args
366368
ps <- mapM checkPattern (BangPat (ann op) e:es)
367369
checkPat l (ps++args)
368370
checkPat e' [] = case e' of
369-
Var l (UnQual _ x) -> return (PVar l x)
371+
Var _ (UnQual l x) -> return (PVar l x)
370372
Lit l lit -> return (PLit l lit)
371373
InfixApp loc l op r ->
372374
case op of
@@ -780,7 +782,7 @@ isFunLhs _ _ = return Nothing
780782
-- a post-processing step
781783

782784
checkSigVar :: PExp L -> P (Name L)
783-
checkSigVar (Var _ (UnQual _ n)) = return n
785+
checkSigVar (Var _ (UnQual l n)) = return $ fmap (const l) n
784786
checkSigVar e = fail $ "Left-hand side of type signature is not a variable: " ++ prettyPrint e
785787

786788
-----------------------------------------------------------------------------
@@ -812,7 +814,7 @@ checkMethodDef _ = return ()
812814

813815
checkUnQual :: QName L -> P (Name L)
814816
checkUnQual (Qual _ _ _) = fail "Illegal qualified name"
815-
checkUnQual (UnQual _ n) = return n
817+
checkUnQual (UnQual l n) = return $ fmap (const l) n
816818
checkUnQual (Special _ _) = fail "Illegal special name"
817819

818820
checkQualOrUnQual :: QName L -> P (QName L)
@@ -846,6 +848,11 @@ mkRecConstrOrUpdate (Con l c) fs = return (RecConstr l c fs)
846848
mkRecConstrOrUpdate e fs@(_:_) = return (RecUpdate (ann e) e fs)
847849
mkRecConstrOrUpdate _ _ = fail "Empty record update"
848850

851+
updateQNameLoc :: l -> QName l -> QName l
852+
updateQNameLoc l (Qual _ mn n) = Qual l mn n
853+
updateQNameLoc l (UnQual _ n) = UnQual l n
854+
updateQNameLoc l (Special _ s) = Special l s
855+
849856
-----------------------------------------------------------------------------
850857
-- Reverse a list of declarations, merging adjacent FunBinds of the
851858
-- same name and checking that their arities match.

‎tests/examples/Attributes.hs.parser.golden

Lines changed: 1 addition & 1 deletion
Large diffs are not rendered by default.

‎tests/examples/ByteStringUtils.hs.parser.golden

Lines changed: 1 addition & 1 deletion
Large diffs are not rendered by default.

‎tests/examples/CParser.hs.parser.golden

Lines changed: 1 addition & 1 deletion
Large diffs are not rendered by default.

‎tests/examples/Directory.hs.parser.golden

Lines changed: 1 addition & 1 deletion
Large diffs are not rendered by default.

‎tests/examples/QualifiedDot.hs.parser.golden

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1 +1 @@
1-
ParseOk (Module (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 1 1 4 1, srcInfoPoints = [SrcSpan "tests/examples/QualifiedDot.hs" 1 1 1 1,SrcSpan "tests/examples/QualifiedDot.hs" 1 1 1 1,SrcSpan "tests/examples/QualifiedDot.hs" 3 1 3 1,SrcSpan "tests/examples/QualifiedDot.hs" 4 1 4 1,SrcSpan "tests/examples/QualifiedDot.hs" 4 1 4 1]}) (Just (ModuleHead (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 1 1 1 26, srcInfoPoints = [SrcSpan "tests/examples/QualifiedDot.hs" 1 1 1 7,SrcSpan "tests/examples/QualifiedDot.hs" 1 21 1 26]}) (ModuleName (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 1 8 1 20, srcInfoPoints = []}) "QualifiedDot") Nothing Nothing)) [] [] [PatBind (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 3 1 3 22, srcInfoPoints = []}) (PVar (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 3 1 3 8, srcInfoPoints = []}) (Ident (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 3 1 3 8, srcInfoPoints = []}) "twoDots")) (UnGuardedRhs (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 3 9 3 22, srcInfoPoints = [SrcSpan "tests/examples/QualifiedDot.hs" 3 9 3 10]}) (Var (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 3 11 3 22, srcInfoPoints = [SrcSpan "tests/examples/QualifiedDot.hs" 3 11 3 12,SrcSpan "tests/examples/QualifiedDot.hs" 3 12 3 21,SrcSpan "tests/examples/QualifiedDot.hs" 3 21 3 22]}) (Qual (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 3 11 3 22, srcInfoPoints = [SrcSpan "tests/examples/QualifiedDot.hs" 3 11 3 12,SrcSpan "tests/examples/QualifiedDot.hs" 3 12 3 21,SrcSpan "tests/examples/QualifiedDot.hs" 3 21 3 22]}) (ModuleName (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 3 11 3 22, srcInfoPoints = [SrcSpan "tests/examples/QualifiedDot.hs" 3 11 3 12,SrcSpan "tests/examples/QualifiedDot.hs" 3 12 3 21,SrcSpan "tests/examples/QualifiedDot.hs" 3 21 3 22]}) "Prelude") (Symbol (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 3 11 3 22, srcInfoPoints = [SrcSpan "tests/examples/QualifiedDot.hs" 3 11 3 12,SrcSpan "tests/examples/QualifiedDot.hs" 3 12 3 21,SrcSpan "tests/examples/QualifiedDot.hs" 3 21 3 22]}) ".")))) Nothing],[])
1+
ParseOk (Module (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 1 1 4 1, srcInfoPoints = [SrcSpan "tests/examples/QualifiedDot.hs" 1 1 1 1,SrcSpan "tests/examples/QualifiedDot.hs" 1 1 1 1,SrcSpan "tests/examples/QualifiedDot.hs" 3 1 3 1,SrcSpan "tests/examples/QualifiedDot.hs" 4 1 4 1,SrcSpan "tests/examples/QualifiedDot.hs" 4 1 4 1]}) (Just (ModuleHead (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 1 1 1 26, srcInfoPoints = [SrcSpan "tests/examples/QualifiedDot.hs" 1 1 1 7,SrcSpan "tests/examples/QualifiedDot.hs" 1 21 1 26]}) (ModuleName (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 1 8 1 20, srcInfoPoints = []}) "QualifiedDot") Nothing Nothing)) [] [] [PatBind (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 3 1 3 22, srcInfoPoints = []}) (PVar (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 3 1 3 8, srcInfoPoints = []}) (Ident (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 3 1 3 8, srcInfoPoints = []}) "twoDots")) (UnGuardedRhs (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 3 9 3 22, srcInfoPoints = [SrcSpan "tests/examples/QualifiedDot.hs" 3 9 3 10]}) (Var (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 3 11 3 22, srcInfoPoints = [SrcSpan "tests/examples/QualifiedDot.hs" 3 11 3 12,SrcSpan "tests/examples/QualifiedDot.hs" 3 12 3 21,SrcSpan "tests/examples/QualifiedDot.hs" 3 21 3 22]}) (Qual (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 3 11 3 22, srcInfoPoints = [SrcSpan "tests/examples/QualifiedDot.hs" 3 11 3 12,SrcSpan "tests/examples/QualifiedDot.hs" 3 12 3 21,SrcSpan "tests/examples/QualifiedDot.hs" 3 21 3 22]}) (ModuleName (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 3 12 3 21, srcInfoPoints = []}) "Prelude") (Symbol (SrcSpanInfo {srcInfoSpan = SrcSpan "tests/examples/QualifiedDot.hs" 3 12 3 21, srcInfoPoints = []}) ".")))) Nothing],[])

‎tests/examples/RealGHC.lhs.parser.golden

Lines changed: 1 addition & 1 deletion
Large diffs are not rendered by default.

0 commit comments

Comments
 (0)