-- | Some examples of grammars.

module Little.Earley.Examples
  ( -- * Grammars
    arithG
  , aArithG
  , lambdaG
  , mlG
  , jsonG

    -- * Symbols
  , ArithN(..)
  , LambdaN(..)
  , MlN(..)
  , JsonN(..)
  , CharT(..)
  , matchCharT
  ) where

import Data.Char (isAlpha, isDigit)

import Little.Earley (Grammar, Rule, Atom(..), mkGrammar)

-- | Grammar of arithmetic expressions.
--
-- > SUM     ::= PRODUCT | SUM [+-] PRODUCT
-- > PRODUCT ::= FACTOR | PRODUCT [*/] FACTOR
-- > FACTOR  ::= NUMBER | [(] NUMBER [)]
-- > NUMBER  ::= [0-9] | [0-9] NUMBER
--
-- === Example
--
-- @
-- 'Little.Earley.pparse' arithG SUM \"1+2*3\"
-- @
arithG :: Grammar ArithN CharT Char
arithG = mkGrammar arithRules matchCharT

-- | Ambiguous grammar of arithmetic expressions.
--
-- > SUM     ::= PRODUCT | SUM [+-] SUM
-- > PRODUCT ::= FACTOR | PRODUCT [*/] PRODUCT
-- > FACTOR  ::= NUMBER | [(] NUMBER [)]
-- > NUMBER  ::= [0-9] | [0-9] NUMBER
--
-- === Example
--
-- @
-- 'Little.Earley.pparse' aArithG SUM \"1+2-3\"
-- @
aArithG :: Grammar ArithN CharT Char
aArithG = mkGrammar aArithRules matchCharT

-- | Grammar of lambda expressions.
--
-- > LAMBDA ::= VAR | [\] VAR [.] LAMBDA | [(] LAMBDA [)] LAMBDA
-- > VAR    ::= [a-z]
--
-- === Example
--
-- @
-- 'Little.Earley.pparse' lambdaG LAMBDA \"\\\\x.x\"
-- 'Little.Earley.pparse' lambdaG LAMBDA \"(\\\\x.(x)x)\\\\x.(x)x\"
-- @
lambdaG :: Grammar LambdaN CharT Char
lambdaG = mkGrammar lambdaRules matchCharT

-- | ML-like syntax.
--
-- > TERM ::= ATOMS
-- >      | "fun" VAR "->" TERM
-- >      | "let" VAR "=" TERM "in" TERM
-- >      | "if" TERM "then" TERM
-- >      | "if" TERM "then" TERM "else" TERM
-- > ATOMS ::= ATOM | ATOMS ATOM
-- > ATOM ::= VAR
-- >      | "(" TERM ")"
-- > VAR ::= "a" | "b" | "c" | ...
--
-- === Example
--
-- Featuring the if-then-else ambiguity.
--
-- @
-- 'Little.Earley.pparse' mlG TERM (words \"if a then if b then c else d\")
-- @
mlG :: Grammar MlN String String
mlG = mkGrammar mlRules (==)

-- | JSON grammar.
--
-- > JSON   ::= "null" | "true" | "false" | (number) | (string) | "{" OBJECT "}" | "[" ARRAY "]"
-- > OBJECT ::= (string) ":" JSON | (string) ":" JSON "," OBJECT
-- > ARRAY ::= JSON | JSON "," ARRAY
--
-- === Example
--
-- @
-- 'Little.Earley.pparse' jsonG JSON (words \"{ \\\"key\\\" : \\\"answer\\\" , \\\"contents\\\" : 42 }\")
-- @
jsonG :: Grammar JsonN String String
jsonG = mkGrammar jsonRules jsonMatch

-- | Basic character classes.
data CharT
  = Digit
  | Alpha
  | OneOf [Char]
  deriving (Eq, Ord, Show)

-- | Membership function for character classes.
matchCharT :: CharT -> Char -> Bool
matchCharT Digit = isDigit
matchCharT Alpha = isAlpha
matchCharT (OneOf s) = (`elem` s)

-- | Non-terminals for arithmetic expressions.
data ArithN
  = SUM
  | PRODUCT
  | FACTOR
  | NUMBER
  deriving (Eq, Ord, Bounded, Enum, Show)

arithRules :: ArithN -> [Rule ArithN CharT]
arithRules n = case n of
  SUM ->
    [ [ N PRODUCT ]
    , [ N SUM, T (OneOf ['+', '-']), N PRODUCT ] ]
  PRODUCT ->
    [ [ N FACTOR ]
    , [ N PRODUCT, T (OneOf ['*', '/']), N FACTOR ] ]
  FACTOR ->
    [ [ N NUMBER ]
    , [ T (OneOf ['(']), N SUM, T (OneOf [')']) ] ]
  NUMBER ->
    [ [ T Digit ]
    , [ T Digit, N NUMBER ] ]

aArithRules :: ArithN -> [Rule ArithN CharT]
aArithRules n = case n of
  SUM ->
    [ [ N PRODUCT ]
    , [ N SUM, T (OneOf ['+', '-']), N SUM ] ]
  PRODUCT ->
    [ [ N FACTOR ]
    , [ N PRODUCT, T (OneOf ['*', '/']), N FACTOR ] ]
  FACTOR ->
    [ [ N NUMBER ]
    , [ T (OneOf ['(']), N SUM, T (OneOf [')']) ] ]
  NUMBER ->
    [ [ T Digit ]
    , [ T Digit, N NUMBER ] ]

-- | Non-terminals for lambda expressions.
data LambdaN = LAMBDA | VAR deriving (Eq, Ord, Bounded, Enum, Show)

lambdaRules :: LambdaN -> [Rule LambdaN CharT]
lambdaRules n = case n of
  LAMBDA ->
    [ [ N VAR ]
    , [ T (OneOf ['\\']), N VAR, T (OneOf ['.']), N LAMBDA ]
    , [ T (OneOf ['(']), N LAMBDA, T (OneOf [')']), N LAMBDA ] ]
  VAR -> [ [ T Alpha ] ]

-- | Non-terminals for an ML-like language.
data MlN
  = TERM
  | ATOMS
  | ATOM
  | VAR'
  deriving (Eq, Ord, Bounded, Enum, Show)

mlRules :: MlN -> [Rule MlN String]
mlRules n = case n of
  TERM ->
    [ [ N ATOMS ]
    , [ T "fun", N VAR', T "->", N TERM ]
    , [ T "let", N VAR', T "=", N TERM, T "in", N TERM ]
    , [ T "if", N TERM, T "then", N TERM ]
    , [ T "if", N TERM, T "then", N TERM, T "else", N TERM ] ]
  ATOMS ->
    [ [ N ATOM ]
    , [ N ATOMS, N ATOM ] ]
  ATOM ->
    [ [ N VAR' ]
    , [ T "(", N TERM, T ")" ] ]
  VAR' -> [ [ T [x] ] | x <- ['a' .. 'z'] ]

-- | Non-terminals for JSON.
data JsonN
  = JSON
  | OBJECT
  | ARRAY
  deriving (Eq, Ord, Bounded, Enum, Show)

jsonRules :: JsonN -> [Rule JsonN String]
jsonRules n = case n of
  JSON ->
    [ [ T "null" ]
    , [ T "true" ]
    , [ T "false" ]
    , [ T "NUMBER" ]
    , [ T "STRING" ]
    , [ T "{", N OBJECT, T "}" ]
    , [ T "[", N ARRAY, T "]" ] ]
  OBJECT ->
    [ [ T "STRING", T ":", N JSON ]
    , [ T "STRING", T ":", N JSON, T ",", N OBJECT ] ]
  ARRAY ->
    [ [ N JSON ]
    , [ N JSON, T ",", N ARRAY ] ]

jsonMatch :: String -> String -> Bool
jsonMatch "NUMBER" = all isDigit  -- Only integers for simplicity.
jsonMatch "STRING" = \s -> length s >= 2 && head s == '"' && last s == '"'
jsonMatch s0 = (==) s0