Skip to content
Browse files

A few minor fixes to Cachel

  • Loading branch information...
1 parent dfef925 commit 4e24fadf0df1180201337e059a039de7c3b642d6 @devhawk committed Aug 5, 2008
View
3 Cashel/Cashel.Tests/cashel.tests.fs
@@ -1,3 +0,0 @@
-// Turn on the lightweight syntax
-#light
-
View
3 Cashel/Cashel.Tests/peg.test.fs
@@ -355,6 +355,7 @@ EndOfFile <- !."
defs |> List.length |> should equal 29
cl |> should equal []
+(*
[<Fact>]
let test_PEG2_grammar () =
let peg_grammar = !! @"
@@ -402,4 +403,4 @@ EndOfFile <- !.
let Some(grammar, cl) = peg_grammar |> DevHawk.Parser.Peg2.Grammar
grammar.name |> should equal !!"PEG"
grammar.defs |> List.length |> should equal 31
- cl |> should equal []
+ cl |> should equal [] *)
View
4 Cashel/Cashel.Tests/primitives.test.fs
@@ -34,11 +34,11 @@ let test_listify_with_item () =
[<Fact>]
let test_satisy_simple_predicate () =
let exp = Some('t', !!"est")
- satisfy (fun x -> x = 't') !!"test" |> should equal exp
+ satisfy item (fun x -> x = 't') !!"test" |> should equal exp
[<Fact>]
let test_satisy_failure_predicate () =
- satisfy (fun x -> x = 'e') !!"test" |> should equal None
+ satisfy item (fun x -> x = 'e') !!"test" |> should equal None
[<Fact>]
let test_any_of_success_predicate () =
View
8 Cashel/Cashel/Cashel.fsharpp
@@ -55,14 +55,6 @@
{
"ProjRelPath" = "T"
}
- "peg2.fs"
- {
- "ProjRelPath" = "T"
- }
- "ometa.fs"
- {
- "ProjRelPath" = "T"
- }
}
"ProjStartupServices"
{
View
60 Cashel/Cashel/ometa.fs
@@ -1,60 +0,0 @@
-#light
-
-(*
-ometa OMetaParser <: Parser {
- FromTo :x :y = Seq((x)) (~Seq((y)) Character)* Seq((y)),
- Space = Super((Space)) | FromTo(("//"), ("\n")) | FromTo(("/*"), ("*/")),
- NameFirst = '_' | '$' | Letter,
- NameRest = NameFirst | Digit,
- TSName = FirstAndRest(("NameFirst"), ("NameRest")):xs -> { xs.As<string>() },
- Name = Spaces TSName,
- EscapedChar = '\\' Character:c -> { System.Text.RegularExpressions.Regex.Unescape("\\" + c.As<string>())[0] }
- | Character,
- TSString = '\'' (~'\'' EscapedChar)*:xs '\'' -> { xs.As<string>() },
- Characters = '`' '`' (~('\'' '\'') EscapedChar)*:xs '\'' '\'' -> { Sugar.Cons("App", "Seq", xs.ToProgramString()) },
- SCharacters = '"' (~'"' EscapedChar)*:xs '"' -> { Sugar.Cons("App", "Token", xs.ToProgramString() ) },
- String = (('#' | '`') TSName | TSString):xs -> { Sugar.Cons("App", "Exactly", xs.ToProgramString() ) },
- Number = ('-' | Empty -> { "" }):sign Digit+:ds -> { Sugar.Cons("App", "Exactly", (sign != OMetaList<HostExpression>.Nil ? sign.As<string>() : "") + ds.As<string>()) },
- Keyword :xs = Token((xs)) ~LetterOrDigit -> { xs },
- HostExpr = Foreign((typeof(OMetaSharp.UnitTests.ManuallyCreatedCode.ManualCSharpRecognizer)), ("ParenExpr")),
- AtomicHostExpr = Foreign((typeof(OMetaSharp.UnitTests.ManuallyCreatedCode.ManualCSharpRecognizer)), ("Block")),
- Args = "(" ListOf(("HostExpr"), (",")):xs ")" -> { xs }
- | Empty -> { OMetaList<HostExpression>.Nil },
- Application = Name:rule Args:ags -> { Sugar.Cons("App", rule, ags) },
- SemAction = ("!" | "->") AtomicHostExpr:x -> { Sugar.Cons("Act", x) },
- SemPred = "?" HostExpr:x -> { Sugar.Cons("Pred", x) },
- Expr = ListOf(("Expr4"), ("|")):xs -> { Sugar.HackedInnerConcat("Or", xs) },
- Expr4 = Expr3*:xs -> { Sugar.HackedInnerConcat("And", xs) },
- OptIter :x = "*" -> { Sugar.Cons("Many", x) }
- | "+" -> { Sugar.Cons("Many1", x) }
- | Empty -> { x },
- Expr3 = Expr2:x OptIter((x)):x ( ':' Name:n -> { Sugar.StatementCons(
- () => Get<VariableSet>("Locals").Add(n.ToString())
- ,
- Sugar.Cons("Set", n, x)) }
- | Empty -> { x }
- )
- | ":" Name:n -> { Sugar.StatementCons(
- () => Get<VariableSet>("Locals").Add(n.ToString()),
- Sugar.Cons("Set", n, Sugar.Cons("App", "Anything"))) },
- Expr2 = "~" Expr2:x -> { Sugar.Cons("Not", x) }
- | "&" Expr1:x -> { Sugar.Cons("Lookahead", x) }
- | Expr1,
- Expr1 = Application | SemAction | SemPred
- | ( Keyword(("undefined")) | Keyword(("nil"))
- | Keyword(("true")) | Keyword(("false")) ):x -> { Sugar.Cons("App", "Exactly", x) }
- | Spaces (Characters | SCharacters | String | Number)
- | "[" Expr:x "]" -> { Sugar.Cons("Form", x) }
- | "(" Expr:x ")" -> { x },
- RuleName = Name
- | Spaces TSString,
- Rule = &(RuleName:n) !{Set("Locals", new VariableSet())}
- RulePart((n)):x ("," RulePart((n)))*:xs -> { Sugar.Cons("Rule", n, Get<VariableSet>("Locals"), Sugar.Cons("Or", x, xs)) },
- RulePart :rn = RuleName:n ?(n.Equals(rn)) Expr4:b1 ( "=" Expr:b2 -> { Sugar.Cons("And", b1, b2) }
- | Empty -> { b1 }
- ),
- Grammar = Keyword(("ometa")) Name:n
- ( "<:" Name | Empty -> { "OMeta" } ):sn
- "{" ListOf(("Rule"), (",")):rs "}" -> { Sugar.ConsWithFlatten("Grammar", n, sn, rs) }
-}
-*)
View
8 Cashel/Cashel/parser.fs
@@ -5,7 +5,7 @@ namespace DevHawk.Parser
module Core
-type Parser<'input, 'result> = 'input-> ('result * 'input) option
+type Parser<'input, 'result> = 'input -> ('result * 'input) option
//I define the monadic operators (zero, result, bind & choice) as individual
//functions so I can use them outside the parse monad
@@ -14,15 +14,15 @@ let result v : Parser<'i,'r> = fun input -> Some(v, input)
let bind p f : Parser<'i,'r> =
fun input ->
match p input with
- | Some(value, input) -> (f value) input
+ | Some(value, input) -> f value input
| None -> None
let zero : Parser<'i,'r> = fun input -> None
let choice p q : Parser<'i,'r> =
fun input ->
match p input with
- | Some(v,i) -> Some(v,i)
+ | Some(v) -> Some(v)
| None -> q input
//I define infix operator versions of bind and choice to make it more
@@ -32,7 +32,7 @@ let (+++) = choice
//Here's the parser monad definition
type ParserBuilder() =
- member w.Delay(f) = fun input -> f () (input)
+ member w.Delay(f) = fun input -> f () input
member w.Zero() = zero
member w.Return(v) = result v
member w.Bind(p, f) = p >>= f
View
39 Cashel/Cashel/peg.fs
@@ -296,27 +296,24 @@ let Identifier =
//Had to name this method pPrimary to avoid conflict with Primary discriminated union
let rec pPrimary =
parse {
- let! id = Identifier
- do! !~ LEFTARROW
- return Primary.Identifier(id) }
- +++
- parse {
- do! OPEN |> ignore
- let! exp = Expression
- do! CLOSE |> ignore
- return Primary.Expression(exp) }
- +++
- parse {
- let! lit = Literal
- return Primary.Literal(lit) }
- +++
- parse {
- let! cls = Class
- return Primary.Class(cls) }
- +++
- parse {
- do! DOT |> ignore
- return Dot }
+ return! parse {
+ let! id = Identifier
+ do! !~ LEFTARROW
+ return Primary.Identifier(id) }
+ return! parse {
+ do! OPEN |> ignore
+ let! exp = Expression
+ do! CLOSE |> ignore
+ return Primary.Expression(exp) }
+ return! parse {
+ let! lit = Literal
+ return Primary.Literal(lit) }
+ return! parse {
+ let! cls = Class
+ return Primary.Class(cls) }
+ return! parse {
+ do! DOT |> ignore
+ return Dot } }
///SequenceItem <- (AND / NOT)? Primary (QUESTION / STAR / PLUS)?
View
399 Cashel/Cashel/peg2.fs
@@ -1,399 +0,0 @@
-#light
-
-(*
-# Hierarchical syntax
-Grammar <- Spacing 'grammar' Identifier LCURLY Definition+ RCURLY EndOfFile #Added name to grammar
-Definition <- Identifier LEFTARROW Expression
-Expression <- Sequence (SLASH Sequence)*
-Sequence <- Prefix*
-Prefix <- (AND / NOT)? Suffix
-Suffix <- Primary (QUESTION / STAR / PLUS)?
-Primary <- Identifier !LEFTARROW / OPEN Expression CLOSE / Literal / Class / DOT
-
-# Lexical syntax
-Identifier <- IdentStart IdentCont* Spacing
-IdentStart <- [a-zA-Z_]
-IdentCont <- IdentStart / [0-9]
-
-Literal <- ['] (!['] Char)* ['] Spacing / [""] (![""] Char)* [""] Spacing
-Class <- '[' (!']' Range)* ']' Spacing
-Range <- Char '-' Char / Char
-Char <- '\\' [nrt'""\[\]\\] / '\\' [0-2][0-7][0-7] / '\\' [0-7][0-7]? / !'\\' .
-
-LEFTARROW <- '<-' Spacing
-SLASH <- '/' Spacing
-AND <- '&' Spacing
-NOT <- '!' Spacing
-QUESTION <- '?' Spacing
-STAR <- '*' Spacing
-PLUS <- '+' Spacing
-OPEN <- '(' Spacing
-CLOSE <- ')' Spacing
-LCURLY <- '{' Spacing #added left curly bracket
-RCURLY <- '}' Spacing #added right curly bracket
-DOT <- '.' Spacing
-
-Spacing <- (Space / Comment)*
-Comment <- '#' (!EndOfLine .)* EndOfLine
-Space <- ' ' / '\t' / EndOfLine
-EndOfLine <- '\r\n' / '\n' / '\r'
-EndOfFile <- !.
-*)
-
-
-namespace DevHawk.Parser
-
-module Peg2
-
-//---------------------------------------------------------------------------------------------
-//AST Types
-
-let rec L2S (input : char list) =
- new System.String(List.to_array input)
-
-///AST Type for Range production
-type Range =
-| Single of char
-| Dual of char * char
- with
- override this.ToString() =
- match this with
- | Single x -> sprintf "Range.Single (%A)" x
- | Dual (x,y) -> sprintf "Range.Dual (%A,%A)" x y
-
-///AST Type for Suffix production
-type Suffix =
-| Question
-| Star
-| Plus
- with
- override this.ToString() =
- match this with
- | Question -> "Suffix.Question"
- | Star -> "Suffix.Star"
- | Plus -> "Suffix.Plus"
-
-///AST Type for Prefix production
-type Prefix =
-| And
-| Not
- with
- override this.ToString() =
- match this with
- | And -> "Prefix.And"
- | Not -> "Prefix.Not"
-
-///AST Type for Primary production
-type Primary =
-| Identifier of char list
-| Expression of Expression
-| Literal of char list
-| Class of Range list
-| Dot
- with
- static member Exp2Str (exp : Expression) =
- let sb = new System.Text.StringBuilder()
- for sequence in exp do
- sb.Append(" Sequence") |> ignore
- for si in sequence do
- sb.AppendFormat(" {0}", si) |> ignore
- sb.ToString()
- override this.ToString() =
- match this with
- | Identifier i -> sprintf "Primary.Identifier %s" (L2S i)
- | Expression e -> sprintf "Primary.Expression %s" (Primary.Exp2Str e)
- | Literal l -> sprintf "Primary.Literal %s" (L2S l)
- | Class rl ->
- let sb = new System.Text.StringBuilder("Primary.Class ")
- for r in rl do
- sb.AppendFormat("{0}, ", r) |> ignore
- sb.ToString()
- | Dot -> "Primary.Dot"
-
-///AST Type for Sequence Item production
-and SequenceItem =
- {
- primaryItem: Primary;
- itemPrefix: Prefix option;
- itemSuffix: Suffix option;
- }
- with
- override this.ToString() =
- let sb = new System.Text.StringBuilder("SequenceItem ")
- if Option.is_some this.itemPrefix then
- sb.AppendFormat("{0} ", (Option.get this.itemPrefix)) |> ignore
- sb.Append(this.primaryItem) |> ignore
- if Option.is_some this.itemSuffix then
- sb.AppendFormat(" {0}", (Option.get this.itemSuffix)) |> ignore
- sb.ToString()
-
-and Sequence = SequenceItem list
-
-and Expression = Sequence list
-
-///AST Type for Definition production
-type Definition =
- {
- name: char list;
- exp: Expression;
- }
- with
- override this.ToString() =
- sprintf "Definition (name: %A, exp: %A)" (L2S this.name) (Primary.Exp2Str this.exp)
-
-type Grammar =
- {
- name: char list;
- defs: Definition list;
- }
-
-//---------------------------------------------------------------------------------------------
-
-open DevHawk.Parser.Core
-open DevHawk.Parser.Primitives
-
-let S2L s = List.of_seq s
-
-///EndOfFile <- !.
-let EndOfFile = eof
-
-///EndOfLine <- '\r\n' / '\n' / '\r'
-let EndOfLine = parse {
- return! items_equal (S2L "\r\n")
- return! item_equal '\n' |> listify
- return! item_equal '\r' |> listify }
-
-///Space <- ' ' / '\t' / EndOfLine
-let Space = parse {
- return! item_equal ' ' |> listify
- return! item_equal '\t' |> listify
- return! EndOfLine }
-
-///Comment <- '#' (!EndOfLine .)* EndOfLine
-let Comment = parse {
- do! item_equal '#' |> ignore
- let! c = parse {
- do! !~ EndOfLine
- return! item} |> repeat
- do! EndOfLine |> ignore
- return c }
-
-///Spacing <- (Space / Comment)*
-let Spacing = parse {
- return! Space
- return! Comment } |> repeat
-
-///DOT <- '.' Spacing
-let DOT = item_equal '.' .>> Spacing
-
-///SLASH <- '/' Spacing
-let SLASH = item_equal '/' .>> Spacing
-
-///AND <- '&' Spacing
-let AND = item_equal '&' .>> Spacing
-
-///NOT <- '!' Spacing
-let NOT = item_equal '!' .>> Spacing
-
-///QUESTION <- '?' Spacing
-let QUESTION = item_equal '?' .>> Spacing
-
-///STAR <- '*' Spacing
-let STAR = item_equal '*' .>> Spacing
-
-///PLUS <- '+' Spacing
-let PLUS = item_equal '+' .>> Spacing
-
-///OPEN <- '(' Spacing
-let OPEN = item_equal '(' .>> Spacing
-
-///CLOSE <- ')' Spacing
-let CLOSE = item_equal ')' .>> Spacing
-
-///LCURLY <- '{' Spacing
-let LCURLY = item_equal '{' .>> Spacing
-
-///RCURLY <- '}' Spacing
-let RCURLY = item_equal '}' .>> Spacing
-
-///LEFTARROW <- '<-' Spacing
-let LEFTARROW = items_equal (S2L "<-") .>> Spacing
-
-///Char <- '\\' [nrt'""\[\]\\] / '\\' [0-2][0-7][0-7] / '\\' [0-7][0-7]? / !'\\' .
-let Char =
- let c2i c = Char.code c - Char.code '0'
-
- parse {
- do! item_equal '\\' |> ignore
- let! c = any_of ['n';'r';'t';'''; '"'; '['; ']'; '\\']
- match c with
- | 'n' -> return '\n'
- | 'r' -> return '\r'
- | 't' -> return '\t'
- | _ -> return c }
- +++
- parse {
- do! item_equal '\\' |> ignore
- let! c1 = any_of ['0'..'2']
- let! c2 = any_of ['0'..'7']
- let! c3 = any_of ['0'..'7']
- return Char.chr ((c2i c1)*64 + (c2i c2)*8 + (c2i c3)) }
- +++
- parse {
- do! item_equal '\\' |> ignore
- let! c1 = any_of ['0'..'7']
- let! c2 = !? (any_of ['0'..'7'])
- match c2 with
- | Some(c2) -> return Char.chr ((c2i c1)*8 + (c2i c2))
- | None -> return Char.chr (c2i c1) }
- +++
- parse {
- do! !~ (item_equal '\\')
- return! item }
-
-
-
-///Range <- Char '-' Char / Char
-let Range =
- parse {
- let! c1 = Char
- do! item_equal '-' |> ignore
- let! c2 = Char
- return Dual(c1, c2) }
- +++
- parse {
- let! c1 = Char
- return Single(c1) }
-
-///Class <- '[' (!']' Range)* ']' Spacing
-let Class =
- parse {
- do! item_equal '[' |> ignore
- let! rl = parse {
- do! !~ (item_equal ']')
- return! Range } |> repeat
- do! item_equal ']' |> ignore
- do! Spacing |> ignore
- return rl
- }
-
-///Literal <- ['] (!['] Char)* ['] Spacing / ["] (!["] Char)* [""] Spacing
-let Literal =
- let literal_workhorse ch = parse {
- do! item_equal ch |> ignore
- let! cl = parse {
- do! !~ (item_equal ch)
- return! Char } |> repeat
- do! item_equal ch |> ignore
- do! Spacing |> ignore
- return cl }
- literal_workhorse ''' +++ literal_workhorse '"'
-
-
-///Identifier <- IdentStart IdentCont* Spacing
-//IdentStart <- [a-zA-Z_]
-//IdentCont <- IdentStart / [0-9]
-let Identifier =
- let IdentStart = any_of (List.flatten [['a'..'z']; ['A'..'Z']; ['_']])
- let IdentCont = IdentStart +++ any_of ['0'..'9']
-
- parse {
- let! c = IdentStart
- let! cs = IdentCont |> repeat
- do! Spacing |> ignore
- return c::cs }
-
-
-///Primary <- Identifier !LEFTARROW / OPEN Expression CLOSE / Literal / Class / DOT
-//Had to name this method pPrimary to avoid conflict with Primary discriminated union
-let rec pPrimary =
- parse {
- let! id = Identifier
- do! !~ LEFTARROW
- return Primary.Identifier(id) }
- +++
- parse {
- do! OPEN |> ignore
- let! exp = Expression
- do! CLOSE |> ignore
- return Primary.Expression(exp) }
- +++
- parse {
- let! lit = Literal
- return Primary.Literal(lit) }
- +++
- parse {
- let! cls = Class
- return Primary.Class(cls) }
- +++
- parse {
- do! DOT |> ignore
- return Dot }
-
-
-///SequenceItem <- (AND / NOT)? Primary (QUESTION / STAR / PLUS)?
-and SequenceItem =
- let prefix =
- parse {
- do! AND |> ignore
- return Prefix.And }
- +++
- parse {
- do! NOT |> ignore
- return Prefix.Not }
- let suffix =
- parse {
- do! QUESTION |> ignore
- return Suffix.Question }
- +++
- parse {
- do! STAR |> ignore
- return Suffix.Star }
- +++
- parse {
- do! PLUS |> ignore
- return Suffix.Plus }
-
- parse {
- let! pre = !? prefix
- let! pri = pPrimary
- let! suf = !? suffix
- return {primaryItem=pri;itemPrefix=pre;itemSuffix=suf}
- }
-
-///Sequence <- SequenceItem*
-and Sequence = SequenceItem |> repeat
-
-///Expression <- Sequence (SLASH Sequence)*
-and Expression =
- parse {
- let! s = Sequence
- let! sl = parse {
- do! SLASH |> ignore
- return! Sequence } |> repeat
- return s::sl
- }
-
-///Definition <- Identifier LEFTARROW Expression
-let Definition =
- parse {
- let! id = Identifier
- do! LEFTARROW |> ignore
- let! ex = Expression
- return {name=id;exp=ex} }
-
-///Grammar <- Spacing 'grammar' Identifier LCURLY Definition+ RCURLY EndOfFile #Added name to grammar
-let Grammar =
- parse {
- do! Spacing |> ignore
- do! items_equal (S2L "grammar") |> ignore
- do! Spacing |> ignore
- let! id = Identifier
- do! LCURLY |> ignore
- let! defrepeat = Definition |> repeat1
- do! RCURLY |> ignore
- do! EndOfFile |> ignore
- return {name=id;defs=defrepeat} }
-
-
-
View
15 Cashel/Cashel/primitives.fs
@@ -8,30 +8,32 @@ open DevHawk.Parser.Core
//let (!!) s = List.of_seq s
+
//item assumes the input is a list and returns a tuple of the head and tail
let item =
fun input ->
match input with
| x::xs -> Some(x,xs)
| [] -> None
-
+
//ignore tosses the result of parsing function p
let ignore p = p >>= (fun x -> result ())
//listify turns the result of parsing function p into a single item list
let listify p = p >>= (fun x -> result [x])
//satisfy checks the value returned from item against the predicate function p
-let satisfy p =
+let satisfy parser pred =
parse {
- let! x = item
- if p x then return x }
+ let! x = parser
+ if pred x then return x }
+
//any_of checks the value at the start of the input is in the list of items l
-let any_of l = satisfy (fun x -> List.exists (fun y -> x = y) l)
+let any_of l = satisfy item (fun x -> List.exists (fun y -> x = y) l)
//item_equal checks the value at the start of the input matches the value v
-let item_equal v = satisfy (fun x -> x = v)
+let item_equal v = satisfy item (fun x -> x = v)
//items_equal recursively uses item_equal to check to see if a list of values l matches the start of the input
let rec items_equal l =
@@ -94,3 +96,4 @@ let (>>.) p1 p2 = parse {
do! p1 |> ignore
let! x = p2
return x }
+

0 comments on commit 4e24fad

Please sign in to comment.
Something went wrong with that request. Please try again.