FP101x Functional Parsers and Monads in LiveScript

expression-parser.ls

{any, tail, fix, concat-map, empty, map, foldr1, id, sqrt, sin, abs} = require \prelude-ls

is-digit = (c) -> 48 <= (c.char-code-at 0) <= 57

is-space = (c) -> code = c.char-code-at 0 ; [9, 32] |> any (== code)


# the argument of parse-digit, parse-pint and parse-decimal must be a valid parsable string

parse-signed-number = (parser, cs) -->
  [sign, cs] = match cs.0
    | "-" => [-1, tail cs]
    | "+" => [1, tail cs]
    | _   => [1, cs]

  sign * (parser cs)

parse-digit = (c) -> (c.char-code-at 0) - 48

parse-pint = (cs) -> match cs
  | ""  => 0
  | _   => (parse-digit cs.0) * (10^(cs.length - 1)) + parse-pint (tail cs)

parse-int = parse-signed-number parse-pint

parse-pdecimal = (cs) -> 
  [hs, ds] = cs.split "."
  (parse-pint hs) + (fix (next) -> (i, cs) -> match cs
    | "" => 0
    | _  => (parse-digit cs.0) * (10^(-1 * i)) + next i+1, (tail cs))(1, ds)

parse-decimal = parse-signed-number parse-pdecimal

# alias Parser a = (String -> [(a, String)])

# executes parser p on string s
# parse :: Parser a -> String -> [(a, String)]
parse = (p, s) --> p s

# parser monad unit
# unit :: a -> Parser a
unit = (v) -> (s) -> [[v, s]]

# parser monad bind
# bind :: Parser a -> (a -> Parser b) -> Parser b
bind = (p, f) --> (s) ->
  (parse p, s)
    |> concat-map ([a, r]:list) -> 
      if (empty list) then [] else parse (f a), r


# tries parser p if failed tries q
# por :: Parser a -> Parser a -> Parser a
por = (p, q) --> (s) ->
  r = parse p, s
  r = parse q, s if empty r
  r

# runs parser p 0+ times
# many :: Parser a -> Parser [a]
many = (p) ->
  (many1 p) `por` (unit [])

# runs parser p 1+ times
# many1 :: Parser a -> Parser [a]
many1 = (q) ->
  a <- bind q
  as <- bind <| many q
  unit <| if ('String' == typeof! a) then (a + as) else ([a] ++ as)

# matches the first character of string s
# item :: Parser Char
item = (s) -> match s
  | "" => []
  | _  => [[s.0, tail s]]

# always fails (equal to mzero)
# failure :: Parser a
failure = (_) -> []

# checks and returns the character if the it matches the predicate f, returns failure otherwise
# sat :: (Char -> Bool) -> Parser Char
sat = (f) ->
  c <- bind item
  if (f c) then (unit c) else failure

# is character a digit
# digit :: Parser Cjar
digit = sat is-digit

# is the string a series of digits
# digits :: Parser String
digits = many1 digit

# checks if the character is matching the given character
# char :: Char -> Parser Char
char = sat . (==)

# checks if the string is matching the given string
# note here: "" == [] and c + cs == c ++ cs
# string :: String -> Parser String
string = (s) -> match s
  | "" => unit ""
  | _  => 
    c  <- bind <| char s.0
    cs <- bind <| string (tail s)
    unit (c + cs)

# is it a series of spaces
# space :: Parser String
space = many <| sat is-space


signed-numeral = (parser) ->
  ((char '-') `bind` (-> parser) `bind` (unit . ('-' +))) `por` parser


integer = signed-numeral digits

# is it a decimal
# decimal :: Parser String
pdecimal = do ->
  hs <- bind digits
  _ <- bind <| char '.'
  ds <- bind digits
  unit <| hs + "." + ds

decimal = signed-numeral pdecimal


# signed decimal or digit
# number :: Parser String
number = decimal `por` integer

# token: "token   "
# token :: Parser a -> Parser a
token = (p) ->
  a <- bind p
  _ <- bind space
  unit a

# symb: a token that is matching the given string
# symb :: String -> Parser String
symb = token . string

# parses a series infix operator op.
# it ends with the last lhs (that is the rhs of the last operator in the chain)
# chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a
chainl1 = (p, op) -->
  a <- bind p
  rest = (a) -> (do ->
    f <- bind <| op
    b <- bind p
    rest (a `f` b)) `por` (unit a)
  rest a
  
# decimals and integers have different parsers
# fnumber :: Parser Number
fnumber = (token decimal `bind` (unit . parse-decimal)) `por` (token integer `bind` (unit . parse-int))

# utility
# make-op :: String -> (a -> b) -> Parser (a -> b)
make-op = (s, f) -->
  _ <- bind <| symb s
  unit f

# utility
# make-ops :: [String -> (a -> b)] -> Parser (a -> b)
make-ops = (map ([s,f]) -> make-op s, f) >> (foldr1 por)

# add :: Parser (Number -> Number)
add = make-ops [["+", (+)], ["-", (-)]]

# mul :: Parser (Number -> Number)
mul = make-ops [["*", (*)], ["/", (/)]]

# power :: Parser (Number -> Number)
power = make-op "^", (^)

# utility
# make-func :: String -> (a -> b) -> Parser (a -> b)
make-func = (s, f) -->
  _ <- bind <| token <| symb s
  e <- bind factor!
  unit <| f e

# utility
# make-funcs :: [String -> (a -> b)] -> Parser (a -> b)
make-funcs = (map ([s, f]) -> make-func s, f) >> (foldr1 por)

# pfunc :: Parser (Number -> Number)
pfunc = make-funcs [["sqrt", sqrt], ["sin", sin]]

# utility
# groups are like blocks
# make-group :: String -> String -> (a -> b) -> Parser b
make-group = (start, end, f) ->
  _ <- bind <| symb start
  e <- bind expr!
  _ <- bind <| symb end
  unit <| f e


# expr :: Parser Number
expr = -> term! `chainl1` add

# term :: Parser Number
term = -> factor! `chainl1` power `chainl1` mul

# fabs :: Parser Number
fabs = make-group '|', '|', abs

# factor :: Parser Number
factor = -> fnumber `por` pfunc `por` fabs `por` (make-group '(', ')', id)


# examples
console.log <| parse expr!, "|-2| * | 1 - (2 ^ (5 * (10 - 8))) |"
console.log <| parse expr!, "1  +  (2  +  4 * 5  *  sqrt (9  +  7 ) * 2) + 100.55 * sqrt( sin( 3.141592653589793 / 2 ) + 3 )   "
console.log <| parse expr!, "2*5^sqrt(4+5)+3"
console.log <| parse expr!, "sqrt( sin( 3.141592653589793 / 2 ) + 3 )"

z-example-array-of-number.ls

json-number-array = do ->
  _ <- bind <| char '['
  d <- bind fnumber
  ds <- bind <| many (
    _ <- bind <| char ','
    n <- bind fnumber
    unit n
  )
  _ <- bind <| char ']'
  unit ([d] ++ ds)

console.log <| parse (json-number-array), "[3.2,-5,2,8]"