summaryrefslogtreecommitdiff
path: root/compiler/parser
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/parser')
-rw-r--r--compiler/parser/ApiAnnotation.hs4
-rw-r--r--compiler/parser/Lexer.x10
-rw-r--r--compiler/parser/Parser.y222
-rw-r--r--compiler/parser/RdrHsSyn.hs52
4 files changed, 141 insertions, 147 deletions
diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs
index f73479695a..b5214c17b3 100644
--- a/compiler/parser/ApiAnnotation.hs
+++ b/compiler/parser/ApiAnnotation.hs
@@ -253,8 +253,6 @@ data AnnKeywordId
| AnnRec
| AnnRole
| AnnSafe
- | AnnStar -- ^ '*'
- | AnnStarU -- ^ '*', unicode variant.
| AnnSemi -- ^ ';'
| AnnSimpleQuote -- ^ '''
| AnnStatic -- ^ 'static'
@@ -330,9 +328,7 @@ unicodeAnn Annlarrowtail = AnnLarrowtailU
unicodeAnn Annrarrowtail = AnnrarrowtailU
unicodeAnn AnnLarrowtail = AnnLarrowtailU
unicodeAnn AnnRarrowtail = AnnRarrowtailU
-unicodeAnn AnnStar = AnnStarU
unicodeAnn ann = ann
--- What about '*'?
-- | Some template haskell tokens have two variants, one with an `e` the other
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index db96acbcbc..3f6fa8c6e0 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -605,7 +605,6 @@ data Token
| ITdarrow IsUnicodeSyntax
| ITminus
| ITbang
- | ITstar IsUnicodeSyntax
| ITdot
| ITbiglam -- GHC-extension symbols
@@ -807,9 +806,6 @@ reservedSymsFM = listToUFM $
,("-", ITminus, always)
,("!", ITbang, always)
- -- For data T (a::*) = MkT
- ,("*", ITstar NormalSyntax, always)
- -- \i -> kindSigsEnabled i || tyFamEnabled i)
-- For 'forall a . t'
,(".", ITdot, always) -- \i -> explicitForallEnabled i || inRulePrag i)
@@ -833,8 +829,6 @@ reservedSymsFM = listToUFM $
,("⤜", ITRarrowtail UnicodeSyntax,
\i -> unicodeSyntaxEnabled i && arrowsEnabled i)
- ,("★", ITstar UnicodeSyntax, unicodeSyntaxEnabled)
-
-- ToDo: ideally, → and ∷ should be "specials", so that they cannot
-- form part of a large operator. This would let us have a better
-- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
@@ -2007,7 +2001,6 @@ data ExtBits
| PatternSynonymsBit -- pattern synonyms
| HaddockBit-- Lex and parse Haddock comments
| MagicHashBit -- "#" in both functions and operators
- | KindSigsBit -- Kind signatures on type variables
| RecursiveDoBit -- mdo
| UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc
| UnboxedTuplesBit -- (# and #)
@@ -2052,8 +2045,6 @@ haddockEnabled :: ExtsBitmap -> Bool
haddockEnabled = xtest HaddockBit
magicHashEnabled :: ExtsBitmap -> Bool
magicHashEnabled = xtest MagicHashBit
--- kindSigsEnabled :: ExtsBitmap -> Bool
--- kindSigsEnabled = xtest KindSigsBit
unicodeSyntaxEnabled :: ExtsBitmap -> Bool
unicodeSyntaxEnabled = xtest UnicodeSyntaxBit
unboxedTuplesEnabled :: ExtsBitmap -> Bool
@@ -2140,7 +2131,6 @@ mkPState flags buf loc =
.|. BangPatBit `setBitIf` xopt Opt_BangPatterns flags
.|. HaddockBit `setBitIf` gopt Opt_Haddock flags
.|. MagicHashBit `setBitIf` xopt Opt_MagicHash flags
- .|. KindSigsBit `setBitIf` xopt Opt_KindSignatures flags
.|. RecursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags
.|. UnicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags
.|. UnboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index bbde989293..06be056575 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -59,7 +59,7 @@ import BasicTypes
-- compiler/types
import Type ( funTyCon )
-import Kind ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind )
+import Kind ( Kind )
import Class ( FunDep )
-- compiler/parser
@@ -73,10 +73,11 @@ import TcEvidence ( emptyTcEvBinds )
-- compiler/prelude
import ForeignCall
-import TysPrim ( liftedTypeKindTyConName, eqPrimTyCon )
+import TysPrim ( eqPrimTyCon )
+import PrelNames ( eqTyCon_RDR )
import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon,
unboxedUnitTyCon, unboxedUnitDataCon,
- listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
+ listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR )
-- compiler/utils
import Util ( looksLikePackageName )
@@ -84,9 +85,9 @@ import Prelude
}
-{- Last updated: 31 Jul 2015
+{- Last updated: 18 Nov 2015
-Conflicts: 47 shift/reduce
+Conflicts: 36 shift/reduce
If you modify this parser and add a conflict, please update this comment.
You can learn more about the conflicts by passing 'happy' the -i flag:
@@ -127,35 +128,26 @@ state 46 contains 2 shift/reduce conflicts.
-------------------------------------------------------------------------------
-state 50 contains 11 shift/reduce conflicts.
+state 50 contains 1 shift/reduce conflict.
- context -> btype . (rule 282)
- *** type -> btype . (rule 283)
- type -> btype . qtyconop type (rule 284)
- type -> btype . tyvarop type (rule 285)
- type -> btype . '->' ctype (rule 286)
- type -> btype . SIMPLEQUOTE qconop type (rule 287)
- type -> btype . SIMPLEQUOTE varop type (rule 288)
- btype -> btype . atype (rule 299)
+ context -> btype . (rule 295)
+ *** type -> btype . (rule 297)
+ type -> btype . '->' ctype (rule 298)
- Conflicts: ':' '->' '-' '!' '*' '.' '`' VARSYM CONSYM QVARSYM QCONSYM
+ Conflicts: '->'
-Example of ambiguity: 'e :: a `b` c'; does this mean
- (e::a) `b` c, or
- (e :: (a `b` c))
+-------------------------------------------------------------------------------
+
+state 51 contains 9 shift/reduce conflicts.
+
+ *** btype -> tyapps . (rule 303)
+ tyapps -> tyapps . tyapp (rule 307)
-The case for '->' involves view patterns rather than type operators:
- 'case v of { x :: T -> T ... } '
- Which of these two is intended?
- case v of
- (x::T) -> T -- Rhs is T
- or
- case v of
- (x::T -> T) -> .. -- Rhs is ...
+ Conflicts: ':' '-' '!' '.' '`' VARSYM CONSYM QVARSYM QCONSYM
-------------------------------------------------------------------------------
-state 119 contains 15 shift/reduce conflicts.
+state 132 contains 14 shift/reduce conflicts.
exp -> infixexp . '::' sigtype (rule 416)
exp -> infixexp . '-<' exp (rule 417)
@@ -165,7 +157,7 @@ state 119 contains 15 shift/reduce conflicts.
*** exp -> infixexp . (rule 421)
infixexp -> infixexp . qop exp10 (rule 423)
- Conflicts: ':' '::' '-' '!' '*' '-<' '>-' '-<<' '>>-'
+ Conflicts: ':' '::' '-' '!' '-<' '>-' '-<<' '>>-'
'.' '`' VARSYM CONSYM QVARSYM QCONSYM
Examples of ambiguity:
@@ -180,7 +172,7 @@ Shift parses as (per longest-parse rule):
-------------------------------------------------------------------------------
-state 279 contains 1 shift/reduce conflicts.
+state 292 contains 1 shift/reduce conflicts.
rule -> STRING . rule_activation rule_forall infixexp '=' exp (rule 215)
@@ -198,23 +190,18 @@ a rule instructing how to rewrite the expression '[0] f'.
-------------------------------------------------------------------------------
-state 288 contains 11 shift/reduce conflicts.
+state 301 contains 1 shift/reduce conflict.
- *** type -> btype . (rule 283)
- type -> btype . qtyconop type (rule 284)
- type -> btype . tyvarop type (rule 285)
- type -> btype . '->' ctype (rule 286)
- type -> btype . SIMPLEQUOTE qconop type (rule 287)
- type -> btype . SIMPLEQUOTE varop type (rule 288)
- btype -> btype . atype (rule 299)
+ *** type -> btype . (rule 297)
+ type -> btype . '->' ctype (rule 298)
- Conflicts: ':' '->' '-' '!' '*' '.' '`' VARSYM CONSYM QVARSYM QCONSYM
+ Conflict: '->'
-Same as State 50, but minus the context productions.
+Same as state 50 but without contexts.
-------------------------------------------------------------------------------
-state 324 contains 1 shift/reduce conflicts.
+state 337 contains 1 shift/reduce conflicts.
tup_exprs -> commas . tup_tail (rule 505)
sysdcon_nolist -> '(' commas . ')' (rule 616)
@@ -229,7 +216,7 @@ if -XTupleSections is not specified.
-------------------------------------------------------------------------------
-state 376 contains 1 shift/reduce conflicts.
+state 388 contains 1 shift/reduce conflicts.
tup_exprs -> commas . tup_tail (rule 505)
sysdcon_nolist -> '(#' commas . '#)' (rule 618)
@@ -241,20 +228,18 @@ Same as State 324 for unboxed tuples.
-------------------------------------------------------------------------------
-state 404 contains 1 shift/reduce conflicts.
+state 460 contains 1 shift/reduce conflict.
- exp10 -> 'let' binds . 'in' exp (rule 425)
- exp10 -> 'let' binds . 'in' error (rule 440)
- exp10 -> 'let' binds . error (rule 441)
- *** qual -> 'let' binds . (rule 579)
+ oqtycon -> '(' qtyconsym . ')' (rule 621)
+ *** qtyconop -> qtyconsym . (rule 628)
- Conflict: error
+ Conflict: ')'
TODO: Why?
-------------------------------------------------------------------------------
-state 633 contains 1 shift/reduce conflicts.
+state 635 contains 1 shift/reduce conflicts.
*** aexp2 -> ipvar . (rule 466)
dbind -> ipvar . '=' exp (rule 590)
@@ -269,7 +254,7 @@ sensible meaning, namely the lhs of an implicit binding.
-------------------------------------------------------------------------------
-state 699 contains 1 shift/reduce conflicts.
+state 702 contains 1 shift/reduce conflicts.
rule -> STRING rule_activation . rule_forall infixexp '=' exp (rule 215)
@@ -286,7 +271,7 @@ doesn't include 'forall'.
-------------------------------------------------------------------------------
-state 950 contains 1 shift/reduce conflicts.
+state 930 contains 1 shift/reduce conflicts.
transformqual -> 'then' 'group' . 'using' exp (rule 528)
transformqual -> 'then' 'group' . 'by' exp 'using' exp (rule 529)
@@ -294,6 +279,16 @@ state 950 contains 1 shift/reduce conflicts.
Conflict: 'by'
+-------------------------------------------------------------------------------
+
+state 1270 contains 1 shift/reduce conflict.
+
+ *** atype -> tyvar . (rule 314)
+ tv_bndr -> '(' tyvar . '::' kind ')' (rule 346)
+
+ Conflict: '::'
+
+TODO: Why?
-------------------------------------------------------------------------------
-- API Annotations
@@ -413,7 +408,6 @@ output it generates.
'=>' { L _ (ITdarrow _) }
'-' { L _ ITminus }
'!' { L _ ITbang }
- '*' { L _ (ITstar _) }
'-<' { L _ (ITlarrowtail _) } -- for arrow notation
'>-' { L _ (ITrarrowtail _) } -- for arrow notation
'-<<' { L _ (ITLarrowtail _) } -- for arrow notation
@@ -1606,12 +1600,22 @@ ctypedoc :: { LHsType RdrName }
-- but not f :: ?x::Int => blah
-- See Note [Parsing ~]
context :: { LHsContext RdrName }
- : btype {% do { (anns,ctx) <- checkContext (splitTilde $1)
+ : btype {% do { (anns,ctx) <- checkContext $1
; if null (unLoc ctx)
then addAnnotation (gl $1) AnnUnit (gl $1)
else return ()
; ams ctx anns
} }
+
+context_no_ops :: { LHsContext RdrName }
+ : btype_no_ops {% do { let { ty = splitTilde $1 }
+ ; (anns,ctx) <- checkContext ty
+ ; if null (unLoc ctx)
+ then addAnnotation (gl ty) AnnUnit (gl ty)
+ else return ()
+ ; ams ctx anns
+ } }
+
{- Note [GADT decl discards annotations]
~~~~~~~~~~~~~~~~~~~~~
The type production for
@@ -1628,40 +1632,49 @@ the top-level annotation will be disconnected. Hence for this specific case it
is connected to the first type too.
-}
--- See Note [Parsing ~]
type :: { LHsType RdrName }
- : btype { splitTilde $1 }
- | btype qtyconop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
- | btype tyvarop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
- | btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations]
- >> ams (sLL $1 $> $ HsFunTy (splitTilde $1) $3)
- [mu AnnRarrow $2] }
- | btype SIMPLEQUOTE qconop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
- [mj AnnSimpleQuote $2] }
- | btype SIMPLEQUOTE varop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
- [mj AnnSimpleQuote $2] }
--- See Note [Parsing ~]
+ : btype { $1 }
+ | btype '->' ctype {% ams $1 [mu AnnRarrow $2] -- See note [GADT decl discards annotations]
+ >> ams (sLL $1 $> $ HsFunTy $1 $3)
+ [mu AnnRarrow $2] }
+
+
typedoc :: { LHsType RdrName }
- : btype { splitTilde $1 }
- | btype docprev { sLL $1 $> $ HsDocTy (splitTilde $1) $2 }
- | btype qtyconop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
- | btype qtyconop type docprev { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
- | btype tyvarop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
- | btype tyvarop type docprev { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 }
- | btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy (splitTilde $1) $3)
+ : btype { $1 }
+ | btype docprev { sLL $1 $> $ HsDocTy $1 $2 }
+ | btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy $1 $3)
[mu AnnRarrow $2] }
- | btype docprev '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy (L (comb2 (splitTilde $1) $2)
- (HsDocTy $1 $2)) $4)
+ | btype docprev '->' ctypedoc {% ams (sLL $1 $> $
+ HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2))
+ $4)
[mu AnnRarrow $3] }
- | btype SIMPLEQUOTE qconop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
- [mj AnnSimpleQuote $2] }
- | btype SIMPLEQUOTE varop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
- [mj AnnSimpleQuote $2] }
+-- See Note [Parsing ~]
btype :: { LHsType RdrName }
- : btype atype { sLL $1 $> $ HsAppTy $1 $2 }
+ : tyapps { sL1 $1 $ HsAppsTy (splitTildeApps (reverse (unLoc $1))) }
+
+-- Used for parsing Haskell98-style data constructors,
+-- in order to forbid the blasphemous
+-- > data Foo = Int :+ Char :* Bool
+-- See also Note [Parsing data constructors is hard].
+btype_no_ops :: { LHsType RdrName }
+ : btype_no_ops atype { sLL $1 $> $ HsAppTy $1 $2 }
| atype { $1 }
+tyapps :: { Located [HsAppType RdrName] } -- NB: This list is reversed
+ : tyapp { sL1 $1 [unLoc $1] }
+ | tyapps tyapp { sLL $1 $> $ (unLoc $2) : (unLoc $1) }
+
+-- See Note [HsAppsTy] in HsTypes
+tyapp :: { Located (HsAppType RdrName) }
+ : atype { sL1 $1 $ HsAppPrefix $1 }
+ | qtyconop { sL1 $1 $ HsAppInfix $1 }
+ | tyvarop { sL1 $1 $ HsAppInfix $1 }
+ | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ HsAppInfix $2)
+ [mj AnnSimpleQuote $1] }
+ | SIMPLEQUOTE varop {% ams (sLL $1 $> $ HsAppInfix $2)
+ [mj AnnSimpleQuote $1] }
+
atype :: { LHsType RdrName }
: ntgtycon { sL1 $1 (HsTyVar $1) } -- Not including unit tuples
| tyvar {% do { nwc <- namedWildCardsEnabled -- (See Note [Unit tuples])
@@ -1797,37 +1810,7 @@ turn them into HsEqTy's.
-- Kinds
kind :: { LHsKind RdrName }
- : bkind { $1 }
- | bkind '->' kind {% ams (sLL $1 $> $ HsFunTy $1 $3)
- [mu AnnRarrow $2] }
-
-bkind :: { LHsKind RdrName }
- : akind { $1 }
- | bkind akind { sLL $1 $> $ HsAppTy $1 $2 }
-
-akind :: { LHsKind RdrName }
- : '*' {% ams (sL1 $1 $ HsTyVar (sL1 $1 (nameRdrName liftedTypeKindTyConName)))
- [mu AnnStar $1] }
- | '(' kind ')' {% ams (sLL $1 $> $ HsParTy $2)
- [mop $1,mcp $3] }
- | pkind { $1 }
- | tyvar { sL1 $1 $ HsTyVar $1 }
-
-pkind :: { LHsKind RdrName } -- promoted type, see Note [Promotion]
- : qtycon { sL1 $1 $ HsTyVar $1 }
- | '(' ')' {% ams (sLL $1 $> $ HsTyVar $ (sLL $1 $> $ getRdrName unitTyCon))
- [mop $1,mcp $2] }
- | '(' kind ',' comma_kinds1 ')'
- {% addAnnotation (gl $2) AnnComma (gl $3) >>
- ams (sLL $1 $> $ HsTupleTy HsBoxedTuple ( $2 : $4))
- [mop $1,mcp $5] }
- | '[' kind ']' {% ams (sLL $1 $> $ HsListTy $2)
- [mos $1,mcs $3] }
-
-comma_kinds1 :: { [LHsKind RdrName] }
- : kind { [$1] }
- | kind ',' comma_kinds1 {% addAnnotation (gl $1) AnnComma (gl $2)
- >> return ($1 : $3) }
+ : ctype { $1 }
{- Note [Promotion]
~~~~~~~~~~~~~~~~
@@ -1840,12 +1823,6 @@ few reasons:
2. if one day we merge types and kinds, tick would mean look in DataName
3. we don't have a kind namespace anyway
-- Syntax of explicit kind polymorphism (IA0_TODO: not yet implemented)
-Kind abstraction is implicit. We write
-> data SList (s :: k -> *) (as :: [k]) where ...
-because it looks like what we do in terms
-> id (x :: a) = x
-
- Name resolution
When the user write Zero instead of 'Zero in types, we parse it a
HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We
@@ -1922,7 +1899,7 @@ constrs1 :: { Located [LConDecl RdrName] }
| constr { sL1 $1 [$1] }
constr :: { LConDecl RdrName }
- : maybe_docnext forall context '=>' constr_stuff maybe_docprev
+ : maybe_docnext forall context_no_ops '=>' constr_stuff maybe_docprev
{% ams (let (con,details) = unLoc $5 in
addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con
(snd $ unLoc $2) $3 details))
@@ -1941,16 +1918,17 @@ forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr RdrName]) }
constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) }
-- see Note [Parsing data constructors is hard]
- : btype {% splitCon $1 >>= return.sLL $1 $> }
- | btype conop btype { sLL $1 $> ($2, InfixCon $1 $3) }
+ : btype_no_ops {% do { c <- splitCon $1
+ ; return $ sLL $1 $> c } }
+ | btype_no_ops conop btype_no_ops { sLL $1 $> ($2, InfixCon (splitTilde $1) $3) }
{- Note [Parsing data constructors is hard]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We parse the constructor declaration
C t1 t2
-as a btype (treating C as a type constructor) and then convert C to be
+as a btype_no_ops (treating C as a type constructor) and then convert C to be
a data constructor. Reason: it might continue like this:
- C t1 t2 %: D Int
+ C t1 t2 :% D Int
in which case C really would be a type constructor. We can't resolve this
ambiguity till we come across the constructor oprerator :% (or not, more usually)
-}
@@ -2931,8 +2909,6 @@ tyconsym :: { Located RdrName }
: CONSYM { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) }
| VARSYM { sL1 $1 $! mkUnqual tcClsName (getVARSYM $1) }
| ':' { sL1 $1 $! consDataCon_RDR }
- | '*' {% ams (sL1 $1 $! mkUnqual tcClsName (fsLit "*"))
- [mu AnnStar $1] }
| '-' { sL1 $1 $! mkUnqual tcClsName (fsLit "-") }
@@ -3070,7 +3046,6 @@ special_id
special_sym :: { Located FastString }
special_sym : '!' {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] }
| '.' { sL1 $1 (fsLit ".") }
- | '*' {% ams (sL1 $1 (fsLit "*")) [mu AnnStar $1] }
-----------------------------------------------------------------------------
-- Data constructors
@@ -3240,7 +3215,6 @@ isUnicode (L _ (ITdcolon iu)) = iu == UnicodeSyntax
isUnicode (L _ (ITlarrow iu)) = iu == UnicodeSyntax
isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax
isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax
-isUnicode (L _ (ITstar iu)) = iu == UnicodeSyntax
isUnicode (L _ (ITlarrowtail iu)) = iu == UnicodeSyntax
isUnicode (L _ (ITrarrowtail iu)) = iu == UnicodeSyntax
isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 53e6184491..e8687acb6c 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -52,7 +52,7 @@ module RdrHsSyn (
checkDoAndIfThenElse,
checkRecordSyntax,
parseErrorSDoc,
- splitTilde,
+ splitTilde, splitTildeApps,
-- Help with processing exports
ImpExpSubSpec(..),
@@ -77,9 +77,10 @@ import Lexer
import Type ( TyThing(..) )
import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon,
nilDataConName, nilDataConKey,
- listTyConName, listTyConKey )
+ listTyConName, listTyConKey,
+ starKindTyConName, unicodeStarKindTyConName )
import ForeignCall
-import PrelNames ( forall_tv_RDR, allNameStrings )
+import PrelNames ( forall_tv_RDR, eqTyCon_RDR, allNameStrings )
import DynFlags
import SrcLoc
import Unique ( hasKey )
@@ -443,9 +444,10 @@ splitCon :: LHsType RdrName
splitCon ty
= split ty []
where
- split (L _ (HsAppTy t u)) ts = split t (u : ts)
- split (L l (HsTyVar (L _ tc))) ts = do data_con <- tyConToDataCon l tc
- return (data_con, mk_rest ts)
+ -- This is used somewhere where HsAppsTy is not used
+ split (L _ (HsAppTy t u)) ts = split t (u : ts)
+ split (L l (HsTyVar (L _ tc))) ts = do data_con <- tyConToDataCon l tc
+ return (data_con, mk_rest ts)
split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) []
= return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts)
split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty)
@@ -641,8 +643,11 @@ checkTyVars pp_what equals_or_where tc tparms
; return (mkHsQTvs tvs) }
where
+ chk (L _ (HsParTy ty)) = chk ty
+ chk (L _ (HsAppsTy [HsAppPrefix ty])) = chk ty
+
-- Check that the name space is correct!
- chk (L l (HsKindSig (L lv (HsTyVar (L _ tv))) k))
+ chk (L l (HsKindSig (L _ (HsAppsTy [HsAppPrefix (L lv (HsTyVar (L _ tv)))])) k))
| isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k))
chk (L l (HsTyVar (L ltv tv)))
| isRdrTyVar tv = return (L l (UserTyVar (L ltv tv)))
@@ -695,10 +700,18 @@ checkTyClHdr is_cls ty
go l (HsTyVar (L _ tc)) acc ann
| isRdrTc tc = return (L l tc, acc, ann)
- go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc ann
+ go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann
| isRdrTc tc = return (ltc, t1:t2:acc, ann)
go l (HsParTy ty) acc ann = goL ty acc (ann ++ mkParensApiAnn l)
go _ (HsAppTy t1 t2) acc ann = goL t1 (t2:acc) ann
+ go _ (HsAppsTy ts) acc ann
+ | Just (head, args) <- getAppsTyHead_maybe ts = goL head (args ++ acc) ann
+
+ go _ (HsAppsTy [HsAppInfix (L loc star)]) [] ann
+ | occNameFS (rdrNameOcc star) == fsLit "*"
+ = return (L loc (nameRdrName starKindTyConName), [], ann)
+ | occNameFS (rdrNameOcc star) == fsLit "★"
+ = return (L loc (nameRdrName unicodeStarKindTyConName), [], ann)
go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann
= return (L l (nameRdrName tup_name), ts, ann)
@@ -718,6 +731,10 @@ checkContext (L l orig_t)
check anns (L lp (HsTupleTy _ ts)) -- (Eq a, Ord b) shows up as a tuple type
= return (anns ++ mkParensApiAnn lp,L l ts) -- Ditto ()
+ -- don't let HsAppsTy get in the way
+ check anns (L _ (HsAppsTy [HsAppPrefix ty]))
+ = check anns ty
+
check anns (L lp1 (HsParTy ty))-- to be sure HsParTy doesn't get into the way
= check anns' ty
where anns' = if l == lp1 then anns
@@ -1028,7 +1045,7 @@ isFunLhs e = go e [] []
go _ _ _ = return Nothing
--- | Transform btype with strict_mark's into HsEqTy's
+-- | Transform btype_no_ops with strict_mark's into HsEqTy's
-- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d
splitTilde :: LHsType RdrName -> LHsType RdrName
splitTilde t = go t
@@ -1043,6 +1060,23 @@ splitTilde t = go t
go t = t
+-- | Transform tyapps with strict_marks into uses of twiddle
+-- [~a, ~b, c, ~d] ==> (~a) ~ b c ~ d
+splitTildeApps :: [HsAppType RdrName] -> [HsAppType RdrName]
+splitTildeApps [] = []
+splitTildeApps (t : rest) = t : concatMap go rest
+ where go (HsAppPrefix
+ (L loc (HsBangTy
+ (HsSrcBang Nothing NoSrcUnpack SrcLazy)
+ ty)))
+ = [HsAppInfix (L tilde_loc eqTyCon_RDR), HsAppPrefix ty]
+ where
+ tilde_loc = srcSpanFirstCharacter loc
+
+ go t = [t]
+
+
+
---------------------------------------------------------------------------
-- Check for monad comprehensions
--
View Lorry Controller Status