import GHC.Exts
import Data.Char
import Control.Monad ( mplus )
+
}
+
{-
-----------------------------------------------------------------------------
24 Februar 2006
'|' { L _ ITvbar }
'<-' { L _ ITlarrow }
'->' { L _ ITrarrow }
+ '~~>' { L _ ITkappa }
'@' { L _ ITat }
'~' { L _ ITtilde }
'=>' { L _ ITdarrow }
'|)' { L _ ITcparenbar }
'<[' { L _ ITopenBrak }
']>' { L _ ITcloseBrak }
+ '<{' { L _ ITopenBrak1 }
+ '}>' { L _ ITcloseBrak1 }
'~~' { L _ ITescape }
'~~$' { L _ ITescapeDollar }
'%%' { L _ ITdoublePercent }
| oqtycon '(' ')' { LL (IEThingWith (unLoc $1) []) }
| oqtycon '(' qcnames ')' { LL (IEThingWith (unLoc $1) (reverse $3)) }
| 'module' modid { LL (IEModuleContents (unLoc $2)) }
- | '<[' incdepth export decdepth ']>' { $3 }
+ | '<[' incdepth export decdepth ']>' { $3 }
+ | '<{' incdepth1 export decdepth '}>' { $3 }
qcnames :: { [RdrName] }
: qcnames ',' qcname_ext { unLoc $3 : $1 }
| qcname_ext { [unLoc $1] }
| btype qtyconop type { LL $ HsOpTy $1 $2 $3 }
| btype tyvarop type { LL $ HsOpTy $1 $2 $3 }
| btype '->' ctype { LL $ HsFunTy $1 $3 }
+ | btype '~~>' ctype { LL $ HsKappaTy $1 $3 }
| btype '~' btype { LL $ HsPredTy (HsEqualP $1 $3) }
typedoc :: { LHsType RdrName }
| '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) }
| '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 }
| '[' ctype ']' { LL $ HsListTy $2 }
- | '<[' ctype ']>' '@' tyvar { LL $ HsModalBoxType (unLoc $5) $2 }
+ | '<{' ctype '}>' '@' tyvar { LL $ HsModalBoxType (unLoc $5) $2 }
| '[:' ctype ':]' { LL $ HsPArrTy $2 }
| '(' ctype ')' { LL $ HsParTy $2 }
| '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) }
; quoterId = mkUnqual varName quoter }
in L1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
-incdepth :: { Located () } : {% do { incrBracketDepth ; return $ noLoc () } }
-decdepth :: { Located () } : {% do { decrBracketDepth ; return $ noLoc () } }
+incdepth :: { Located () } : {% do { incrBracketDepth ; return $ noLoc () } }
+incdepth1 :: { Located () } : {% do { incrBracketDepth1 ; return $ noLoc () } }
+decdepth :: { Located () } : {% do { decrBracketDepth ; return $ noLoc () } }
+pushdepth :: { Located () } : {% do { pushBracketDepth ; return $ noLoc () } }
+popdepth :: { Located () } : {% do { popBracketDepth ; return $ noLoc () } }
exp :: { LHsExpr RdrName }
| infixexp '-<<' exp { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True }
| infixexp '>>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False}
| infixexp { $1 }
- | '~~$' decdepth exp incdepth { sL (comb2 $3 $>) (HsHetMetEsc placeHolderType placeHolderType $3) }
+ | '~~$' pushdepth exp popdepth {% do { x <- mkHsHetMetEsc placeHolderType placeHolderType $3; return $ sL (comb2 $3 $>) x } }
infixexp :: { LHsExpr RdrName }
: exp10 { $1 }
exp10 :: { LHsExpr RdrName }
: '\\' apat apats opt_asig '->' exp
- { LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4
- (unguardedGRHSs $6)
- ]) }
+ {% do { x <- getParserBrakDepth
+ ; return
+ $ case x of
+ KappaFlavor:_ -> LL $ HsKappa (mkMatchGroup[LL $ Match ($2:$3) $4 (unguardedGRHSs $6) ])
+ _ -> LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4 (unguardedGRHSs $6) ])
+ } }
| 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 }
| 'if' exp optSemi 'then' exp optSemi 'else' exp
{% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
}
fexp :: { LHsExpr RdrName }
- : fexp aexp { LL $ HsApp $1 $2 }
+ : fexp aexp {% do { x <- getParserBrakDepth
+ ; return $ case x of
+ [] -> LL $ HsApp $1 $2
+ LambdaFlavor:_ -> LL $ HsApp $1 $2
+ KappaFlavor:_ -> LL $ HsKappaApp $1 $2
+ } }
| aexp { $1 }
aexp :: { LHsExpr RdrName }
| '(|' aexp2 cmdargs '|)' { LL $ HsArrForm $2 Nothing (reverse $3) }
-- code type notation extension
- | '<[' incdepth exp decdepth ']>' { sL (comb2 $3 $>) (HsHetMetBrak placeHolderType $3) }
- | '~~' decdepth aexp incdepth { sL (comb2 $3 $>) (HsHetMetEsc placeHolderType placeHolderType $3) }
- | '%%' decdepth aexp incdepth { sL (comb2 $3 $>) (HsHetMetCSP placeHolderType $3) }
+ | '<[' incdepth exp decdepth ']>' { sL (comb2 $3 $>) (HsHetMetBrak placeHolderType $3) }
+ | '<{' incdepth1 exp decdepth '}>' { sL (comb2 $3 $>) (HsHetMetBrak placeHolderType $3) }
+ | '~~' pushdepth aexp popdepth {% do { x <- mkHsHetMetEsc placeHolderType placeHolderType $3; return $ sL (comb2 $3 $>) x } }
+ | '%%' pushdepth aexp popdepth { sL (comb2 $3 $>) (HsHetMetCSP placeHolderType $3) }
cmdargs :: { [LHsCmdTop RdrName] }
: cmdargs acmd { $2 : $1 }
| PREFIXQVARSYM { L1 $! mkQual varName (getPREFIXQVARSYM $1) }
varid :: { Located RdrName }
- : VARID {% do { depth <- getParserBrakDepth ; return (L1 $! mkUnqual (varNameDepth depth) (getVARID $1)) } }
+ : VARID {% do { depth <- getParserBrakDepth ; return (L1 $! mkUnqual (varNameDepth $ length depth) (getVARID $1)) } }
| special_id { L1 $! mkUnqual varName (unLoc $1) }
| 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") }
| 'safe' { L1 $! mkUnqual varName (fsLit "safe") }
varsym_no_minus :: { Located RdrName } -- varsym not including '-'
: VARSYM {% do { depth <- getParserBrakDepth
- ; return (L1 $! mkUnqual (varNameDepth depth) (getVARSYM $1)) } }
+ ; return (L1 $! mkUnqual (varNameDepth $ length depth) (getVARSYM $1)) } }
| special_sym {% do { depth <- getParserBrakDepth
- ; return (L1 $! mkUnqual (varNameDepth depth) (unLoc $1)) } }
+ ; return (L1 $! mkUnqual (varNameDepth $ length depth) (unLoc $1)) } }
-- These special_ids are treated as keywords in various places,
-- but as ordinary ids elsewhere. 'special_id' collects all these
l <- getSrcLoc;
let loc = mkSrcLoc (srcLocFile l) 1 1;
return (mkSrcSpan loc loc)
+
+mkHsHetMetEsc a b c = do { depth <- getParserBrakDepth
+ ; return $ case head depth of
+ { LambdaFlavor -> HsHetMetEsc a b c
+ ; KappaFlavor -> HsHetMetEsc a b c
+ }
+ }
+
}