language-ocaml-0.2.0: lib/Language/OCaml/Parser/Generator/Parser.y
{
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
module Language.OCaml.Parser.Generator.Parser
( Parser
, parseExpr
, parseExprCommaList
, parseImplementation
, parseLetBinding
, parseModLongident
, parseOpenStatement
, parsePattern
, parseSeqExpr
, parseSimpleExpr
, parseSimplePattern
, parseStructure
, parseStructureItem
, parseValIdent
, parseValLongident
) where
import Data.Default
import Text.Printf
import Language.OCaml.Definitions.Parsing.ASTHelper.Exp as Exp
import Language.OCaml.Definitions.Parsing.ASTHelper.Mb as Mb
import Language.OCaml.Definitions.Parsing.ASTHelper.Mod as Mod
import Language.OCaml.Definitions.Parsing.ASTHelper.Mtd as Mtd
import Language.OCaml.Definitions.Parsing.ASTHelper.Mty as Mty
import Language.OCaml.Definitions.Parsing.ASTHelper.Opn as Opn
import Language.OCaml.Definitions.Parsing.ASTHelper.Pat as Pat
import Language.OCaml.Definitions.Parsing.ASTHelper.Str as Str
import Language.OCaml.Definitions.Parsing.ASTHelper.Te as Te
import Language.OCaml.Definitions.Parsing.ASTHelper.Typ as Typ
import Language.OCaml.Definitions.Parsing.ASTHelper.Type as Type
import Language.OCaml.Definitions.Parsing.ASTHelper.Val as Val
import Language.OCaml.Definitions.Parsing.ASTHelper.Vb as Vb
import Language.OCaml.Definitions.Parsing.Docstrings
import Language.OCaml.Definitions.Parsing.Location
import Language.OCaml.Definitions.Parsing.Parser.LetBinding
import Language.OCaml.Definitions.Parsing.Parser.LetBindings
import Language.OCaml.Definitions.Parsing.ASTTypes as ASTTypes
import Language.OCaml.Definitions.Parsing.ParseTree as ParseTree
import Language.OCaml.Parser.Common
import Language.OCaml.Parser.Generator.Lexer
}
%name rawParseExpr Expr
%name rawParseExprCommaList ExprCommaList
%name rawParseImplementation Implementation
%name rawParseLetBinding LetBinding
%name rawParseModLongident ModLongident
%name rawParseOpenStatement OpenStatement
%name rawParsePattern Pattern
%name rawParseSeqExpr SeqExpr
%name rawParseSimpleExpr SimpleExpr
%name rawParseSimplePattern SimplePattern
%name rawParseStructureItem StructureItem
%name rawParseStructure Structure
%name rawParseValIdent ValIdent
%name rawParseValLongident ValLongident
%tokentype { ResultToken }
%lexer { lexWrap } { Located _ TokEOF }
%monad { Alex }
%error { parseError }
%token
"&&" { Located _ TokAmperAmper }
"&" { Located _ TokAmpersand }
and { Located _ TokAnd }
as { Located _ TokAs }
assert { Located _ TokAssert }
"`" { Located _ TokBackQuote }
"!" { Located _ TokBang }
"|" { Located _ TokBar }
"||" { Located _ TokBarBar }
"|]" { Located _ TokBarRBracket }
begin { Located _ TokBegin }
CHAR { Located _ (TokChar $$) }
class { Located _ TokClass }
":" { Located _ TokColon }
"::" { Located _ TokColonColon }
":=" { Located _ TokColonEqual }
":>" { Located _ TokColonGreater }
"," { Located _ TokComma }
constraint { Located _ TokConstraint }
do { Located _ TokDo }
done { Located _ TokDone }
"." { Located _ TokDot }
".." { Located _ TokDotDot }
DOTOP { Located _ (TokDotOp $$) }
downto { Located _ TokDownTo }
else { Located _ TokElse }
end { Located _ TokEnd }
EOF { Located _ TokEOF }
"=" { Located _ TokEqual }
exception { Located _ TokException }
external { Located _ TokExternal }
false { Located _ TokFalse }
FLOAT { Located _ (TokFloat $$) }
for { Located _ TokFor }
fun { Located _ TokFun }
function { Located _ TokFunction }
functor { Located _ TokFunctor }
">" { Located _ TokGreater }
">}" { Located _ TokGreaterRBrace }
">]" { Located _ TokGreaterRBracket }
"#" { Located _ TokHash }
HASHOP { Located _ (TokHashOp $$) }
if { Located _ TokIf }
in { Located _ TokIn }
include { Located _ TokInclude }
inherit { Located _ TokInherit }
initialier { Located _ TokInitializer }
INFIXOP0 { Located _ (TokInfixOp0 $$) }
INFIXOP1 { Located _ (TokInfixOp1 $$) }
INFIXOP2 { Located _ (TokInfixOp2 $$) }
INFIXOP3 { Located _ (TokInfixOp3 $$) }
INFIXOP4 { Located _ (TokInfixOp4 $$) }
INT { Located _ (TokInt $$) }
LABEL { Located _ (TokLabel $$) }
lazy { Located _ TokLazy }
"{" { Located _ TokLBrace }
"{<" { Located _ TokLBraceLess }
"[" { Located _ TokLBracket }
"[@" { Located _ TokLBracketAt }
"[@@" { Located _ TokLBracketAtAt }
"[@@@" { Located _ TokLBracketAtAtAt }
"[|" { Located _ TokLBracketBar }
"[>" { Located _ TokLBracketGreater }
"[<" { Located _ TokLBracketLess }
"[%" { Located _ TokLBracketPercent }
"[%%" { Located _ TokLBracketPercentPercent }
"<" { Located _ TokLess }
"<-" { Located _ TokLessMinus }
let { Located _ TokLet }
LIDENT { Located _ (TokLIdent $$) }
"(" { Located _ TokLParen }
match { Located _ TokMatch }
method { Located _ TokMethod }
"-" { Located _ TokMinus }
"-." { Located _ TokMinusDot }
"->" { Located _ TokMinusGreater }
module { Located _ TokModule }
mutable { Located _ TokMutable }
new { Located _ TokNew }
nonrec { Located _ TokNonRec }
object { Located _ TokObject }
of { Located _ TokOf }
open { Located _ TokOpen }
OPTLABEL { Located _ (TokOptLabel $$) }
or { Located _ TokOr }
"%" { Located _ TokPercent }
"+" { Located _ TokPlus }
"+." { Located _ TokPlusDot }
"+=" { Located _ TokPlusEq }
PREFIXOP { Located _ (TokPrefixOp $$) }
private { Located _ TokPrivate }
"?" { Located _ TokQuestion }
"'" { Located _ TokQuote }
"}" { Located _ TokRBrace }
"]" { Located _ TokRBracket }
rec { Located _ TokRec }
")" { Located _ TokRParen }
";" { Located _ TokSemi }
";;" { Located _ TokSemiSemi }
sig { Located _ TokSig }
"*" { Located _ TokStar }
STRING { Located _ (TokString $$) }
struct { Located _ TokStruct }
then { Located _ TokThen }
"~" { Located _ TokTilde }
to { Located _ TokTo }
true { Located _ TokTrue }
try { Located _ TokTry }
type { Located _ TokType }
UIDENT { Located _ (TokUIdent $$) }
"_" { Located _ TokUnderscore }
val { Located _ TokVal }
virtual { Located _ TokVirtual }
when { Located _ TokWhen }
while { Located _ TokWhile }
with { Located _ TokWith }
%nonassoc in
%nonassoc belowSemi
%nonassoc ";"
%nonassoc let
%nonassoc belowWith
%nonassoc function with
%nonassoc and
%nonassoc then
%nonassoc else
%nonassoc "<-"
%right ":="
%nonassoc as
%left "|"
%nonassoc belowComma
%left ","
%right "->"
%right or "||"
%right "&" "&&"
%nonassoc belowEqual
%left INFIXOP0 "=" "<" ">"
%right INFIXOP1
%nonassoc belowLBracketAtAt
%nonassoc "[@"
%nonassoc "[@@"
%right "::"
%left INFIXOP2 "+" "+." "-" "-." "+="
%left "%" INFIXOP3 "*"
%right INFIXOP4
%nonassoc precUnaryMinus precUnaryPlus
%nonassoc precConstantConstructor
%nonassoc precConstrAppl
%nonassoc belowHash
%nonassoc "#"
%left HASHOP
%nonassoc belowDot
%nonassoc "." DOTOP
%nonassoc "`" "!" begin CHAR false float int
"{" "{<" "[" "[|" LIDENT "("
new PREFIXOP STRING true UIDENT
"[%" "[%%"
%%
Additive :: { String }
: "+" { "+" }
| "+." { "+." }
AmperTypeList :: { [CoreType] }
: CoreTypeNoAttr { [$1] }
| AmperTypeList "&" CoreTypeNoAttr { $3 : $1 }
AndLetBinding :: { LetBinding }
: and Attributes LetBindingBody PostItemAttributes { mklb False $3 ($2 ++ $4) }
AndTypeDeclaration :: { TypeDeclaration }
: and Attributes OptionalTypeParameters LIDENT TypeKind Constraints PostItemAttributes
{ let (kind, priv, manifest) = $5 in
Type.mk (def { params = $3
, cstrs = reverse $6
, kind
, priv
, attrs = $2 ++ $7
, loc = symbolRLoc ()
, Type.text = symbolText ()
, docs = symbolDocs ()
})
manifest (mkRHS $4 4)
}
Attribute :: { Attribute }
: "[@@" AttrId Payload "]" { ($2, $3) }
Attributes :: { [Attribute] }
: {- empty -} { [] }
| Attribute Attributes { $1 : $2 }
AttrId :: { Loc String }
: SingleAttrId { mkLoc $1 (symbolRLoc ()) }
| SingleAttrId "." AttrId { mkLoc ($1 ++ "." ++ txt $3) (symbolRLoc ()) }
BarConstructorDeclaration :: { ConstructorDeclaration }
: "|" ConstrIdent GeneralizedConstructorArguments Attributes
{ let (args, res) = $3 in
Type.constructor (def { args
, attrs = $4
, loc = symbolRLoc ()
, info = symbolInfo ()
})
res (mkRHS $2 2)
}
ClassLongident :: { Longident }
: LIDENT { Lident $1 }
| ModLongident "." LIDENT { Ldot $1 $3 }
Constant :: { ParseTree.Constant }
: INT { uncurry PconstInteger $1 }
| CHAR { PconstChar $1 }
| STRING { uncurry PconstString $1 }
| FLOAT { uncurry PconstFloat $1 }
Constrain :: { (CoreType, CoreType, Location) }
: CoreType "=" CoreType { ($1, $3, symbolRLoc ()) }
Constraints :: { [(CoreType, CoreType, Location)] }
: Constraints constraint Constrain { $3 : $1 }
| {- empty-} { [] }
ConstrIdent :: { String }
: UIDENT { $1 }
| "[" "]" { "[]" }
| "(" ")" { "()" }
| "(" "::" ")" { "::" }
| false { "false" }
| true { "true" }
ConstrLongident :: { Longident }
: ModLongident %prec belowDot { $1 }
| ModLongident "." "(" "::" ")" { Ldot $1 "::" }
| "[" "]" { Lident "[]" }
| "(" ")" { Lident "()" }
| "(" "::" ")" { Lident "::" }
| false { Lident "false" }
| true { Lident "true" }
ConstructorArguments :: { ConstructorArguments }
: CoreTypeList { PcstrTuple (reverse $1) }
| "{" LabelDeclarations "}" { PcstrRecord $2 }
ConstructorDeclaration :: { ConstructorDeclaration }
: ConstrIdent GeneralizedConstructorArguments Attributes
{ let (args, res) = $2 in
Type.constructor (def { args
, attrs = $3
, loc = symbolRLoc ()
, info = symbolInfo ()
})
res (mkRHS $1 1)
}
ConstructorDeclarations :: { [ConstructorDeclaration] }
: "|" { [] }
| ConstructorDeclaration { [$1] }
| BarConstructorDeclaration { [$1] }
| ConstructorDeclarations BarConstructorDeclaration { $2 : $1 }
CoreType :: { CoreType }
: CoreTypeNoAttr { $1 }
-- | CoreType Attribute { attrTyp $1 $2 }
CoreType2 :: { CoreType }
: SimpleCoreTypeOrTuple { $1 }
-- | "?" LIDENT ":" CoreType2 "->" CoreType2 { let param = extraRHSCoreType (def { pos = 4 }) $4 in
-- mktyp $ PtypArrow (Optional $2) param $6
-- }
-- TODO
CoreTypeCommaList :: { [CoreType] }
: CoreType { [$1] }
| CoreTypeCommaList "," CoreType { $3 : $1 }
CoreTypeList :: { [CoreType] }
: CoreType { [$1] }
| CoreTypeList "*" CoreType { $3 : $1 }
CoreTypeNoAttr :: { CoreType }
: CoreType2 %prec "->" { $1 }
| CoreType2 as "'" Ident { mktyp $ PtypAlias $1 $4 }
DirectionFlag :: { DirectionFlag }
: to { UpTo }
| downto { DownTo }
Expr :: { Expression }
: SimpleExpr %prec belowHash { $1 }
| SimpleExpr SimpleLabeledExprList { mkexp $ PexpApply $1 (reverse $2) }
| LetBindings in SeqExpr { exprOfLetBindings $1 $3 }
| let module ExtAttributes UIDENT ModuleBindingBody in SeqExpr { mkexpAttrs (PexpLetModule (mkRHS $4 4) $5 $7) $3 }
| let exception ExtAttributes LetExceptionDeclaration in SeqExpr { mkexpAttrs (PexpLetException $4 $6) $3 }
| let open OverrideFlag ExtAttributes ModLongident in SeqExpr { mkexpAttrs (PexpOpen $3 (mkRHS $5 5) $7) $4 }
| function ExtAttributes OptBar MatchCases { mkexpAttrs (PexpFunction (reverse $4)) $2 }
| fun ExtAttributes LabeledSimplePattern FunDef { let (l, o, p) = $3 in
mkexpAttrs (PexpFun l o p $4) $2
}
| fun ExtAttributes "(" type LidentList ")" FunDef { mkexpAttrs (pexpDesc $ mkNewTypes $5 $7) $2 }
| match ExtAttributes SeqExpr with OptBar MatchCases { mkexpAttrs (PexpMatch $3 (reverse $6)) $2 }
| try ExtAttributes SeqExpr with OptBar MatchCases { mkexpAttrs (PexpTry $3 (reverse $6)) $2 }
| try ExtAttributes SeqExpr with error {% alexError "try ExtAttributes SeqExpr with <ERROR>" }
| ExprCommaList %prec belowComma { mkexp $ PexpTuple (reverse $1) }
| ConstrLongident SimpleExpr %prec belowHash { mkexp $ PexpConstruct (mkRHS $1 1) (Just $2) }
| NameTag SimpleExpr %prec belowHash { mkexp $ PexpVariant $1 (Just $2) }
| if ExtAttributes SeqExpr then Expr else Expr { mkexpAttrs (PexpIfThenElse $3 $5 (Just $7)) $2 }
| if ExtAttributes SeqExpr then Expr { mkexpAttrs (PexpIfThenElse $3 $5 Nothing) $2 }
| while ExtAttributes SeqExpr do SeqExpr done { mkexpAttrs (PexpWhile $3 $5) $2 }
| for ExtAttributes Pattern
"=" SeqExpr DirectionFlag SeqExpr
do SeqExpr done { mkexpAttrs (PexpFor $3 $5 $7 $6 $9) $2 }
| Expr "::" Expr { mkexpCons (rhsLoc 2) (ghexp $ PexpTuple [$1, $3]) (symbolRLoc ()) }
| Expr INFIXOP0 Expr { mkinfix $1 $2 $3 }
| Expr INFIXOP1 Expr { mkinfix $1 $2 $3 }
| Expr INFIXOP2 Expr { mkinfix $1 $2 $3 }
| Expr INFIXOP3 Expr { mkinfix $1 $2 $3 }
| Expr INFIXOP4 Expr { mkinfix $1 $2 $3 }
-- TODO: infixops
| Expr "+" Expr { mkinfix $1 "+" $3 }
| Expr "+." Expr { mkinfix $1 "+." $3 }
| Expr "+=" Expr { mkinfix $1 "+=" $3 }
| Expr "-" Expr { mkinfix $1 "-" $3 }
| Expr "-." Expr { mkinfix $1 "-." $3 }
| Expr "*" Expr { mkinfix $1 "*" $3 }
| Expr "%" Expr { mkinfix $1 "%" $3 }
| Expr "=" Expr { mkinfix $1 "=" $3 }
| Expr "<" Expr { mkinfix $1 "<" $3 }
| Expr ">" Expr { mkinfix $1 ">" $3 }
| Expr or Expr { mkinfix $1 "or" $3 }
| Expr "||" Expr { mkinfix $1 "||" $3 }
| Expr "&" Expr { mkinfix $1 "&" $3 }
| Expr "&&" Expr { mkinfix $1 "&&" $3 }
| Expr ":=" Expr { mkinfix $1 ":=" $3 }
| Subtractive Expr %prec precUnaryMinus { mkuminus $1 $2 }
| Additive Expr %prec precUnaryPlus { mkuplus $1 $2 }
| SimpleExpr "." LabelLongident "<-" Expr { mkexp $ PexpSetField $1 (mkRHS $3 3) $5 }
-- TODO: label LESSMINUS expr
| assert ExtAttributes SimpleExpr %prec belowHash { mkexpAttrs (PexpAssert $3) $2 }
-- TODO
-- | Expr Attribute { attrExp $1 $2 }
| "_" {% alexError "Wildcard not expected" }
ExprCommaList :: { [Expression] }
: Expr "," Expr { [$3, $1] }
| ExprCommaList "," Expr { $3 : $1 }
ExprSemiList :: { [Expression] }
: Expr { [$1] }
| ExprSemiList ";" Expr { $3 : $1 }
ExtAttributes :: { (Maybe (Loc String), [(Loc String, Payload)]) }
: {- empty -} { (Nothing, []) }
| Attribute Attributes { (Nothing, $1 : $2) }
| "%" AttrId Attributes { (Just $2, $3) }
Extension :: { (Loc String, Payload) }
: "[%" AttrId Payload "]" { ($2, $3) }
FieldExpr :: { (Loc String, Expression) }
: Label "=" Expr { (mkRHS $1 1, $3) }
| Label { (mkRHS $1 1, expOfLabel (Lident $1) 1) }
FieldExprList :: { [(Loc String, Expression)] }
: FieldExpr OptSemi { [$1] }
| FieldExpr ";" FieldExprList { $1 : $3 }
FieldSemi :: { ObjectField }
: Label ":" PolyTypeNoAttr Attributes ";" Attributes
{ let info = case rhsInfo 4 of
-- Somehow the next line needs to be indented real right for the generater .hs file to parse correctly
infoBeforeSemi@(Just _) -> infoBeforeSemi
Nothing -> symbolInfo ()
in
Otag (mkRHS $1 1) (addInfoAttrs info ($4 ++ $6)) $3
}
FunBinding :: { Expression }
: StrictBinding { $1 }
-- | TypeConstraint "=" SeqExpr { mkexpConstraint $3 $1 }
FunDef :: { Expression }
: "->" SeqExpr { $2 }
| ":" SimpleCoreType "->" SeqExpr { Exp.mk def $ PexpConstraint $4 $2 }
| LabeledSimplePattern FunDef { let (l, o, p) = $1 in
ghexp $ PexpFun l o p $2
}
GeneralizedConstructorArguments :: { (ConstructorArguments, Maybe CoreType) }
: {- empty -} { (PcstrTuple [], Nothing) }
| of ConstructorArguments { ($2, Nothing) }
| ":" ConstructorArguments "->" SimpleCoreType { ($2, Just $4) }
| ":" SimpleCoreType { (PcstrTuple [], Just $2) }
Ident :: { String }
: UIDENT { $1 }
| LIDENT { $1 }
Implementation :: { [StructureItem] }
: Structure { extraStr 1 $1 }
-- : Structure EOF { extraStr 1 $1 } -- FIXME
Label :: { String }
: LIDENT { $1 }
LabelDeclaration :: { LabelDeclaration }
: MutableFlag Label ":" PolyTypeNoAttr Attributes
{ Type.field (def { mut = $1
, attrs = $5
, loc = symbolRLoc ()
, info = symbolInfo ()
}
)
(mkRHS $2 2) $4
}
LabelDeclarations :: { [LabelDeclaration] }
: LabelDeclaration { [$1] }
| LabelDeclarationSemi { [$1] }
| LabelDeclarationSemi LabelDeclarations { $1 : $2 }
LabelDeclarationSemi :: { LabelDeclaration }
: MutableFlag Label ":" PolyTypeNoAttr Attributes ";" Attributes
{ let info = symbolInfo ()
-- case rhsInfo 5 of
-- infoBeforeSemi@(Just _) -> infoBeforeSemi
-- Nothing -> symbolInfo ()
in
Type.field (def { mut = $1
, attrs = $5 ++ $7
, loc = symbolRLoc ()
, info
}
)
(mkRHS $2 2) $4
}
LabelLetPattern :: { (String, Pattern) }
: LabelVar { $1 }
| LabelVar ":" CoreType { let (lab, pat) = $1 in
(lab, mkpat $ PpatConstraint pat $3)
}
LabelLongident :: { Longident }
: LIDENT { Lident $1 }
| ModLongident "." LIDENT { Ldot $1 $3 }
LabeledSimpleExpr :: { (ArgLabel, Expression) }
: SimpleExpr %prec belowHash { (Nolabel, $1) }
-- | LabelExpr { $1 }
LabeledSimplePattern :: { (ArgLabel, Maybe Expression, Pattern) }
: "?" "(" LabelLetPattern OptDefault ")" { (Optional (fst $3), $4, snd $3) }
| "?" LabelVar { (Optional (fst $2), Nothing, snd $2) }
| OPTLABEL "(" LetPattern OptDefault ")" { (Optional $1, $4, $3) }
| OPTLABEL PatternVar { (Optional $1, Nothing, $2) }
| "~" "(" LabelLetPattern ")" { (Labelled (fst $3), Nothing, snd $3) }
| "~" LabelVar { (Labelled (fst $2), Nothing, snd $2) }
| LABEL SimplePattern { (Labelled $1, Nothing, $2) }
| SimplePattern { (Nolabel, Nothing, $1) }
LabelVar :: { (String, Pattern) }
: LIDENT { ($1, mkpat $ PpatVar (mkRHS $1 1)) }
LblExpr :: { (Loc Longident, Expression) }
: LabelLongident OptTypeConstraint "=" Expr { (mkRHS $1 1, mkexpOptConstraint $4 $2) }
| LabelLongident OptTypeConstraint { (mkRHS $1 1, mkexpOptConstraint (expOfLabel $1 1) $2) }
LblExprList :: { [(Loc Longident, Expression)] }
: LblExpr { [$1] }
| LblExpr ";" LblExprList { $1 : $3 }
| LblExpr ";" { [$1] }
LblPattern :: { (Loc Longident, Pattern) }
: LabelLongident OptPatternTypeConstraint "=" Pattern { (mkRHS $1 1, mkpatOptConstraint $4 $2) }
| LabelLongident OptPatternTypeConstraint { (mkRHS $1 1, mkpatOptConstraint (patOfLabel $1 1) $2) }
LblPatternList :: { ([(Loc Longident, Pattern)], ClosedFlag) }
: LblPattern { ([$1], Closed) }
| LblPattern ";" { ([$1], Closed) }
| LblPattern ";" "_" OptSemi { ([$1], Open) }
| LblPattern ";" LblPatternList { let (fields, closed) = $3 in ($1 : fields, closed) }
LetBinding :: { LetBindings }
: let ExtAttributes RecFlag LetBindingBody PostItemAttributes { let (ext, attr) = $2 in
mklbs ext $3 (mklb True $4 (attr ++ $5))
}
LetBindingBody :: { (Pattern, Expression) }
: ValIdent StrictBinding { (mkpatvar $1 1, $2) }
| ValIdent TypeConstraint "=" SeqExpr { let v = mkpatvar $1 1 in
let t = case $2 of
(Just t, Nothing) -> t
(_, Just t) -> t
(_, _) -> error "This should not happen"
in
( ghpat $ PpatConstraint v (ghtyp $ PtypPoly [] t)
, mkexpConstraint $4 $2
)
}
| ValIdent ":" TypeVarList "." CoreType "=" SeqExpr { ( ghpat $ PpatConstraint (mkpatvar $1 1) (ghtyp $ PtypPoly (reverse $3) $5)
, $7
)
}
| ValIdent ":" type LidentList "." CoreType "=" SeqExpr { let (exp, poly) = wrapTypeAnnotation $4 $6 $8 in
( ghpat $ PpatConstraint (mkpatvar $1 1) poly
, exp
)
}
| PatternNoExn "=" SeqExpr { ($1, $3) }
| SimplePatternNotIdent ":" CoreType "=" SeqExpr { (ghpat $ PpatConstraint $1 $3, $5) }
LetBindings :: { LetBindings }
: LetBinding { $1 }
| LetBindings AndLetBinding { addlb $1 $2 }
LetExceptionDeclaration :: { ExtensionConstructor }
: ConstrIdent GeneralizedConstructorArguments Attributes
{ let (args, res) = $2 in
Te.decl (def { args
, attrs = $3
, loc = symbolRLoc ()
}
)
res (mkRHS $1 1)
}
LetPattern :: { Pattern }
: Pattern { $1 }
| Pattern ":" CoreType { mkpat $ PpatConstraint $1 $3 }
LidentList :: { [Loc String] }
: LIDENT { [mkRHS $1 1] }
| LIDENT LidentList { mkRHS $1 1 : $2 }
MatchCase :: { Case }
: Pattern "->" SeqExpr { Exp.case' def $1 $3 }
| Pattern when SeqExpr "->" SeqExpr { Exp.case' (def { guard = Just $3 }) $1 $5 }
| Pattern "->" "." { Exp.case' def $1 (Exp.unreachable (def { loc = rhsLoc 3 }) ()) }
MatchCases :: { [Case] }
: MatchCase { [$1] }
| MatchCases "|" MatchCase { $3 : $1 }
MethList :: { ([ObjectField], ClosedFlag) }
: FieldSemi MethList { let (f, c) = $2 in ($1 : f, c) }
-- TODO
| ".." { ([], Open) }
ModExtLongident :: { Longident }
: UIDENT { Lident $1 }
| ModExtLongident "." UIDENT { Ldot $1 $3 }
-- | ModExtLongident "(" ModExtLongident ")" { lapply $1 $3 }
ModLongident :: { Longident }
: UIDENT { Lident $1 }
| ModLongident "." UIDENT { Ldot $1 $3 }
ModuleBinding :: { (ModuleBinding, Maybe (Loc String)) }
: module ExtAttributes UIDENT ModuleBindingBody PostItemAttributes
{ let (ext, attrs) = $2 in
( Mb.mk (def { attrs = attrs ++ $5
, loc = symbolRLoc ()
, docs = symbolDocs ()
}
)
(mkRHS $3 3) $4
, ext
)
}
ModuleBindingBody :: { ModuleExpr }
: "=" ModuleExpr { $2 }
| ":" ModuleType "=" ModuleExpr { mkmod def $ PmodConstraint $4 $2 }
-- | FunctorArg ModuleBindingBody { mkmod def $ PmodFunctor (fst $1) (snd $1) $2 }
ModuleExpr :: { ModuleExpr }
: ModLongident { mkmod def $ PmodIdent (mkRHS $1 1) }
| struct Attributes Structure end { mkmod (Just $2) $ PmodStructure (extraStr 3 $3) }
| struct Attributes Structure error {% alexError "struct Attributes Structure <ERROR>" }
-- | functor Attributes FunctorArg "->" ModuleExpr { let modExp = foldl (\ acc (n, t) -> mkmod def $ PmodFunctor n t acc) $5 $3
-- in wrapModAttrs modExp $2
-- }
| ModuleExpr ParenModuleExpr { mkmod def $ PmodApply $1 $2 }
| ModuleExpr "(" ")" { mkmod def $ PmodApply $1 (mkmod def $ PmodStructure []) }
| ParenModuleExpr { $1 }
| ModuleExpr Attribute { Mod.attr $1 $2 }
| Extension { mkmod def $ PmodExtension $1 }
ModuleType :: { ModuleType }
: MtyLongident { mkmty def $ PmtyIdent (mkRHS $1 1) }
-- TODO
ModuleTypeDeclaration :: { (ModuleTypeDeclaration, Maybe (Loc String)) }
: module type ExtAttributes Ident ModuleTypeDeclarationBody PostItemAttributes
{ let (ext, attrs) = $3 in
( Mtd.mk (def { attrs = attrs ++ $6
, loc = symbolRLoc ()
, docs = symbolDocs ()
}
) $5 (mkRHS $4 4)
, ext
)
}
ModuleTypeDeclarationBody :: { Maybe ModuleType }
: {- empty -} { Nothing }
| "=" ModuleType { Just $2 }
MutableFlag :: { MutableFlag }
: {- empty-} { Immutable }
| mutable { Mutable }
MtyLongident :: { Longident }
: Ident { Lident $1 }
| ModExtLongident "." Ident { Ldot $1 $3 }
NameTag :: { String }
: "`" Ident { $2 }
NonRecFlag :: { RecFlag }
: {- empty -} { Recursive }
| nonrec { NonRecursive }
OpenStatement :: { (OpenDescription, Maybe (Loc String)) }
: open OverrideFlag ExtAttributes ModLongident PostItemAttributes
{ let (ext, attrs) = $3 in
(Opn.mk (def { Opn.override = $2
, attrs = attrs ++ $5
, loc = symbolRLoc ()
, docs = symbolDocs ()
})
(mkRHS $4 4)
, ext
)
}
Operator :: { String }
: PREFIXOP { $1 }
| INFIXOP0 { $1 }
| INFIXOP1 { $1 }
| INFIXOP2 { $1 }
| INFIXOP3 { $1 }
| INFIXOP4 { $1 }
| DOTOP "(" ")" { "." ++ $1 ++ "()" }
| DOTOP "(" ")" "<-" { "." ++ $1 ++ "()<-" }
| DOTOP "[" "]" { "." ++ $1 ++ "[]" }
| DOTOP "[" "]" "<-" { "." ++ $1 ++ "[]<-" }
| DOTOP "{" "}" { "." ++ $1 ++ "{}" }
| DOTOP "{" "}" "<-" { "." ++ $1 ++ "{}<-" }
| HASHOP { $1 }
| "!" { "!" }
| "+" { "+" }
| "+." { "+." }
| "-" { "-" }
| "-." { "-." }
| "*" { "*" }
| "=" { "=" }
| "<" { "<" }
| ">" { ">" }
| or { "or" }
| "||" { "||" }
| "&" { "&" }
| "&&" { "&&" }
| ":=" { ":=" }
| "+=" { "+=" }
| "%" { "%" }
OptAmpersand :: { Bool }
: "&" { True }
| {- empty -} { False }
OptBar :: { () }
: {- empty -} { () }
| "|" { () }
OptDefault :: { Maybe Expression }
: {- empty-} { Nothing }
| "=" SeqExpr { Just $2 }
OptionalTypeParameter :: { (CoreType, Variance) }
: TypeVariance OptionalTypeVariable { ($2, $1) }
OptionalTypeParameterList :: { [(CoreType, Variance)] }
: OptionalTypeParameter { [$1] }
| OptionalTypeParameterList "," OptionalTypeParameter { $3 : $1 }
OptionalTypeParameters :: { [(CoreType, Variance)] }
: {- empty -} { [] }
| OptionalTypeParameter { [$1] }
| "(" OptionalTypeParameterList ")" { reverse $2 }
OptionalTypeVariable :: { CoreType }
: "'" Ident { mktyp $ PtypVar $2 }
| "_" { mktyp $ PtypAny }
OptPatternTypeConstraint :: { Maybe CoreType }
: ":" CoreType { Just $2 }
| {- empty -} { Nothing }
OptSemi :: { () }
: {- empty -} { () }
| ";" { () }
OptTypeConstraint :: { Maybe (Maybe CoreType, Maybe CoreType) }
: TypeConstraint { Just $1 }
| {- empty -} { Nothing }
OverrideFlag :: { OverrideFlag }
: {- empty -} { Fresh }
| "!" { Override }
PackageType :: { PackageType }
: ModuleType { packageTypeOfModuleType $1 }
ParenModuleExpr :: { ModuleExpr }
: "(" ModuleExpr ":" ModuleType ")" { mkmod def $ PmodConstraint $2 $4 }
| "(" ModuleExpr ":" ModuleType error {% alexError "( ModuleExpr : ModuleType <ERROR>" }
-- TODO
Pattern :: { Pattern }
: Pattern as ValIdent { mkpat $ PpatAlias $1 (mkRHS $3 3) }
| Pattern as error {% alexError "Pattern as <ERROR>" }
| PatternCommaList %prec belowComma { mkpat $ PpatTuple (reverse $1) }
| Pattern "::" Pattern { mkpatCons (rhsLoc 2) (ghpat $ PpatTuple [$1, $3]) (symbolRLoc ()) }
| Pattern "::" error {% alexError "Pattern :: <ERROR>" }
| Pattern "|" Pattern { mkpat $ PpatOr $1 $3 }
| Pattern "|" error {% alexError "Pattern | <ERROR>" }
-- | exception ExtAttributes Pattern %prec precConstrAppl { mkpatAttrs (PpatException $3) $2 }
-- | Pattern Attribute { attrPat $1 $2 }
| PatternGen { $1 }
PatternCommaList :: { [Pattern] }
: PatternCommaList "," Pattern { $3 : $1 }
| Pattern "," Pattern { [$3, $1] }
| Pattern "," error {% alexError "Pattern , <ERROR>" }
PatternGen :: { Pattern }
: SimplePattern { $1 }
| ConstrLongident Pattern %prec precConstrAppl { mkpat $ PpatConstruct (mkRHS $1 1) (Just $2) }
| NameTag Pattern %prec precConstrAppl { mkpat $ PpatVariant $1 (Just $2) }
| lazy ExtAttributes SimplePattern { mkpatAttrs (PpatLazy $3) $2 }
PatternNoExn :: { Pattern }
: PatternNoExn as ValIdent { mkpat $ PpatAlias $1 (mkRHS $3 3) }
| PatternNoExn as error {% alexError "PatternNoExn as <ERROR>" }
| PatternNoExnCommaList %prec belowComma { mkpat $ PpatTuple (reverse $1) }
| PatternNoExn "::" Pattern { mkpatCons (rhsLoc 2) (ghpat $ PpatTuple [$1, $3]) (symbolRLoc ()) }
| PatternNoExn "::" error {% alexError "PatternNoExn :: <ERROR>" }
| PatternNoExn "|" Pattern { mkpat $ PpatOr $1 $3 }
| PatternNoExn "|" error {% alexError "PatternNoExn | <ERROR>" }
| PatternNoExn Attribute { Pat.attr $1 $2 }
| PatternGen { $1 }
PatternNoExnCommaList :: { [Pattern] }
: PatternNoExnCommaList "," Pattern { $3 : $1 }
| PatternNoExn "," Pattern { [$3, $1] }
| PatternNoExn "," error {% alexError "PatternNoExn , <ERROR>" }
PatternSemiList :: { [Pattern] }
: Pattern { [$1] }
| PatternSemiList ";" Pattern { $3 : $1 }
PatternVar :: { Pattern }
: LIDENT { mkpat $ PpatVar (mkRHS $1 1) }
| "_" { mkpat $ PpatAny }
Payload :: { Payload }
: Structure { PStr $1 }
-- | ":" Signature { PSig $2 }
-- TODO
PolyType :: { CoreType }
: CoreType { $1 }
| TypeVarList "." CoreType { mktyp $ PtypPoly (reverse $1) $3 }
PolyTypeNoAttr :: { CoreType }
: CoreTypeNoAttr { $1 }
| TypeVarList "." CoreTypeNoAttr { mktyp $ PtypPoly (reverse $1) $3 }
PostItemAttribute :: { (Loc String, Payload) }
: "[@@" AttrId Payload "]" { ($2, $3) }
PostItemAttributes :: { Attributes }
: {- empty -} { [] }
| PostItemAttribute PostItemAttributes { $1 : $2 }
PrimitiveDeclaration :: { (ValueDescription, Maybe (Loc String)) }
: external ExtAttributes ValIdent ":" CoreType "=" PrimitiveDeclarationBody PostItemAttributes
{ let (ext, attrs) = $2 in
( Val.mk (def { prim = $7
, attrs = attrs ++ $8
, loc = symbolRLoc ()
, docs = symbolDocs ()
}
)
(mkRHS $3 3) $5
, ext
)
}
PrimitiveDeclarationBody :: { [String] }
: STRING { [fst $1] }
| STRING PrimitiveDeclarationBody { fst $1 : $2 }
PrivateFlag :: { PrivateFlag }
: {- empty -} { Public }
| private { Private }
RecFlag :: { RecFlag }
: {- empty -} { NonRecursive }
| rec { Recursive }
RecordExpr :: { (Maybe Expression, [(Loc Longident, Expression)]) }
: SimpleExpr with LblExprList { (Just $1, $3) }
| LblExprList { (Nothing, $1) }
RowField :: { a }
: TagField { $1 }
| SimpleCoreType { Rinherit $1 }
RowFieldList :: { [a] }
: RowField { [$1] }
| RowFieldList "|" RowField { $3 : $1 }
SeqExpr :: { Expression }
: Expr %prec belowSemi { $1 }
| Expr ";" { $1 }
| Expr ";" SeqExpr { mkexp $ PexpSequence $1 $3 }
| Expr ";" "%" AttrId SeqExpr { let seq = mkexp $ PexpSequence $1 $5 in
let payload = PStr [mkstrexp seq []] in
mkexp $ PexpExtension ($4, payload)
}
SigExceptionDeclaration :: { (ExtensionConstructor, Maybe (Loc String)) }
: exception ExtAttributes ConstrIdent GeneralizedConstructorArguments Attributes PostItemAttributes
{ let (args, res) = $4 in
let (ext, attrs) = $2 in
( Te.decl (def { args
, attrs = attrs ++ $5 ++ $6
, loc = symbolRLoc ()
, docs = symbolDocs ()
}
)
res (mkRHS $3 3)
, ext
)
}
-- Signature :: { [SignatureItem] }
-- : {- empty-} { [] }
-- | ";;" Signature { textSig 1 ++ $2 }
-- | SignatureItem Signature { textSig 1 ++ $1 : $2 }
--
-- SignatureItem :: { SignatureItem }
-- : ValueDescription { let (body, ext) = $1 in mksigExt (PsigValue body) ext }
-- -- TODO
SignedConstant :: { ParseTree.Constant }
: Constant { $1 }
| "-" INT { let (n, m) = $2 in PconstInteger ("-" ++ n) m }
| "-" FLOAT { let (f, m) = $2 in PconstFloat ("-" ++ f) m }
| "+" INT { let (n, m) = $2 in PconstInteger n m }
| "+" FLOAT { let (f, m) = $2 in PconstFloat f m }
SimpleCoreType :: { CoreType }
: SimpleCoreType2 %prec belowHash { $1 }
| "(" CoreTypeCommaList ")" %prec belowHash {% case $2 of
[sty] -> return sty
_ -> alexError "( CoreTypeCommaList ) [expected length 1]"
}
SimpleCoreType2 :: { CoreType }
: "'" Ident { mktyp $ PtypVar $2 }
| "_" { mktyp $ PtypAny }
| TypeLongident { mktyp $ PtypConstr (mkRHS $1 1) [] }
| SimpleCoreType2 TypeLongident { mktyp $ PtypConstr (mkRHS $2 2) [$1] }
| "(" CoreTypeCommaList ")" TypeLongident { mktyp $ PtypConstr (mkRHS $4 4) (reverse $2) }
| "<" MethList ">" { let (f, c) = $2 in
mktyp $ PtypObject f c
}
| "<" ">" { mktyp $ PtypObject [] Closed }
| "#" ClassLongident { mktyp $ PtypClass (mkRHS $2 2) [] }
| "(" CoreTypeCommaList ")" "#" ClassLongident { mktyp $ PtypClass (mkRHS $5 5) (reverse $2) }
| "[" TagField "]" { mktyp $ PtypVariant [$2] Closed Nothing }
-- TODO
| "[" "|" RowFieldList "]" { mktyp $ PtypVariant (reverse $3) Closed Nothing }
| "[>" "]" { mktyp $ PtypVariant [] Open Nothing }
SimpleCoreTypeOrTuple :: { CoreType }
: SimpleCoreType { $1 }
| SimpleCoreType "*" CoreTypeList { mktyp $ PtypTuple ($1 : reverse $3) }
SimpleDelimitedPattern :: { Pattern }
: "{" LblPatternList "}" { let (fields, closed) = $2 in mkpat $ PpatRecord fields closed }
| "{" LblPatternList error {% alexError "{ LblPatternList <ERROR>" }
| "[" PatternSemiList OptSemi "]" { relocPat $ mktailpat (rhsLoc 4) (reverse $2) }
| "[" PatternSemiList OptSemi error {% alexError "[ PatternSemiList OptSemi <ERROR>" }
| "[|" PatternSemiList OptSemi "|]" { mkpat $ PpatArray (reverse $2) }
| "[|" "|]" { mkpat $ PpatArray [] }
| "[|" PatternSemiList OptSemi error {% alexError "[| PatternSemiList OptSemi <ERROR>" }
SimpleExpr :: { Expression }
: ValLongident { mkexp $ PexpIdent (mkRHS $1 1) }
| Constant { mkexp $ PexpConstant $1 }
| ConstrLongident %prec precConstantConstructor { mkexp $ PexpConstruct (mkRHS $1 1) Nothing }
| NameTag %prec precConstantConstructor { mkexp $ PexpVariant $1 Nothing }
| "(" SeqExpr ")" { relocExp $2 }
| "(" SeqExpr error {% alexError "( SeqExpr <ERROR>" }
| begin ExtAttributes SeqExpr end { wrapExpAttrs (relocExp $3) $2 }
| begin ExtAttributes end { mkexpAttrs (PexpConstruct (mkLoc (Lident "()") (symbolRLoc ())) Nothing) $2 }
| begin ExtAttributes error {% alexError "begin ExtAttributes <ERROR>" }
| "(" SeqExpr TypeConstraint ")" { mkexpConstraint $2 $3 }
| SimpleExpr "." LabelLongident { mkexp $ PexpField $1 (mkRHS $3 3) }
| ModLongident "." "(" SeqExpr ")" { mkexp $ PexpOpen Fresh (mkRHS $1 1) $4 }
| ModLongident "." "(" ")" { mkexp $ PexpOpen Fresh (mkRHS $1 1) (mkexp $ PexpConstruct (mkRHS (Lident "()") 1) Nothing) }
| ModLongident "." "(" SeqExpr error {% alexError "TODO" }
| SimpleExpr "." "(" SeqExpr ")" { error "TODO 1" }
| SimpleExpr "." "(" SeqExpr { error "TODO 2" }
| SimpleExpr "." "[" SeqExpr "]" { error "TODO 3" }
| SimpleExpr "." "[" SeqExpr { error "TODO 4" }
| SimpleExpr DOTOP "[" SeqExpr "]" { error "TODO 5" }
| SimpleExpr DOTOP "[" SeqExpr { error "TODO 6" }
| SimpleExpr DOTOP "(" Expr ")" { error "TODO 7" }
| SimpleExpr DOTOP "(" Expr { error "TODO 8" }
| SimpleExpr DOTOP "{" Expr "}" { error "TODO 9" }
| SimpleExpr DOTOP "{" Expr { error "TODO 11" }
| SimpleExpr "." ModLongident DOTOP "[" Expr "]" { error "TODO 12" }
| SimpleExpr "." ModLongident DOTOP "[" Expr { error "TODO 13" }
| SimpleExpr "." ModLongident DOTOP "(" Expr ")" { error "TODO 14" }
| SimpleExpr "." ModLongident DOTOP "(" Expr { error "TODO 15" }
| SimpleExpr "." ModLongident DOTOP "{" Expr "}" { error "TODO 16" }
| SimpleExpr "." ModLongident DOTOP "{" Expr { error "TODO 17" }
| SimpleExpr "." "{" Expr "}" { error "TODO 18" }
| SimpleExpr "." "{" ExprCommaList { error "TODO 19" }
| "{" RecordExpr "}" { error "TODO 20" }
| "{" RecordExpr { error "TODO 21" }
| ModLongident "." "{" RecordExpr "}" { error "TODO 22" }
| ModLongident "." "{" RecordExpr { error "TODO 23" }
| "[|" ExprSemiList OptSemi "|]" { error "TODO 24" }
| "[|" ExprSemiList OptSemi { error "TODO 25" }
| "[|" "|]" { error "TODO 26" }
| ModLongident "." "[|" ExprSemiList OptSemi "|]" { error "TODO 27" }
| ModLongident "." "[|" "|]" { error "TODO 28" }
| ModLongident "." "[|" ExprSemiList OptSemi { error "TODO 29" }
| "[" ExprSemiList OptSemi "]" { relocExp $ mktailexp (rhsLoc 4) (reverse $2) }
| "[" ExprSemiList OptSemi error {% alexError "TODO" }
| ModLongident "." "[" ExprSemiList OptSemi "]" { error "TODO 30" }
| ModLongident "." "[" "]" { error "TODO 31" }
| ModLongident "." "[" ExprSemiList OptSemi { error "TODO 32" }
| PREFIXOP SimpleExpr { error "TODO 33" }
| "!" SimpleExpr { mkexp $ PexpApply (mkOperator "!" 1) [(Nolabel, $2)] }
| new ExtAttributes ClassLongident { mkexpAttrs (PexpNew (mkRHS $3 3)) $2 }
| "{<" FieldExprList ">}" { mkexp $ PexpOverride $2 }
| "{<" FieldExprList error {% alexError "TODO" }
| "{<" ">}" { mkexp $ PexpOverride [] }
| ModLongident "." "{<" FieldExprList ">}" { mkexp $ PexpOpen Fresh (mkRHS $1 1) (mkexp $ PexpOverride $4) }
-- TODO
SimpleLabeledExprList :: { [(ArgLabel, Expression)] }
: LabeledSimpleExpr { [$1] }
| SimpleLabeledExprList LabeledSimpleExpr { $2 : $1 }
SimplePattern :: { Pattern }
: ValIdent %prec belowEqual { mkpat $ PpatVar (mkRHS $1 1) }
| SimplePatternNotIdent { $1 }
SimplePatternNotIdent :: { Pattern }
: "_" { mkpat $ PpatAny }
| SignedConstant { mkpat $ PpatConstant $1 }
| SignedConstant ".." SignedConstant { mkpat $ PpatInterval $1 $3 }
| ConstrLongident { mkpat $ PpatConstruct (mkRHS $1 1) Nothing }
| NameTag { mkpat $ PpatVariant $1 Nothing }
| "#" TypeLongident { mkpat $ PpatType (mkRHS $2 2) }
| SimpleDelimitedPattern { $1 }
| ModLongident "." SimpleDelimitedPattern { mkpat $ PpatOpen (mkRHS $1 1) $3 }
| ModLongident "." "{" "}" { mkpat $ PpatOpen (mkRHS $1 1) (mkpat $ PpatConstruct (mkRHS (Lident "[]") 4) Nothing) }
| ModLongident "." "(" ")" { mkpat $ PpatOpen (mkRHS $1 1) (mkpat $ PpatConstruct (mkRHS (Lident "()") 4) Nothing) }
| ModLongident "." "(" Pattern ")" { mkpat $ PpatOpen (mkRHS $1 1) $4 }
| ModLongident "." "(" error {% alexError "ModLongident . ( <ERROR>" }
| "(" Pattern ")" { relocPat $2 }
| "(" Pattern error {% alexError "( Pattern <ERROR>" }
| "(" Pattern ":" CoreType ")" { mkpat $ PpatConstraint $2 $4 }
| "(" Pattern ":" CoreType error {% alexError "( Pattern : CoreType <ERROR>" }
| "(" Pattern ":" error {% alexError "( Pattern : <ERROR>" }
| "(" module ExtAttributes UIDENT ")" { mkpatAttrs (PpatUnpack (mkRHS $4 4)) $3 }
| "(" module ExtAttributes UIDENT ":" PackageType ")" { mkpatAttrs (PpatConstraint (mkpat $ PpatUnpack (mkRHS $4 4)) (ghtyp $ PtypPackage $6)) $3 }
| "(" module ExtAttributes UIDENT ":" PackageType error {% alexError "( module ExtAttributes UIDENT : PackageType <ERROR>" }
| Extension { mkpat $ PpatExtension $1 }
SingleAttrId :: { String }
: LIDENT { $1 }
| UIDENT { $1 }
-- | and { "and" }
-- | as { "as" }
-- | assert { "assert" }
-- | begin { "begin" }
-- | class { "class" }
-- TODO
StrExceptionDeclaration :: { (ExtensionConstructor, Maybe (Loc String)) }
: SigExceptionDeclaration { $1 }
| exception ExtAttributes ConstrIdent
"=" ConstrLongident Attributes PostItemAttributes { let (ext, attrs) = $2 in
( Te.rebind (def { attrs = attrs ++ $6 ++ $7
, loc = symbolRLoc ()
, docs = symbolDocs ()
})
(mkRHS $3 3) (mkRHS $5 5)
, ext
)
}
StrictBinding :: { Expression }
: "=" SeqExpr { $2 }
| LabeledSimplePattern FunBinding { let (l, o, p) = $1 in
ghexp $ PexpFun l o p $2
}
-- | "(" LidentList ")" FunBinding { mk_newtypes $3 $5 }
Structure :: { Structure }
: SeqExpr PostItemAttributes StructureTail { do
-- TODO: mark_rhsDocs 1 2
(textStr 1) ++ mkstrexp $1 $2 : $3
}
| StructureTail { $1 }
StructureItem :: { StructureItem }
: LetBindings { valOfLetBindings $1 }
| PrimitiveDeclaration { let (body, ext) = $1 in mkstrExt (PstrPrimitive body) ext }
| ValueDescription { let (body, ext) = $1 in mkstrExt (PstrPrimitive body) ext }
| TypeDeclarations { let (nr, l, ext) = $1 in mkstrExt (PstrType nr (reverse l)) ext }
-- | StrTypeExtension { let (l, ext) = $1 in mkstrExt (PstrTypExt l) ext }
| StrExceptionDeclaration { let (l, ext) = $1 in mkstrExt (PstrException l) ext }
| ModuleBinding { let (body, ext) = $1 in mkstrExt (PstrModule body) ext }
-- TODO: RecModuleBindings
| ModuleTypeDeclaration { let (body, ext) = $1 in mkstrExt (PstrModType body) ext }
| OpenStatement { let (body, ext) = $1 in mkstrExt (PstrOpen body) ext }
-- TODO: ClassDeclarations
-- TODO: ClassTypeDeclarations
-- TODO: StrIncludeStatement
-- TODO: ItemExtension PostItemAttributes
-- TODO: FloatingAttribute
StructureTail :: { Structure }
: {- empty -} { [] }
| ";;" Structure { (textStr 1) ++ $2 }
| StructureItem StructureTail { (textStr 1) ++ $1 : $2 }
Subtractive :: { String }
: "-" { "-" }
| "-." { "-." }
TagField :: { RowField }
: NameTag of OptAmpersand AmperTypeList Attributes { Rtag (mkRHS $1 1) (addInfoAttrs (symbolInfo ()) $5) $3 (reverse $4) }
-- TODO
TypeConstraint :: { (Maybe CoreType, Maybe CoreType) }
: ":" CoreType { (Just $2, Nothing) }
| ":" CoreType ":>" CoreType { (Just $2, Just $4) }
| ":>" CoreType { (Nothing, Just $2) }
| ":" error {% alexError ": <ERROR>" }
| ":>" error {% alexError ":> <ERROR>" }
TypeDeclaration :: { (RecFlag, TypeDeclaration, Maybe (Loc String)) }
: type ExtAttributes RecFlag OptionalTypeParameters LIDENT
TypeKind Constraints PostItemAttributes
{ let (kind, priv, manifest) = $6 in
let (ext, attrs) = $2 in
let ty = Type.mk (def { params = $4
, cstrs = reverse $7
, kind
, priv
, attrs = attrs ++ $8
, loc = symbolRLoc ()
, docs = symbolDocs ()
}
)
manifest (mkRHS $5 5)
in ($3, ty, ext)
}
TypeDeclarations :: { (RecFlag, [TypeDeclaration], Maybe (Loc String)) }
: TypeDeclaration { let (nonRecFlag, ty, ext) = $1 in
(nonRecFlag, [ty], ext)
}
| TypeDeclarations AndTypeDeclaration { let (nonRecFlag, tys, ext) = $1 in
(nonRecFlag, $2 : tys, ext)
}
TypeKind :: { (TypeKind, PrivateFlag, Maybe CoreType) }
: {- empty-} { (PtypeAbstract, Public, Nothing) }
| "=" CoreType { (PtypeAbstract, Public, Just $2) }
| "=" private CoreType { (PtypeAbstract, Private, Just $3) }
| "=" ConstructorDeclarations { (PtypeVariant (reverse $2), Public, Nothing) }
| "=" private ConstructorDeclarations { (PtypeVariant (reverse $3), Private, Nothing) }
| "=" ".." { (PtypeOpen, Public, Nothing) }
| "=" private ".." { (PtypeOpen, Private, Nothing) }
| "=" PrivateFlag "{" LabelDeclarations "}" { (PtypeRecord $4, $2, Nothing) }
| "=" CoreType "=" PrivateFlag ConstructorDeclarations { (PtypeVariant (reverse $5), $4, Just $2) }
| "=" CoreType "=" PrivateFlag ".." { (PtypeOpen, $4, Just $2) }
| "=" CoreType "=" PrivateFlag "{" LabelDeclarations "}" { (PtypeRecord $6, $4, Just $2) }
TypeLongident :: { Longident }
: LIDENT { Lident $1 }
| ModExtLongident "." LIDENT { Ldot $1 $3 }
TypeVariance :: { Variance }
: {- empty-} { Invariant }
| "+" { Covariant }
| "-" { Contravariant }
TypeVarList :: { [Loc String] }
: "'" Ident { [mkRHS $2 2] }
| TypeVarList "'" Ident { mkRHS $3 3 : $1 }
ValIdent :: { String }
: LIDENT { $1 }
| "(" Operator ")" { $2 }
-- TODO
ValLongident :: { Longident }
: ValIdent { Lident $1 }
| ModLongident "." ValIdent { Ldot $1 $3 }
ValueDescription :: { (ValueDescription, Maybe (Loc String)) }
: val ExtAttributes ValIdent ":" CoreType PostItemAttributes
{ let (ext, attrs) = $2 in
( Val.mk (def { attrs = attrs ++ $6
, loc = symbolRLoc ()
, docs = symbolDocs ()
})
(mkRHS $3 3) $5
, ext
)
}
{
parseError :: ResultToken -> Alex a
parseError (Located (SrcSpan {..}) tok) = do
alexError $ printf "unexpected token %s at line %s, column %s"
(show tok) (show srcSpanStartLine) (show srcSpanStartCol)
type Parser a = String -> Either String a
parseExpr :: Parser Expression
parseExpr = myParse rawParseExpr
parseExprCommaList :: Parser [Expression]
parseExprCommaList = myParse rawParseExprCommaList
parseImplementation :: Parser [StructureItem]
parseImplementation = myParse rawParseImplementation
parseLetBinding :: Parser LetBindings
parseLetBinding = myParse rawParseLetBinding
parseModLongident :: Parser Longident
parseModLongident = myParse rawParseModLongident
parseOpenStatement :: Parser (OpenDescription, Maybe (Loc String))
parseOpenStatement = myParse rawParseOpenStatement
parsePattern :: Parser Pattern
parsePattern = myParse rawParsePattern
parseSeqExpr :: Parser Expression
parseSeqExpr = myParse rawParseSeqExpr
parseSimpleExpr :: Parser Expression
parseSimpleExpr = myParse rawParseSimpleExpr
parseSimplePattern :: Parser Pattern
parseSimplePattern = myParse rawParseSimplePattern
parseStructure :: Parser Structure
parseStructure = myParse rawParseStructure
parseStructureItem :: Parser StructureItem
parseStructureItem = myParse rawParseStructureItem
parseValIdent :: Parser String
parseValIdent = myParse rawParseValIdent
parseValLongident :: Parser Longident
parseValLongident = myParse rawParseValLongident
myParse :: Alex a -> String -> Either String a
myParse = flip runAlex
negString :: String -> String
negString f =
if length f > 0 && f !! 0 == '-'
then tail f
else '-' : f
mkuminus :: String -> Expression -> Expression
mkuminus name arg =
case (name, pexpDesc arg) of
("-", PexpConstant (PconstInteger n m)) -> mkexp $ PexpConstant $ PconstInteger (negString n) m
("-", PexpConstant (PconstFloat f m)) -> mkexp $ PexpConstant $ PconstFloat (negString f) m
("-.", PexpConstant (PconstFloat f m)) -> mkexp $ PexpConstant $ PconstFloat (negString f) m
_ -> mkexp $ PexpApply (mkOperator ("~" ++ name) 1) [(Nolabel, arg)]
mkuplus :: String -> Expression -> Expression
mkuplus name arg =
let desc = pexpDesc arg in
case (name, desc) of
("+", PexpConstant (PconstInteger _ _)) -> mkexp desc
("+", PexpConstant (PconstFloat _ _)) -> mkexp desc
("+.", PexpConstant (PconstFloat _ _)) -> mkexp desc
_ -> mkexp $ PexpApply (mkOperator ("~" ++ name) 1) [(Nolabel, arg)]
}