{-# Language TemplateHaskell, QuasiQuotes, FlexibleContexts #-}

module Parse (LVal, grammar) where

import Text.ParserCombinators.Parsec hiding (many)
import Control.Applicative hiding (optional, (<|>))

data LVal =
  Var (LVal, LVal)
  | Varname String
  | Pair (LVal, LVal)
  | Lambda (String, LVal)
  | Number Integer
  | Apply (LVal, LVal)
  | Comment
  deriving (Show)

grammar = stat

stat :: Parser LVal
stat =
  comment <//>
  var <//>
  apply

comment :: Parser LVal
comment = (\_ -> Comment) <$>
          (string "--" *> (many (noneOf ['\n'])))

-- foo = bar
-- [[name]] = (apply | expr)
var :: Parser LVal
var = (\v e -> Var (v, e)) <$>
      name <*>
      (spaceP *> char '=' *> spaceP *> (apply <//> expr))

-- fn expr
-- [[name]] (name | expr)+
apply :: Parser LVal
apply = (\s e -> Apply (s, e)) <$>
        fun <*> (spaceP *> (apply <//> fun <//> expr))

-- [[number]], pair, lambda, name
expr :: Parser LVal
expr = nums <//>
       pair <//>
       lambda <//>
       name

-- \x x
-- '\'[[name]] (apply | expr)
lambda :: Parser LVal
lambda = (\a e -> Lambda (a, e)) <$>
         ((char '\\' *> spaceP) *> strP) <*> (spaceP *> (expr <//> apply) <* spaceP)

-- <3, 5>
-- '<' expr ',' expr '>'
pair :: Parser LVal
pair = (\e1 e2 -> Pair (e1, e2)) <$>
       ((char '<' *> spaceP) *> (expr <//> apply)) <*> ((spaceP *> char ',' *> spaceP) *> (expr <//> apply) <* (spaceP <* char '>' <* spaceP))

-- [[name]]
name :: Parser LVal
name = sToLv strP

fun :: Parser LVal
fun = (brac lambda) <//>
      name <//>
      (sToLv arithP) <//>
      (brac apply)

-- [[number]]
nums :: Parser LVal
nums = (\n -> Number $
       read n) <$> (many1 $ oneOf ['0' .. '9'])

strP :: Parser String
strP = many1 $ oneOf $ ('_':['a' .. 'z']) ++ ['A' .. 'Z']

arithP :: Parser String
arithP = many1 $ oneOf "+-*/"

spaceP :: Parser String
spaceP = many $ oneOf " \t\n"

sToLv e = (\s -> Varname s) <$>
          (spaceP *> e <* spaceP)

brac e = char '(' *> spaceP *> e <* spaceP <* char ')'

p <//> q = (try p) <|> q