Skip to content

Instantly share code, notes, and snippets.

@girvo
Forked from xavierzwirtz/Parser.fs
Created December 10, 2016 00:31
Show Gist options
  • Save girvo/389ab59fb48c988b52b6ea01e4c4c5f9 to your computer and use it in GitHub Desktop.
Save girvo/389ab59fb48c988b52b6ea01e4c4c5f9 to your computer and use it in GitHub Desktop.
module Emly.Parser
open Emly.UntypedAST
open FParsec
open FParsec.CharParsers
open Emly.ParserUtils
open Emly.ParserUtils.IndentationParserWithoutBacktracking
let keywords =
Set.ofList ["let"; "fun"; "rec"; "impure"; "in"; "of"; "if"; "then"; "else"; "match"; "with"; "type"; "foreign"; "mutable"]
let baseExpression, baseExpressionRef = createParserForwardedToRef()
let rawExpression, rawExpressionRef = createParserForwardedToRef()
let expression = (maybeIndented baseExpression false true "expression") <!> "expression"
let expressionApplied = (maybeIndented baseExpression false false "expressionApplied") <!> "expressionApplied"
let maybeIndentedSameExpression = (maybeIndented (baseExpression) true true "maybeIndentedSameExpression") <!> "maybeIndentedSameExpression"
let maybeIndentedSameExpressionApplied = (maybeIndented (baseExpression) true false "maybeIndentedSameExpression") <!> "maybeIndentedSameExpression"
let indentedSameExpression = indented (baseExpression) true "expression" <!> "indentedSameExpression"
let expressionPosition p =
startEndPosition p
|>> (fun (exp, p) -> { ExpressionType = exp
Position = p })
let number =
numberLiteral (NumberLiteralOptions.AllowHexadecimal |||
NumberLiteralOptions.AllowFraction |||
NumberLiteralOptions.AllowSuffix) "number"
|>> (fun x ->
let num value suffix =
{ Value = value
Suffix = suffix }
match x.SuffixLength with
| 0 -> num x.String None
| 1 -> num x.String (Some(new System.String([| x.SuffixChar1 |])))
| 2 -> num x.String (Some(new System.String([| x.SuffixChar1; x.SuffixChar2 |])))
| 3 -> num x.String (Some(new System.String([| x.SuffixChar1; x.SuffixChar2; x.SuffixChar3 |])))
| 4 -> num x.String (Some(new System.String([| x.SuffixChar1; x.SuffixChar2; x.SuffixChar3; x.SuffixChar4 |])))
| _ -> failwith "shouldnt get here, suffix is greater than 4 chars") <!> "number"
let numberExpression =
number |>> Number |> expressionPosition
let isIdentifierChar c = isLetter c || isDigit c || c = '_'
let isIdentFirstChar = (fun c -> isLetter c || c = '_')
let identName =
let identIncludingKeywords =
many1Satisfy2L isIdentFirstChar isIdentifierChar "identName"
(fun (stream : CharStream) ->
let state = stream.State
let reply = identIncludingKeywords stream
if reply.Status = Ok then
let ident = reply.Result
if keywords |> Set.contains ident then
stream.BacktrackTo state
Reply(Error, messageError ("'" + ident + "' cannot be used as an identifier"))
else reply
else reply)
<!> "identName"
let identPath = sepBy1 (startEndPosition identName) (pchar '.')
//let rawTypeNameL = many1Satisfy2L isLetter isIdentifierChar
let (typeP : Parser<Type, UserState>), typePRef = createParserForwardedToRef()
let typeNameArgs = between (pchar '<') (ws .>> pchar '>') (sepBy1 (ws >>. typeP) (pchar ','))
let typevar =
let name = startEndPosition (pchar ''' >>. identName)
name .>>. (opt typeNameArgs)
|>> (fun ((n, np), args) ->
let args =
match args with
| None -> []
| Some args -> args
{ TypeVariableName = "'" + n
NamePosition = np
Arguments = args })
let typeName =
let name = startEndPosition (identName)
let start = sepBy1 name (pchar '.')
start .>>. (opt typeNameArgs)
|>> (fun (path, args) ->
let args =
match args with
| None -> []
| Some args -> args
let name, path =
match path with
| [] -> failwith "should never be empty"
| [x] -> x, []
| _ ->
path |> List.last, path |> List.take(path.Length - 1)
let name, namePosition = name
{ Name = name
NamePosition = namePosition
Path = path
Arguments = args })
<!> "typeName"
<?> "type name"
do typePRef :=
let genParser =
startEndPosition typevar
|>> Generic
let nonGenParser =
startEndPosition typeName
|>> NonGeneric
let nameParser =
let betwe = between (pchar '(') (pchar ')') typeP
fun (stream : CharStream) ->
let c = stream.Peek()
if c = '(' then
betwe stream
else if c = ''' then
genParser stream
else
nonGenParser stream
let nameParser = ws >>. nameParser
let tup = tuple false (fun results _ -> TupleType results) nameParser (ws .>> pchar '*')
let func = tuple false (fun results _ -> FunType results) tup (ws .>> pstring "->")
func
let typeclassNames = sepBy1 (startEndPosition typeName) (attempt (ws .>> pchar ',' .>> ws))
let (identType : Parser<IdentType, UserState>) =
let constr =
startEndPosition (pchar ''' >>. identName)
.>> ws1 .>> pstring "of" .>> ws1
.>>. (typeclassNames <!> "constr sepBy1")
|> startEndPosition
|>> (fun (((vn, vnp), tc_names), pos) ->
{ TypeVariableName = "'" + vn
TypeVariableNamePosition = vnp
TypeClasses = tc_names
Position = pos })
<!> "constr"
// tc of 'a
// tc of 'a => 'a
// 'a
let constrs = ws >>. sepBy1 constr (attempt (ws .>> pchar ';' .>> ws)) <!> "constrs"
let afterConstr = ws1 >>. pstring "=>" >>. ws1 >>. typeP
fun (stream: CharStream) ->
// apply constraint first
let startPos = capturePosition stream
let before = stream.State
let constrsReply = constrs stream
if constrsReply.Status = Ok then
let beforeTyReply = stream.State
let tyReply = afterConstr stream
match constrsReply.Result with
| [] -> failwith "shouldnt ever be empty"
| [constr] ->
if tyReply.Status = Ok then
Reply({ Constraints = [constr]
Type = tyReply.Result
Position = { File = stream.Name
Start = startPos
End = capturePosition stream } }
|> ConstraintsAndType)
else if tyReply.Status = Error then
stream.BacktrackTo beforeTyReply
Reply(SingleConstraint constr)
else Reply(tyReply.Status, tyReply.Error)
| _ ->
if tyReply.Status = Ok then
Reply({ Constraints = constrsReply.Result
Type = tyReply.Result
Position = { File = stream.Name
Start = startPos
End = capturePosition stream } }
|> ConstraintsAndType)
else Reply(tyReply.Status, tyReply.Error)
else
stream.BacktrackTo before
let tyReply = typeP stream
if tyReply.Status = Ok then
Reply({ Constraints = []
Type = tyReply.Result
Position = { File = stream.Name
Start = startPos
End = capturePosition stream }}
|> ConstraintsAndType)
else
Reply(constrsReply.Status, mergeErrors constrsReply.Error tyReply.Error)
let operatorChars = @"!%&*+-./<=>@^|~?"
let isOperatorChar =
let set = operatorChars |> Set.ofSeq
fun c -> set.Contains c
let infixOperators = [ //".", Left, Self
"**", Right, CustomAndSelf
"*", Left, CustomAndSelf
"/", Left, CustomAndSelf
"%", Left, CustomAndSelf
"-", Left, CustomAndSelf
"+", Left, CustomAndSelf
":?", NotAssociative, Self
"::", Right, Self
"^", Right, CustomAndSelf
"!=", Left, CustomAndSelf
"<", Left, CustomAndSelf
">", Left, CustomAndSelf
"=", Left, Self
"|", Left, CustomOnly
"&", Left, CustomAndSelf
"$", Left, Self
":>", Right, Self
":?>", Right, Self
"||", Left, Self ]
// , is not parsed as an operator. it has explicit handling as the tuple char
// | is not parsed as an operator. it has explicit handling as the match case char
let illegalOperators = ["."; "<-"]
let opFirstChars =
['.'] @
(infixOperators |> List.map(fun (x, _, _) -> x.Chars(0)))
let op =
many1Satisfy2L (fun c -> opFirstChars |> List.contains c)
(fun c -> operatorChars |> Seq.contains c)
"op"
<!> "op"
let typeAnnotation =
attempt (ws >>. pchar ':') >>. identType |> startEndPosition
<!> "typeAnnotation"
let identBuilder<'ident> withT =
let ident, identRef : Parser<IdentTuple<'ident>> * ref<_> = createParserForwardedToRef()
let identNoOp, identNoOpRef : Parser<IdentTuple<'ident>> * ref<_> = createParserForwardedToRef()
let fstOp =
withT (attempt (pchar '(') >>. (startEndPosition op) .>> pchar ')')
<!> "fstOp"
let opOrIdentName =
attempt(withT ((attempt (pchar '(') >>. (startEndPosition op) .>> pchar ')'))) <|>
(attempt ident) <|> betweenParen ident
<!> "opOrIdentName"
let opOrIdentBetween =
betweenParen opOrIdentName
<!> "opOrIdentBetween"
let first =
attempt(fstOp) <|> identNoOp
<!> "first"
let identNameT = withT (startEndPosition identName)
let p =
fun (stream: CharStream) ->
let c2 = stream.Peek2()
let startPos = capturePosition stream
if c2.Char0 = '(' && c2.Char1 = ')' then
let endPos = capturePosition stream
stream.Skip(2)
Reply(IdentUnit { Start = startPos; End = endPos; File = stream.Name })
else
match c2.Char0 with
| '(' -> first stream
| x when (isIdentFirstChar x) -> identNameT stream
| _ -> Reply(Error, expected ("ident"))
let make p =
tuple true (fun x p -> IdentTuple(x, p)) p (ws .>> pchar ',') <!> "ident"
identRef := make p
identNoOpRef := betweenParen (make p)
ident
let identOfName =
let withT p =
p .>>. (opt typeAnnotation) |> startEndPosition
|>> (fun ((n, t), pos) ->
{ IdentOfName.Name = n; Type = t; Position = pos } |> IdentTuple.Ident)
identBuilder withT
<!> "identOfName"
let identOfType : Parser<IdentTuple<IdentOfType>> =
let withT p =
attempt (
p .>>. typeAnnotation |> startEndPosition
|>> (fun ((n, (t, tp)), pos) ->
{ IdentOfType.Name = Some n; Type = t; TypePosition = tp; Position = pos } |> IdentTuple.Ident))
<|>
(identType |> startEndPosition
|>> (fun (t, tp) ->
{ IdentOfType.Name = None; Type = t; TypePosition = tp; Position = tp } |> IdentTuple.Ident))
identBuilder withT
<!> "identOfType"
let identTuple (requireParensForAnnotationOrTuple : bool) ident isFirstChar just =
(if requireParensForAnnotationOrTuple then
let identBetweenParen = betweenParen ident
fun (stream: CharStream) ->
let c2 = stream.Peek2()
let startPos = capturePosition stream
if c2.Char0 = '(' && c2.Char1 = ')' then
let endPos = capturePosition stream
stream.Skip(2)
Reply(IdentUnit { Start = startPos; End = endPos; File = stream.Name })
else
match c2.Char0 with
| '(' -> identBetweenParen stream
| x when (isFirstChar x) -> just stream
| _ -> Reply(Error, expected ("ident"))
else
ident <!> "identTuple ident")
<?> "ident" <!> "identTuple"
let identTupleOfName requireParensForAnnotationOrTuple =
identTuple requireParensForAnnotationOrTuple
identOfName
isIdentFirstChar
(startEndPosition identName |>> (fun (n, np) -> IdentTuple.Ident { IdentOfName.Name = n, np; Type = None; Position = np }))
<!> "identTupleOfName"
let identTupleOfType requireParensForAnnotationOrTuple =
identTuple requireParensForAnnotationOrTuple
identOfType
(fun c -> isIdentFirstChar c || c = ''')
(startEndPosition identType |>> (fun (t, tp) -> IdentTuple.Ident { IdentOfType.Name = None; Type = t; TypePosition = tp; Position = tp }))
<!> "identTupleOfType"
let letFunArgs require1 =
let p =
if require1 then many1Indented
else manyIndented
(p (identTupleOfName true) false true "ident")
<!> "letFunArgs"
let identAndArgs =
let identOrArg =
attempt(pchar '(' >>. op .>> pchar ')') <|>
identName
<!> "identOrArg"
tuple3
(startEndPosition identOrArg)
(letFunArgs true)
(opt typeAnnotation)
|>> (fun ((name, namePosition), funArgs, ty) ->
{ IdentName = name
IdentNamePosition = namePosition
Args = funArgs
ReturnType = ty })
<!> "identAndArgs"
let letIdentNoLet =
let equal = ws1 >>. pchar '='
attempt(identTupleOfName false |>> LetIdent.Ident .>> equal) <|>
((identAndArgs |>> LetIdent.IdentAndArgs) .>> equal)
<!> "letIdentNoLet"
type LetModifiers =
| Rec
| Impure
| Mutable
let modifiers (nameAssoc : list<string * 't>) : Parser<Map<'t, StartEndPosition>> =
let nameP =
nameAssoc |> List.map(fun (s, n) ->
startEndPosition (pstring s >>. preturn (n, s)) .>> ws1 |> attempt)
|> choice
|> opt
fun stream ->
let mutable found : Map<'t, StartEndPosition> = Map.empty
let mutable cont = true
let mutable err = None
while cont do
let reply = nameP stream
if reply.Status <> Ok then
cont <- false
else
match reply.Result with
| None -> cont <- false
| Some((res, resS), resPos) ->
match found |> Map.containsKey res with
| true ->
cont <- false
err <- Some (Reply(Error, unexpected resS))
| false ->
found <- found |> Map.add res resPos
match err with
| Some x -> x
| None -> Reply found
let letIdent =
let letModifiers = modifiers ["rec", Rec
"impure", Impure
"mutable", Mutable]
(pstring "let" >>. ws1 >>. letModifiers .>>. letIdentNoLet)
let letIn = (attemptS ((ws1 <!> "ws1 in") >>. (pstring "in" <!> "pstring in") >>. maybeIndentedSameExpression) <!> "in"
<|> (ws >>. indentedSameExpression)) <!> "letIn"
let ``let`` =
tuple3
letIdent
expression
letIn
|>> (fun ((modifiers, ident), defn, body) ->
Let { Ident = ident
Definition = defn
Body = body
Impure = modifiers |> Map.tryFind Impure
Mutable = modifiers |> Map.tryFind Mutable
Rec = modifiers |> Map.tryFind Rec })
<!> "let"
|> expressionPosition
let fun_idents =
many1Indented (identTupleOfName true) false true "ident" .>> ws
<!> "fun_idents"
let ``fun`` =
tuple2
(pstring "fun" >>. ws1 >>. fun_idents)
(pstring "->" >>. expression)
|>> (fun (args, body) ->
{ Args = args
Body = body } |> Lambda)
<!> "fun"
|> expressionPosition
let ifelse =
tuple3
(pstring "if" <!> "if" >>. expression <!> "if expr")
(maybeIndented (pstring "then") true false "then" >>. expression)
(maybeIndented (pstring "else") true false "else" >>. expression)
|>> IfElse <!> "ifelse"
|> expressionPosition
let ``match`` =
let matchExpression, matchExpressionRef = createParserForwardedToRef()
let matchPosition p =
startEndPosition p
|>> (fun (m, p) -> { MatchExpressionType = m
Position = p })
let matchIdent =
let matchIdentArg = ws >>. (startEndPosition (identTupleOfName true))
typeName .>>. opt (attempt (matchIdentArg))
|>> (fun (ident, arg) ->
{ MatchIdent = ident
Argument = arg }
|> MatchIdent) |> matchPosition
<!> "matchIdent"
let matchParser =
let betwe = between (pchar '(') (pchar ')') matchExpression
let number = number |>> MatchNumber |> matchPosition
fun (stream : CharStream) ->
let c = stream.Peek()
if c = '(' then
betwe stream
else if isDigit c then
number stream
else
matchIdent stream
let matchParser = ws >>. matchParser .>> ws
let mapping results pos =
{ MatchExpressionType = MatchTuple results
Position = pos }
matchExpressionRef :=
tuple false mapping matchParser (ws .>> pchar ',')
let matchCase =
tuple2 (pchar '|' >>. ws1 >>. matchExpression)
(pstring "->" >>. expression)
|>> (fun (matchExpr, result) ->
{ MatchExpression = matchExpr
ResultExpression = result })
<!> "matchCase"
startEndPosition (pstring "match" >>. ws1 >>. expression .>> ws1 .>> pstring "with")
.>>. (many1Indented matchCase true true "match case")
|>> (fun ((value, matchPosition), cases) ->
{ Value = value
Cases = cases
MatchPosition = matchPosition })
let fixApplyPosition fst snd =
{ ExpressionType = Apply(fst, snd)
Position = { Start = fst.Position.Start
End = snd.Position.End
File = fst.Position.File } }
let rec applyChain (expressionList : Expression list) : Expression =
match expressionList with
| [] -> failwith "list had no elements, should never get here"
| [x] -> x
| [fst; snd] ->
fixApplyPosition fst snd
| fst :: snd :: tail ->
applyChain ([fixApplyPosition fst snd] @ tail)
let recordInit =
let recordMember =
tuple2
(startEndPosition typeName .>> ws .>> pchar '=' .>> ws <!> "recordMemberName")
(expression)
|>> (fun ((name, namePos), value) ->
{ MemberName = name
NamePosition = namePos
Value = value })
<!> "recordMember init"
let body =
many1Indented recordMember false true "recordInit body" <!> "recordInit body"
pchar '{' >>. body .>> (maybeIndented (pchar '}') true false "recordInit close brace")
let unit =
pstring "()"
|>> (fun _ -> Unit)
|> expressionPosition
<!> "unit"
let assign =
opt (attempt (ws >>. pstring "<-" >>. expression .>>. (opt (attempt letIn)))) <!> "assign"
let identOrAssign =
startEndPosition identName .>>. assign
|>> (fun ((name, namePos), assign) ->
match assign with
| None ->
{ ExpressionType = Ident name
Position = namePos }
| Some (defn, body) ->
let assign =
{ AssignTarget = AssignIdent { Ident = name
IdentPosition = namePos }
Definition = defn
Body = body }
{ ExpressionType = Assign assign
Position = namePos })
let expressionChooser =
let recordInit = recordInit |>> RecordInit |> expressionPosition
let ``match`` = ``match`` |>> Match |> expressionPosition
let stringLiteral = stringLiteral |>> StringLiteral |> expressionPosition
fun (stream: CharStream<UserState>) ->
if stream.IsEndOfStream then
Reply(Error, expected ("expression"))
else
match stream.Peek() with
| ')' -> Reply(Error, expected ("expression"))
| '"' -> stringLiteral stream
| _ ->
let next3 = stream.PeekString 3
match next3 with
| "let" ->
let fourth = stream.Peek(3)
if isIdentifierChar fourth then
identOrAssign stream
else
``let`` stream
| "fun" ->
let fourth = stream.Peek(3)
if isIdentifierChar fourth then
identOrAssign stream
else
``fun`` stream
| "mat" ->
let sixth = stream.Peek(5)
if isIdentifierChar sixth then
identOrAssign stream
else
``match`` stream
| _ ->
if next3.StartsWith "{" then
recordInit stream
else if next3.StartsWith "if" then
if next3.Length = 3 then
let thrd = next3.Chars 2
if isIdentifierChar thrd then
identOrAssign stream
else
ifelse stream
else
ifelse stream
else
if next3.Chars 0 |> isDigit then
numberExpression stream
else
identOrAssign stream
do rawExpressionRef := (
let betweenParen =
let term =
startEndPosition (many1Satisfy (isOperatorChar)) |>> (fun (n, p) ->
{ ExpressionType = Ident n
Position = p }) .>> ((pchar ')') <!> "close paren") |> attempt <|>
(maybeIndentedSameExpressionApplied .>> ws .>> (maybeIndented (pchar ')') true false ")" <!> "close paren") )
((pchar '(' .>> ws <!> "open paren") >>. (term)) <!> "between parens"
let expressionF elsee =
fun (stream: CharStream<UserState>) ->
let nextTwo = stream.Peek2()
if nextTwo.Char0 = '(' && nextTwo.Char1 = ')' then
unit stream
else if nextTwo.Char0 = '(' then
betweenParen stream
else
elsee stream
let highPrecedence = (expressionF (fun _ -> Reply(Error, expected "(")))
let highPrecedence =
attempt(ws >>. (maybeIndented highPrecedence false false "apply snd"))
<!> "highPrecedence"
let membAcc =
(ws >>. maybeIndented (startEndPosition (pchar '.') <!> "membAcc dot") false false "apply snd" <!> "membAcc indented dot") .>>. (maybeIndented (startEndPosition identName) false false "membAcc" <!> "membAcc ident")
<!> "membAcc"
let lowPrecedence =
let expressionJustMember =
tuple2
(expressionF expressionChooser)
(opt (attempt membAcc))
|> startEndPosition
|>> (fun ((fst, memb), pos) ->
match memb with
| None -> fst
| Some ((_, opPos), (memb, membPos)) ->
let memb =
{ DotPosition = opPos
Expression = fst
MemberName = memb
MemberPosition = membPos }
{ ExpressionType = MemberAccess memb
Position = pos })
<!> "expressionJustMember"
attempt(ws >>. (maybeIndented (expressionF expressionJustMember) false false "apply snd"))
<!> "lowPrecedence"
|> many
let apply =
unit <|>
(between (pchar '(' .>> ws <!> "open paren")
(maybeIndented (pchar ')') true false ")" <!> "close paren")
(maybeIndentedSameExpression .>> ws)) <!> "between parens"
let identName = (maybeIndented identName true false "identName")
let membrName = ws >>. (startEndPosition identName) <!> "membrName"
let membr =
membrName .>>. manyIndented apply false true "apply"
<!> "membr"
let dot =
let dot = startEndPosition (pchar '.')
(maybeIndented dot true false ".") |> attempt
<!> "dot"
let chain = many (dot .>>. membr) <!> "chain"
// let chainAssign =
// tuple4
// chain dot membrName assign
// <!> "chainAssign"
let splitOnApply (chain : ((char * StartEndPosition) * ((string * StartEndPosition) * Expression list)) list) =
let head, (tail, tailApplies) =
chain
|> List.fold(fun (before, (current, _last)) (op, (name, applies)) ->
match applies with
| [] ->
before, (current @ [op, name], None)
| applies ->
before @ [current @ [op, name], Some applies], ([], None)) ([], ([], None))
head @ [tail, tailApplies]
let assignOrJustMembers : Parser<Choice<(((char * StartEndPosition) * ((string * StartEndPosition) * Expression list)) list * (char * StartEndPosition) * (string * StartEndPosition) * (Expression * Expression option)),(((char * StartEndPosition) * ((string * StartEndPosition) * Expression list)) list * Expression list option)>,UserState> =
let lowPrecedence = (opt (attempt lowPrecedence))
fun (stream : CharStream) ->
let chainReply = chain stream
if chainReply.Status <> Ok then
Reply(chainReply.Status, chainReply.Error)
else
let chainResult = chainReply.Result
let other () =
let lowPrecedenceReply = lowPrecedence stream
Reply(Choice2Of2 (chainResult, lowPrecedenceReply.Result))
if chainResult |> List.isEmpty then other()
else
let lastDot, (lastMembName, lastApplies) = chainResult |> List.last
if lastApplies |> List.isEmpty then
let assignReply = assign stream
match assignReply.Result with
| Some assignResult ->
let x = (chainResult |> List.take(chainResult.Length - 1)), lastDot, lastMembName, assignResult
Reply(Choice1Of2(x))
| None -> other()
else other()
// (chainAssign |>> Choice1Of2) <|>
// ((chain .>>. (opt (attempt lowPrecedence))) |>> Choice2Of2 )
let applyMembers fst members =
if members |> List.isEmpty then fst
else
let result =
members
|> splitOnApply
|> List.fold(fun (parent) (chain, applies) ->
let membrChain =
chain
|> List.fold(fun (parent) ((_, opPos), (name, namePos)) ->
let parent =
match parent with
| None -> fst
| Some parent -> parent
let memb =
{ DotPosition = opPos
Expression = parent
MemberName = name
MemberPosition = namePos }
{ ExpressionType = MemberAccess memb
Position = { Start = parent.Position.Start
End = namePos.End
File = parent.Position.File }}
|> Some) parent
match applies with
| None -> membrChain
| Some applies ->
applies
|> List.fold(fun parent item ->
{ ExpressionType = Apply(parent, item)
Position = { Start = parent.Position.Start
End = item.Position.End
File = parent.Position.File } }) membrChain.Value
|> Some) (None)
result.Value
let rawExpressionRes =
tuple3
(expressionF expressionChooser <!> "rawExpression fst")
(many highPrecedence)
(opt (attempt assignOrJustMembers))
|>> (fun (fst, (highPrecedence), memberAssignOrMembersAndLow) ->
let fst =
match highPrecedence with
| [] ->
fst
| _ ->
applyChain ([fst] @ highPrecedence)
let fst =
match memberAssignOrMembersAndLow with
| None -> fst
| Some memberAssignOrMembersAndLow ->
match memberAssignOrMembersAndLow with
| Choice1Of2 (members, (_, finalDotPos), (finalMember, finalMemberPos), (assign_defn, assign_body)) ->
let membersResult = applyMembers fst members
let membAccess =
{ DotPosition = finalDotPos
Expression = membersResult
MemberName = finalMember
MemberPosition = finalMemberPos }
let assign =
{ AssignTarget = AssignMember membAccess
Definition = assign_defn
Body = assign_body }
|> Assign
let endPos =
match assign_body with
| None -> assign_defn.Position.End
| Some body -> body.Position.End
{ ExpressionType = assign
Position = { Start = fst.Position.Start
End = endPos
File = fst.Position.File } }
| Choice2Of2 (members, low) ->
let fst = applyMembers fst members
match low with
| None -> fst
| Some rest -> applyChain ([fst] @ rest)
fst)
<!> "rawExpression"
rawExpressionRes)
let expressionOperator =
operator true (rawExpression) operatorChars infixOperators illegalOperators (fun x ->
let t, pos =
match x with
| InfixResult (op, opPos, fst, snd) ->
ApplyInfixOperator (op, opPos, fst, snd),
{ Start = fst.Position.Start
End = snd.Position.End
File = fst.Position.File }
| PrefixResult (op, opPos, exp) ->
ApplyPrefixOperator (op, opPos, exp),
{ Start = opPos.Start
End = exp.Position.End
File = opPos.File }
{ ExpressionType = t
Position = pos } )
<!> "expressionOperator"
let tupledExpression =
let mapping results pos =
{ ExpressionType = TupleExpression(results)
Position = pos }
tuple true mapping (expressionOperator) (pchar ',')
<!> "tupledExpression"
let unboundExpression =
(tupledExpression <!> "unboundExpression fst") .>>. opt (attempt (indentedSameExpression <!> "unboundExpression snd"))
|> startEndPosition
<!> "unboundExpression"
|>> (fun ((fst, snd), pos) ->
match snd with
| None -> fst
| Some snd ->
{ ExpressionType = Unbound { Unbound = fst
Body = snd }
Position = pos })
do baseExpressionRef := unboundExpression
let ``module``, moduleRef = createParserForwardedToRef()
let moduleLet =
letIdent .>>. expression
|>> (fun ((modifiers, ident), defn) ->
{ Ident = ident
Definition = defn
Impure = modifiers |> Map.tryFind Impure
Mutable = modifiers |> Map.tryFind Mutable
Rec = modifiers |> Map.tryFind Rec}
|> ModuleLet)
<!> "moduleLet"
type ForeignModifiers =
| ForeignImpure
| ForeignMutable
let moduleOpen =
pstring "open" >>. ws1 >>. identPath
|>> (fun path ->
{ OpenPath = path } |> ModuleOpen)
let typeArguments =
let typeArgument =
startEndPosition(pchar ''' >>. identName <?> "type constraint")
.>>. opt (attempt (ws1 .>> pstring "of" .>> ws1 >>. typeclassNames))
|>> (fun ((n, p), typeclasses) ->
let typeclasses =
match typeclasses with
| None -> []
| Some x -> x
{ TypeArgumentName = "'" + n
NamePosition = p
TypeClasses = typeclasses })
pchar '<' >>. (sepBy1 (ws >>. typeArgument .>> ws) (pchar ',')) .>> pchar '>' .>> ws
|> opt
type RecordModifiers =
| RecordMutable
let memberP mods =
tuple3
(modifiers mods)
(startEndPosition identName .>> ws .>> pchar ':' .>> ws1)
(startEndPosition identType)
let typeMember =
memberP ["mutable", RecordMutable]
<!> "typeMember"
|>> (fun (modifiers, (memberName, memberNamePosition), (ty, tyPosition)) ->
{ TypeMemberName = memberName
NamePosition = memberNamePosition
Type = ty
TypePosition = tyPosition
Mutable = modifiers |> Map.tryFind RecordMutable })
let recordMembers requireMembers =
let members =
if requireMembers then many1Indented
else manyIndented
((between (maybeIndented (pchar '{') false false "{" .>> ws <!> "open curly")
(maybeIndented (pchar '}') true false "}" <!> "close curly")
(members typeMember false true "recordMember")) <!> "between curly")
let unionMembers =
let unionMember =
pchar '|' >>. ws1 >>.
(startEndPosition identName) .>>.
opt (ws1 >>. pstring "of" .>> ws1 >>. (startEndPosition identType))
|>> (fun (((name, namePosition), ty)) ->
{ UnionCaseName = name
NamePosition = namePosition
Type = ty })
<!> "unionMember"
(many1Indented unionMember true true "unionMember")
let recordStart =
tuple3
(pstring "type" >>. ws1 >>. (startEndPosition identName) .>> ws)
(typeArguments .>> pchar '=' .>> ws)
(maybeIndented (preturn ()) true false "open" .>> ws)
<!> "recordStart"
let recordOrUnion =
fun (stream: CharStream<UserState>) ->
let startReply = recordStart stream
if startReply.Status <> Ok then
Reply(startReply.Status, startReply.Error)
else
let (recName, recNamePosition), typeArguments, _ = startReply.Result
let typeArguments =
match typeArguments with
| None -> []
| Some x -> x
let openChar = stream.Peek()
match openChar with
| '{' ->
let reply = recordMembers true stream
if reply.Status <> Ok then
Reply(reply.Status, reply.Error)
else
let recordMembers = reply.Result
Reply(Record { RecordName = recName
TypeArguments = typeArguments
NamePosition = recNamePosition
RecordMembers = recordMembers })
| '|' ->
let reply = unionMembers stream
if reply.Status <> Ok then
Reply(reply.Status, reply.Error)
else
let unionCases = reply.Result
Reply(Union { UnionName = recName
TypeArguments = typeArguments
NamePosition = recNamePosition
UnionCases = unionCases })
| _ ->
Reply(Error, expected ("{ or |"))
let foreign =
let modifiers = modifiers ["impure", ForeignImpure
"mutable", ForeignMutable]
tuple4
(modifiers)
(startEndPosition identName)
(letFunArgs false)
(ws >>. pchar ':' >>. ws >>. (startEndPosition identType))
|>> (fun (modifiers, (name, namePos), args, (ty, tyPos)) ->
{ ForeignName = name
NamePosition = namePos
Args = args
Type = ty
TypePosition = tyPos
Impure = modifiers |> Map.tryFind ForeignImpure
Mutable = modifiers |> Map.tryFind ForeignMutable }
|> Foreign)
type ForeignTypeMethodModifiers =
| ForeignTypeMethodImpure
let foreignTypeMethods =
let methodd =
memberP ["impure", ForeignTypeMethodImpure]
<!> "foreignTypeMethod"
|>> (fun (modifiers, (memberName, memberNamePosition), (ty, tyPosition)) ->
{ ForeignTypeMethodName = memberName
NamePosition = memberNamePosition
Type = ty
TypePosition = tyPosition
Impure = modifiers |> Map.tryFind ForeignTypeMethodImpure })
attempt (indented (pstring "with") true "with")
>>. (many1Indented methodd false true "foreignTypeMethod")
let foreignType =
tuple3
recordStart
(recordMembers false)
(opt foreignTypeMethods)
|>> (fun (((recName, recNamePosition), typeArguments, _), members, methods) ->
let typeArguments =
match typeArguments with
| None -> []
| Some x -> x
let methods =
match methods with
| None -> []
| Some x -> x
{ ForeignTypeName = recName
TypeArguments = typeArguments
NamePosition = recNamePosition
Members = members
Methods = methods }
|> ForeignType)
let foreignOrForeignType =
pstring "foreign" >>. ws1 >>.
fun (stream: CharStream<UserState>) ->
let next4 = stream.PeekString(4)
if next4 = "type" then
foreignType stream
else
foreign stream
let typeClassStart name nameParser ofParser =
tuple3
(pstring name >>. ws1 >>. nameParser .>> ws)
(pstring "of" >>. ws1 >>. ofParser .>> ws1 .>> pchar '=' .>> ws)
(maybeIndented (preturn ()) true false "open" .>> ws)
<!> (name + " start")
let typeclassMemberType =
sepBy1
(identTupleOfType true)
(attempt (ws1 .>> pstring "->" .>> ws1))
<!> "typeclassMemberType"
let typeclassMember =
tuple2
(startEndPosition identName .>> ws1 .>> pchar ':' .>> ws1)
(startEndPosition typeclassMemberType)
<!> "typeclassMember"
|>> (fun ((memberName, memberNamePosition), (ty, tyPosition)) ->
{ TypeclassMemberName = memberName
NamePosition = memberNamePosition
Type = ty
TypePosition = tyPosition })
let typeclass =
let start = typeClassStart "typeclass" (startEndPosition (identName <!> "typeclass name")) (startEndPosition typeP)
let members = (many1Indented typeclassMember false true "typeclass member")
start .>>. members
|>> (fun (((name, namePosition), (ty, tyPosition), _), members) ->
{ TypeClassName = name
NamePosition = namePosition
Of = ty
OfPosition = tyPosition
TypeClassMembers = members }
|> TypeClass)
let typeclassInstance =
let start = typeClassStart "instance" identPath (startEndPosition typeName)
let instanceIdent =
(attempt (identAndArgs |>> InstanceIdentAndArgs)) <|>
((startEndPosition identName) |>> InstanceIdent)
let instanceMember =
tuple2
(startEndPosition instanceIdent .>> ws1 .>> pchar '=')
expression
|> startEndPosition
<!> "instanceMember"
|>> (fun (((ident, memberNamePosition), expression), pos) ->
{ TypeClassInstanceMemberIdent = ident
NamePosition = memberNamePosition
Position = pos
Expression = expression })
let members = (many1Indented instanceMember false true "instance member")
start .>>. members
|>> (fun ((name, (ty, tyPosition), _), members) ->
{ TypeClassInstanceName = name
Of = ty
OfPosition = tyPosition
TypeClassInstanceMembers = members }
|> TypeClassInstance)
let rawModuleMember =
let subModule = (``module`` |>> Module) <!> "subModule"
fun (stream: CharStream<UserState>) ->
if stream.IsEndOfStream then
Reply(Error, expected ("moduleMember"))
else
match stream.Peek() with
| ')' -> Reply(Error, expected ("moduleMember"))
| _ ->
match stream.PeekString 3 with
| "typ" ->
if stream.PeekString 5 = "typec" then
typeclass stream
else
recordOrUnion stream
| "ins" ->
typeclassInstance stream
| "let" -> moduleLet stream
| "mod" -> subModule stream
| "ope" -> moduleOpen stream
| "for" -> foreignOrForeignType stream
| _ -> Reply(Error, expected ("moduleMember"))
// need to change this to a parser that checks for = and adjusts indentation rules
let rawModule =
tuple2
(pstring "module" >>. ws1 >>. (startEndPosition identName) .>> ws .>> opt(pchar '=' >>. ws))
(many1Indented (startEndPosition rawModuleMember) true false "moduleMember" <!> "many1Indented moduleMember")
|>> (fun ((n, p), members) ->
{ ModuleName = n
NamePosition = p
ModuleMembers =
members |> List.map(fun (membr, position) ->
{ ModuleMemberType = membr
Position = position } ) })
do ``moduleRef`` := rawModule <!> "module"
let rootModule =
maybeIndented rawModule false false "rootModule" <!> "rootModule"
let spacesOrComments : Parser<unit,'u> =
fun stream ->
let mutable skip = true
while skip do
stream.SkipWhitespace() |> ignore
if stream.IsEndOfStream then
skip <- false
else
if stream.Peek2() = TwoChars('/', '/') then
stream.SkipRestOfLine(true)
else
skip <- false
Reply(())
let document p = p .>> spacesOrComments .>> eof <!> "document"
let documentExpression = document expression
let documentRootModule = document rootModule
let run p streamName str = runParserOnString p (UserState.Create()) streamName str
module Emly.ParserUtils
open Emly.UntypedAST
open FParsec
open FParsec.CharParsers
type Identifier = string
let mutable logIdent = 0
let offsetString firstOffset offset count (value : string) =
let offset = String.replicate (offset * count) " "
let value =
value.Split([| "\r\n"; "\n" |], System.StringSplitOptions.None)
|> Seq.mapi(fun i x ->
if i = 0 then
x
else
offset + x)
|> String.concat "\n"
if firstOffset then offset + value else value
let printfn format =
Printf.kprintf (fun x ->
printfn "%s" (offsetString true logIdent 2 x)) format
let debug = false
let debugShowResult = true
let (<!>) (p: Parser<_,_>) label : Parser<_,_> =
if not debug then
p
else
fun stream ->
logIdent <- (logIdent + 1)
printfn "%A: Entering %s" stream.Position label
let t = System.Diagnostics.Stopwatch()
t.Start()
let reply = p stream
t.Stop()
let status =
if reply.Status = Ok then
"Ok ("
else
sprintf "%A" reply.Status
let before = sprintf "%A: Leaving %s, time %i, (%s" stream.Position label t.ElapsedMilliseconds status
let res =
if reply.Status = Ok && debugShowResult then
sprintf "%s)" (offsetString false before.Length 1 (sprintf "%A" reply.Result))
else
if debugShowResult then
")"
else
"))"
printfn "%s%s" before res
logIdent <- (logIdent - 1)
reply
let tabError = messageError "Tab characters are not allowed. Use spaces for indentation"
let isBlank = fun c -> c = ' '
//pulled from the fparsec source, and modified to not report errors when backtracking
let attemptS (p: Parser<'a,'u>) : Parser<'a,'u> =
(fun stream ->
// state is only declared mutable so it can be passed by ref, it won't be mutated
let mutable state = CharStreamState(stream)
let mutable reply = p stream
if reply.Status <> Ok then
if state.Tag <> stream.StateTag then
stream.BacktrackTo(&state) // passed by ref as a (slight) optimization
elif reply.Status = FatalError then
reply.Status <- Error
reply)
<!> "attemptS"
let capturePosition (stream: CharStream<'UserState>) =
{ ColumnNo = stream.Position.Column
LineNo = stream.Position.Line }
let startEndPosition (parser : Parser<'Result,'UserState>) : Parser<'Result * UntypedAST.StartEndPosition,'UserState> =
let toPos (pos : Position) =
{ ColumnNo = pos.Column
LineNo = pos.Line }
fun (stream: CharStream<'UserState>) ->
let start = stream.Position
let reply = parser stream
if reply.Status = Ok then
let endPos = stream.Position
let res = (reply.Result, { Start = start |> toPos
End = endPos |> toPos
File = stream.Name })
Reply(res)
else
Reply(reply.Status, reply.Error)
module IndentationParserWithoutBacktracking =
type SkipIndentationResult =
| FoundTab
| Indent of int64
| IndentNoNewline of int64
type SkipIndentationOnlyNewLinesResult =
| FoundTabResult
| NewLineIndent of int64
| NoIndent
type LastParsedIndentation() =
[<DefaultValue>]
val mutable Value: SkipIndentationResult
[<DefaultValue>]
val mutable EndIndex: int64
type UserState =
{ Indentation: int64
FirstLine : bool
// We put LastParsedIndentation into the UserState so that we
// can conveniently use a separate instance for each stream.
// The members of the LastParsedIndentation instance will be mutated
// directly and hence won't be affected by any stream backtracking.
LastParsedIndentation: LastParsedIndentation}
with
static member Create() = { Indentation = -1L
FirstLine = true
LastParsedIndentation = LastParsedIndentation(EndIndex = -1L)}
type CharStream = CharStream<UserState>
type Parser<'t> = Parser<'t, UserState>
let ws : Parser<unit, UserState> = skipManySatisfy isBlank <?> "whitespace" <!> "whitespace"
let ws1 : Parser<unit, UserState> = skipMany1SatisfyL isBlank "whitespace" <!> "whitespace"
let betweenParen p : Parser<'t, UserState> =
between (pchar '(' >>. ws <!> "paren open")
(ws .>> pchar ')' <!> "paren close")
p
let betweenParenAttempt p : Parser<'t, UserState> =
between (attempt(pchar '(' >>. ws) <!> "paren open")
(ws .>> pchar ')' <!> "paren close")
p
let skipIndentationInternal (stream: CharStream) =
let mutable read = true
let mutable indentation = 0L
let mutable hitNl = false
let mutable hitTab = false
while read do
let nextChar = stream.Peek()
let mutable wasNl = false
let mutable wasRlNl = false
match nextChar with
| ' ' -> indentation <- indentation + 1L
| '\t' ->
hitTab <- true
read <- false
| '\n' ->
indentation <- 0L
hitNl <- true
wasNl <- true
| '\r' ->
if stream.Peek(1) = '\n' then
indentation <- 0L
hitNl <- true
wasRlNl <- true
else
read <- false
| _ -> read <- false
if read then
if wasRlNl then
stream.Skip(2)
else
stream.Skip()
if wasNl || wasRlNl then stream.RegisterNewline() |> ignore
if hitTab then
FoundTab
else if hitNl then
Indent indentation
else
IndentNoNewline indentation
// If this function is called at the same index in the stream
// where the function previously stopped, then the previously
// returned indentation will be returned again.
// This way we can avoid backtracking at the end of indented blocks.
let skipIndentation (stream: CharStream) : SkipIndentationResult =
let lastParsedIndentation = stream.UserState.LastParsedIndentation
if lastParsedIndentation.EndIndex = stream.Index then
lastParsedIndentation.Value
else
let mutable indentation = skipIndentationInternal stream
while stream.Peek2() = TwoChars('/', '/') do
stream.SkipRestOfLine(false) // skip comment
indentation <- skipIndentationInternal stream
lastParsedIndentation.EndIndex <- stream.Index
lastParsedIndentation.Value <- indentation
indentation
let skipIndentationOnlyNewLines (stream: CharStream) : SkipIndentationOnlyNewLinesResult =
let skipIndentation (stream: CharStream) =
let state = stream.State
let res = skipIndentationInternal stream
match res with
| IndentNoNewline _ ->
stream.BacktrackTo state
NoIndent
| Indent x -> NewLineIndent x
| FoundTab -> FoundTabResult
let mutable indentation = skipIndentation stream
// while stream.Peek2() = TwoChars('/', '/') do
// stream.SkipRestOfLine(false) // skip comment
// indentation <- skipIndentation stream
indentation
let private indentedInternal (p: Parser<'t>) allowSameIndentation
allowNoNewLine
resetIndentation
indentNoNewLineSetsIndentation
badIndentationBacktrack
backtrackOnFail
label : Parser<'t> =
(fun (stream : CharStream<UserState>) ->
let startState = stream.State
let firstLine = stream.UserState.FirstLine
let oldIndentation = stream.UserState.Indentation
let indentation = skipIndentation stream
// printfn "firstLine %A" firstLine
// printfn "indentation %A" indentation
// printfn "oldIndentation %i" oldIndentation
// printfn "allowSameIndentation %A" allowSameIndentation
// printfn "allowNoNewLine %A" allowNoNewLine
let indentationValue =
match indentation with
| Indent x -> Choice1Of2 x
| IndentNoNewline x ->
if indentNoNewLineSetsIndentation then
stream.Column - 1L
else
if firstLine then x
else oldIndentation
|> Choice1Of2
| FoundTab -> Choice2Of2()
// printfn "bad %A" bad
match indentationValue with
| Choice2Of2 () ->
Reply(Error, tabError)
| Choice1Of2 indentationValue ->
let bad =
let bad()=
if allowSameIndentation then
indentationValue < oldIndentation
else
indentationValue <= oldIndentation
match allowNoNewLine, indentation with
| true, indentation ->
match indentation with
| IndentNoNewline _ -> false
| Indent _ -> bad()
| FoundTab -> failwith "shouldnt get here"
| false, _ -> bad()
let indentation = indentationValue
if bad then
if badIndentationBacktrack then
stream.BacktrackTo(startState)
Reply(Error, expected (if indentation < 0L then "newline" else "indented " + label))
else
stream.UserState <- { stream.UserState with Indentation = indentation
FirstLine = false }
let stateTag = stream.StateTag
let reply =
p stream
if reply.Status = Ok then
if resetIndentation then
stream.UserState <- { stream.UserState with Indentation = oldIndentation }
Reply(reply.Result)
else // p failed
if stateTag = stream.StateTag && backtrackOnFail then
stream.BacktrackTo(startState)
Reply(reply.Status, reply.Error))
<!> "indented"
let private manyIndentedInternal (p: Parser<'t>) require1 allowSameIndentation allowNoNewLine label : Parser<'t list> =
let fstp = indentedInternal p allowSameIndentation allowNoNewLine false true true false label <!> "manyIndentedInternal first"
let manyp = indentedInternal p true allowNoNewLine false true true false label <!> "manyIndentedInternal nth"
fun (stream : CharStream<UserState>) ->
let state = stream.State
let beforeIndentation = stream.UserState.Indentation
let fstReply = fstp stream
if fstReply.Status = Ok then
let itemIndentation = stream.UserState.Indentation
// printfn "itemIndentation %A" itemIndentation
let mutable run = true
let mutable results = [fstReply.Result]
let mutable stateTag = stream.StateTag
let mutable error = None
while run do
let state = stream.State
let reply = manyp stream
if reply.Status = Ok then
stream.UserState <- { stream.UserState with Indentation = itemIndentation }
stateTag <- stream.StateTag
results <- results @ [reply.Result]
else
stream.BacktrackTo state
if stateTag <> stream.StateTag then
error <- Some (reply.Status, reply.Error)
run <- false
stream.UserState <- { stream.UserState with Indentation = beforeIndentation }
match error with
| None -> Reply(results)
| Some (status, error) -> Reply(status, error)
else
if require1 then
Reply(Error, fstReply.Error)
else
stream.BacktrackTo state
Reply []
let indented p allowSameIndentation label : Parser<'t> =
indentedInternal p allowSameIndentation false true false false true label
let maybeIndented p allowSameIndentation indentNoNewLineSetsIndentation label : Parser<'t> =
indentedInternal p allowSameIndentation true true indentNoNewLineSetsIndentation false true label
<!> "maybeIndented"
let manyIndented p allowSameIndentation allowNoNewLine label =
manyIndentedInternal p false allowSameIndentation allowNoNewLine label
<!> "manyIndented"
let many1Indented p allowSameIndentation allowNoNewLine label =
manyIndentedInternal p true allowSameIndentation allowNoNewLine label
<!> "many1Indented"
type Associativity =
| NotAssociative
| Left
| Right
type UseType =
| CustomOnly
| CustomAndSelf
| Self
type Operator =
{ Prefix : string
Associativity : Associativity
UseType : UseType}
type OperatorResult<'t> =
| InfixResult of string * StartEndPosition * 't * 't
| PrefixResult of string * StartEndPosition * 't
type InfixState =
| Good
| Stop
| NoExpressionAfter
type private WorkingOperator =
{ Operator : string
Associativity : Associativity
Priority : int }
let private left mapping workingOp state =
let append state x =
state @ [x]
state
|> List.fold(fun state x ->
match x with
| Choice2Of2 _ -> append state x
| Choice1Of2 (op, res : 't) ->
match op with
| None -> state @ [Choice2Of2 res]
| Some (op, opPos) ->
if workingOp <> op then
append state x
else
let prev =
state |> List.last
let fix (prev : 't) =
mapping (InfixResult (op.Operator, opPos, prev, res))
let prev =
match prev with
| Choice1Of2 (x, y) -> Choice1Of2 (x, fix y)
| Choice2Of2 x -> Choice2Of2 (fix x)
let state =
state |> List.take (state.Length - 1)
append state prev) []
let private right mapping workingOp state =
let append state x =
[x] @ state
let _, state =
state
|> List.rev
|> List.fold(fun (ahead, state) x ->
match x with
| Choice2Of2 before ->
match ahead with
| None -> None, append state (Choice2Of2 before)
| Some ((op, opPos), ahead) ->
let n = mapping (InfixResult (op.Operator, opPos, before, ahead))
None, append state (Choice2Of2 n)
| Choice1Of2 (op, before : 't) ->
match op with
| None ->
match ahead with
| None -> None, append state x
| Some ((ahop, ahopPos), ahead) ->
let n = mapping (InfixResult (ahop.Operator, ahopPos, before, ahead))
None, append state (Choice2Of2 n)
| Some (op, opPos) ->
if workingOp <> op then
match ahead with
| None -> None, append state x
| Some ((ahop, ahopPos), ahead) ->
let n = mapping (InfixResult (ahop.Operator, ahopPos, before, ahead))
None, append state (Choice1Of2 (Some (op, opPos), n))
else
let this =
match ahead with
| None -> before
| Some ((op, opPos), ahead) ->
mapping (InfixResult (op.Operator, opPos, before, ahead))
Some((op, opPos), this), state) (None, [])
state
let operator indented
(termParser : Parser<'t>)
(operatorChars : System.Char seq)
(infixOperators : list<string * Associativity * UseType>)
illegalOperators
(mapping : OperatorResult<'t> -> 't) =
let illegalOperators = Set.ofList illegalOperators
let isOperatorChar c =
operatorChars |> Seq.contains c
let infixOperators =
infixOperators
|> List.mapi(fun i (p, assoc, allow) -> p, assoc, i, allow)
let infixParser =
let longest =
infixOperators
|> List.map(fun (x, _, _, _) -> x.Length)
|> List.sortDescending
|> List.head
fun (stream : CharStream<UserState>) ->
let peek = stream.PeekString(longest)
match infixOperators |> List.tryFind(fun (x, _, _, _) ->
peek.StartsWith(x)) with
| None -> Reply(Error, expected "an operator char")
| Some (prefix, assoc, priority, useType) ->
stream.Skip(prefix.Length) |> ignore
let getRest() =
let mutable chars = List.empty<char>
let mutable nextChar = stream.Peek()
while isOperatorChar nextChar do
stream.Skip 1
chars <- chars @ [nextChar]
nextChar <- stream.Peek()
chars
let good rest =
let op = prefix + System.String(rest |> List.toArray)
if illegalOperators |> Set.contains op then
Reply(Error, messageError (op + " is not a valid operator"))
else
let res =
{ Operator = op
Associativity = assoc
Priority = priority }
Reply(res)
match useType with
| CustomOnly ->
let rest = getRest()
if rest = [] then
Reply(Error, expected (prefix + " is only allowed as the start of an operator, expected more operator chars"))
else
good rest
| CustomAndSelf ->
getRest()
|> good
| Self ->
let rest = getRest()
if rest <> [] then
Reply(Error, unexpected (prefix + " is not allowed as the start of a custom operator"))
else
good rest
let termParser =
let termAndPrefixParser, termAndPrefixParserRef = createParserForwardedToRef()
let indentedTermAndPrefixParser =
if indented then
maybeIndented (termAndPrefixParser) false false "maybeIndentedTermAndPrefixParser"
else
termAndPrefixParser
let p =
fun (stream : CharStream<UserState>) ->
let opStartPos = capturePosition stream
let first = stream.Peek()
if isOperatorChar first |> not then
termParser stream
else
let mutable chars = [first]
stream.Skip 1
let mutable nextChar = stream.Peek()
while isOperatorChar nextChar do
chars <- chars @ [nextChar]
stream.Skip 1
nextChar <- stream.Peek()
let opEndPos = capturePosition stream
let prefix = System.String(chars |> List.toArray)
let termReply = indentedTermAndPrefixParser stream
if termReply.Status <> Ok then
termReply
else
if illegalOperators |> Set.contains prefix then
Reply(Error, messageError (prefix + " is not a valid operator"))
else
Reply(mapping(PrefixResult(prefix,
{ Start = opStartPos
End = opEndPos
File = stream.Name },
termReply.Result)))
termAndPrefixParserRef := p
p
let firstTermParser = termParser
let termParser =
if indented then
maybeIndented (termParser) false false "maybeIndentedTermParser"
else
termParser
let infixParser = startEndPosition infixParser
let infixParser =
if indented then
maybeIndented (infixParser) true false "maybeIndentedInfixOperator"
else
infixParser
fun (stream : CharStream<UserState>) ->
let fstReply = firstTermParser stream
if fstReply.Status <> Ok then
fstReply
else
let mutable results : list<option<((WorkingOperator) * StartEndPosition)> * 't> =
[None, fstReply.Result]
let mutable operators = Set.empty
let mutable status = Good
while status = Good do
let beforeInfix = stream.State
let infixReply = infixParser stream
if infixReply.Status <> Ok then
stream.BacktrackTo beforeInfix
status <- Stop
else
let termReply = termParser stream
if termReply.Status <> Ok then
status <- NoExpressionAfter
else
operators <- operators |> Set.add (fst infixReply.Result)
results <- results @ [ Some infixReply.Result, termReply.Result ]
match status with
| NoExpressionAfter ->
Reply(Error, expected "expression following operator")
| _ ->
if results.Length = 1 then
Reply(fstReply.Result)
else
let results = results |> List.map Choice1Of2
let results =
operators
|> Set.toList
|> List.sortBy(fun x -> x.Priority)
|> List.fold(fun state workingOp ->
let state =
match workingOp.Associativity with
| NotAssociative | Left -> left mapping workingOp state
| Right -> right mapping workingOp state
state) results
let res =
match results |> List.exactlyOne with
| Choice2Of2 x -> x
| Choice1Of2 _ -> failwith "shouldnt get here"
Reply(res)
let tuple indented mapping (p : Parser<'t>) sep =
let tupleParser =
if indented then
maybeIndented sep true false "tuple"
else
sep
let followingExpression =
if indented then
maybeIndented (p) true false "expression"
else
p
(fun (stream: CharStream<UserState>) ->
let startPos = capturePosition stream
let fst = p stream
if fst.Status <> Ok then
fst
else
let mutable results : list<'t> = []
let mutable status = Good
while status = Good do
let beforeTuple = stream.State
let tupleReply = tupleParser stream
if tupleReply.Status <> Ok then
stream.BacktrackTo beforeTuple
status <- Stop
else
let expressionReply = followingExpression stream
if expressionReply.Status <> Ok then
status <- NoExpressionAfter
else
results <- results @ [expressionReply.Result]
match status with
| NoExpressionAfter ->
Reply(Error, expected "expression following ,")
| Good -> failwith "should not get here"
| Stop ->
if results.IsEmpty then
fst
else
let endPos = capturePosition stream
let pos =
{ Start = startPos
End = endPos
File = stream.Name }
Reply (mapping ([fst.Result] @ results) pos))
let stringLiteral =
(fun (stream: CharStream<UserState>) ->
let start = stream.Peek()
if start <> '"' then
Reply (Error, expected "\"")
else
stream.Skip()
let firstContentStartPos = capturePosition stream
let mutable contentStartPos = firstContentStartPos
let mutable lines = []
let mutable currentLine = []
let mutable cont = true
let mutable escape = false
let mutable endOfStream = false
let mutable badIndentation = false
let endLine() =
let contentEndPos = capturePosition stream
lines <- lines @ [{ Content = new System.String(Array.ofList currentLine)
ContentPosition = { Start = contentStartPos; End = contentEndPos; File = stream.Name}}]
currentLine <- []
while cont do
if stream.IsEndOfStream then
endOfStream <- true
cont <- false
else
let c = stream.Peek()
if c = '"' && not escape then
endLine()
stream.Skip()
cont <- false
else
if c = '\r' || c = '\n' then
if escape then
currentLine <- currentLine @ ['\\']
endLine()
if c = '\r' && stream.Peek(1) = '\n' then
stream.Skip 2
else
stream.Skip()
stream.RegisterNewline() |> ignore
contentStartPos <- capturePosition stream
let mutable read_whitespace = true
let mutable indentation = 0L
while read_whitespace do
if stream.IsEndOfStream then
read_whitespace <- false
else
let nextChar = stream.Peek()
let mutable was_nl = false
let mutable was_rn = false
match nextChar with
| ' ' -> indentation <- indentation + 1L
| '\n' ->
was_nl <- true
endLine()
| '\r' ->
if stream.Peek(1) = '\n' then
endLine()
was_rn <- true
indentation <- 0L
else
read_whitespace <- false
| _ -> read_whitespace <- false
if read_whitespace then
if was_rn then
stream.Skip 2
else
stream.Skip()
if (indentation + 1L) = firstContentStartPos.ColumnNo then
read_whitespace <- false
else
if was_nl || was_rn then
stream.RegisterNewline() |> ignore
contentStartPos <- capturePosition stream
contentStartPos <- capturePosition stream
if (indentation + 1L) < firstContentStartPos.ColumnNo then
badIndentation <- true
cont <- false
else
if escape then
let c =
match c with
| 'n' -> ['\n']
| '\\' -> ['\\']
| c -> ['\\'; c]
escape <- false
stream.Skip()
currentLine <- currentLine @ c
else
stream.Skip()
if c = '\\' then
escape <- true
else
currentLine <- currentLine @ [c]
if endOfStream then
Reply (Error, expected "\"")
else if badIndentation then
Reply (Error, messageError "Multi-line string content must be indented to the same level")
else
match lines with
| [] -> failwith "shouldnt ever be empty"
| [x] -> Reply(OneLineStringLiteral x)
| lines ->
Reply(MultiLineStringLiteral lines))
module Emly.UntypedAST
type Position =
{ ColumnNo : int64
LineNo : int64 }
type StartEndPosition =
{ Start : Position
End : Position
File : string }
type TypeName =
{ Name : string
NamePosition : StartEndPosition
Path : (string * StartEndPosition) list
Arguments : Type list }
member this.FullName = (this.Path |> List.map fst) @ [ this.Name ]
member this.FullNameAsString = (this.Path |> List.map fst) @ [ this.Name ] |> String.concat "."
and TypeVariable =
{ TypeVariableName : string
NamePosition : StartEndPosition
Arguments : Type list }
and Type =
| Generic of TypeVariable * StartEndPosition
| NonGeneric of TypeName * StartEndPosition
| TupleType of Type list
| FunType of Type list
member this.NameAsString =
let printOp op (types : Type list) =
types
|> List.map(fun x -> x.NameAsString)
|> String.concat op
match this with
| Generic (x, _) -> x.TypeVariableName
| NonGeneric (x, _) -> x.FullNameAsString
| TupleType types -> printOp " * " types
| FunType types -> printOp " -> " types
type TypeConstraint =
{ TypeVariableName : string
TypeVariableNamePosition : StartEndPosition
TypeClasses : (TypeName * StartEndPosition) list
Position : StartEndPosition }
type ConstraintsAndType =
{ Constraints : TypeConstraint list
Type : Type
Position : StartEndPosition }
type IdentType =
| SingleConstraint of TypeConstraint
| ConstraintsAndType of ConstraintsAndType
type RawNumber =
{ Value : string
Suffix : string option }
type IdentOfName =
{ Name : string * StartEndPosition
Type : option<IdentType * StartEndPosition>
Position : StartEndPosition }
type IdentOfType =
{ Name : Option<string * StartEndPosition>
Type : IdentType
TypePosition : StartEndPosition
Position : StartEndPosition }
type IdentTuple<'ident> =
| IdentTuple of IdentTuple<'ident> list * StartEndPosition
| Ident of 'ident
| IdentUnit of StartEndPosition
type IdentAndArgs =
{ IdentName : string
IdentNamePosition : StartEndPosition
Args : IdentTuple<IdentOfName> list
ReturnType : option<IdentType * StartEndPosition> }
type LetIdent =
| Ident of IdentTuple<IdentOfName>
| IdentAndArgs of IdentAndArgs
type StringLiteralLine =
{ ContentPosition : StartEndPosition
Content : string }
type StringLiteralType =
| OneLineStringLiteral of StringLiteralLine
| MultiLineStringLiteral of StringLiteralLine list
type RecordMemberInit =
{ MemberName : TypeName
NamePosition : StartEndPosition
Value : Expression }
//and MatchIdentArgumentType =
//| MatchIdentArgumentSingle of string
//| MatchIdentArgumentTuple of MatchIdentArgument list
//
//and MatchIdentArgument =
// { MatchIdentArgumentType : MatchIdentArgumentType
// Position : StartEndPosition }
and MatchIdent =
{ MatchIdent : TypeName
Argument : option<IdentTuple<IdentOfName> * StartEndPosition> }
and MatchExpressionType =
| MatchIdent of MatchIdent
| MatchNumber of RawNumber
| MatchTuple of MatchExpression list
and MatchExpression =
{ MatchExpressionType : MatchExpressionType
Position : StartEndPosition }
and MatchCase =
{ MatchExpression : MatchExpression
ResultExpression : Expression }
and Match =
{ Value : Expression
Cases : MatchCase list
MatchPosition : StartEndPosition }
and Let =
{ Ident : LetIdent
Definition : Expression
Body : Expression
Impure : StartEndPosition option
Mutable : StartEndPosition option
Rec : StartEndPosition option }
and AssignIdent =
{ Ident : string
IdentPosition : StartEndPosition }
and AssignTarget =
| AssignIdent of AssignIdent
| AssignMember of MemberAccess
and Assign =
{ AssignTarget : AssignTarget
Definition : Expression
Body : Expression option }
and Lambda =
{ Args : IdentTuple<IdentOfName> list
Body : Expression }
and MemberAccess =
{ DotPosition : StartEndPosition
Expression : Expression
MemberName : string
MemberPosition : StartEndPosition }
and Unbound =
{ Unbound : Expression
Body : Expression }
and ExpressionType =
| Unit
| Ident of string
| Number of RawNumber
| StringLiteral of StringLiteralType
| Lambda of Lambda
| Apply of Expression * Expression
| ApplyInfixOperator of string * StartEndPosition * Expression * Expression
| ApplyPrefixOperator of string * StartEndPosition * Expression
| MemberAccess of MemberAccess
| Let of Let
| Assign of Assign
| RecordInit of RecordMemberInit list
| TupleExpression of List<Expression>
| IfElse of Expression * Expression * Expression
| Match of Match
| Unbound of Unbound
and Expression =
{ ExpressionType : ExpressionType
Position : StartEndPosition }
override this.ToString() = sprintf "%A" this
type TypeMember =
{ TypeMemberName : string
NamePosition : StartEndPosition
Type : IdentType
TypePosition : StartEndPosition
Mutable : StartEndPosition option }
type TypeArgument =
{ TypeArgumentName : string
NamePosition : StartEndPosition
TypeClasses : (TypeName * StartEndPosition) list }
type Record =
{ RecordName : string
TypeArguments : TypeArgument list
NamePosition : StartEndPosition
RecordMembers : TypeMember list }
type UnionCase =
{ UnionCaseName : string
NamePosition : StartEndPosition
Type : option<IdentType * StartEndPosition> }
type Union =
{ UnionName : string
TypeArguments : TypeArgument list
NamePosition : StartEndPosition
UnionCases : UnionCase list }
type TypeclassMember =
{ TypeclassMemberName : string
NamePosition : StartEndPosition
Type : IdentTuple<IdentOfType> list
TypePosition : StartEndPosition }
type TypeClass =
{ TypeClassName : string
NamePosition : StartEndPosition
Of : Type
OfPosition : StartEndPosition
TypeClassMembers : TypeclassMember list }
type TypeClassInstanceMemberIdent =
| InstanceIdent of string * StartEndPosition
| InstanceIdentAndArgs of IdentAndArgs
type TypeClassInstanceMember =
{ TypeClassInstanceMemberIdent : TypeClassInstanceMemberIdent
NamePosition : StartEndPosition
Position : StartEndPosition
Expression : Expression }
type TypeClassInstance =
{ TypeClassInstanceName : list<string * StartEndPosition>
Of : TypeName
OfPosition : StartEndPosition
TypeClassInstanceMembers : TypeClassInstanceMember list }
type ModuleLet =
{ Ident : LetIdent
Definition : Expression
Impure : StartEndPosition option
Mutable : StartEndPosition option
Rec : StartEndPosition option }
type Foreign =
{ ForeignName : string
NamePosition : StartEndPosition
Args : IdentTuple<IdentOfName> list
Type : IdentType
TypePosition : StartEndPosition
Impure : StartEndPosition option
Mutable : StartEndPosition option }
type ForeignTypeMethod =
{ ForeignTypeMethodName : string
NamePosition : StartEndPosition
Type : IdentType
TypePosition : StartEndPosition
Impure : StartEndPosition option }
type ForeignType =
{ ForeignTypeName : string
NamePosition : StartEndPosition
TypeArguments : TypeArgument list
Members : TypeMember list
Methods : ForeignTypeMethod list }
type ModuleOpen =
{ OpenPath : list<string * StartEndPosition> }
type ModuleMemberType =
| Module of Module
| Record of Record
| Union of Union
| TypeClass of TypeClass
| TypeClassInstance of TypeClassInstance
| ModuleLet of ModuleLet
| Foreign of Foreign
| ForeignType of ForeignType
| ModuleOpen of ModuleOpen
and ModuleMember =
{ ModuleMemberType : ModuleMemberType
Position : StartEndPosition }
and Module =
{ ModuleName : string
NamePosition : StartEndPosition
ModuleMembers : ModuleMember list }
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment