-- http://gilmi.xyz/blog/post/2016/10/14/lisp-to-js

module Parser where

import Prelude

import Control.Lazy (class Lazy)
import Control.Monad.State (class MonadState, StateT, get, lift, put, runStateT)
import Control.MonadZero (class Alt, class Alternative, class MonadZero, class Plus, guard)
import Data.Array (many)
import Data.Char.Unicode (isSpace)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap)
import Data.String.CodeUnits as S
import Data.Traversable (elem, sequence, traverse)
import Data.Tuple (Tuple)
import Data.Unfoldable (replicate)
import Effect (Effect)
import Effect.Class.Console (logShow)

newtype Parser a = Parser (StateT String Maybe a)

derive instance newtypeParser :: Newtype (Parser a) _

derive newtype instance lazyParser :: Lazy (Parser a)

derive newtype instance functorParser :: Functor Parser
derive newtype instance applyParser :: Apply Parser
derive newtype instance applicativeParser :: Applicative Parser
derive newtype instance bindParser :: Bind Parser
derive newtype instance monadParser :: Monad Parser

derive newtype instance plusParser :: Plus Parser
derive newtype instance altParser :: Alt Parser
derive newtype instance alternativeParser :: Alternative Parser
derive newtype instance monadZeroParser :: MonadZero Parser

derive newtype instance monadStateParser :: MonadState String Parser

anyChar :: Parser Char
anyChar = Parser $ do
  xs <- get
  case S.uncons xs of
    Just {head, tail} -> put tail *> pure head
    Nothing -> lift Nothing

satisfy :: (Char -> Boolean) -> Parser Char
satisfy pred = do
    c <- anyChar
    guard $ pred c
    pure c

char :: Char -> Parser Char
char = satisfy <<< (==)

string :: String -> Parser String
string = map S.fromCharArray <$> traverse char <<< S.toCharArray

string2 :: String -> Parser String
string2 s = case S.uncons s of
  Just r -> do
    c <- char r.head
    cs <- string2 r.tail
    pure $ S.singleton c <> cs
  Nothing -> pure ""

count :: forall a. Int -> Parser a -> Parser (Array a)
count n p = sequence (replicate n p)

oneOf :: Array Char -> Parser Char
oneOf ss = satisfy (flip elem ss)

space :: Parser Char
space = satisfy isSpace

spaces :: Parser String
spaces = map S.fromCharArray $ many space

brackets :: forall a b. Parser a -> Parser a -> Parser b -> Parser b
brackets o c p = o *> p <* c

withSpaces :: forall a. Parser a -> Parser a
withSpaces = brackets spaces spaces

parens :: forall a. Parser a -> Parser a
parens = brackets (withSpaces $ char '(') (withSpaces $ char ')')

runParser :: forall a. Parser a -> String -> Maybe (Tuple a String)
runParser = runStateT <<< unwrap


-- Show
-- Eq
-- Ord
data Expr
  = Var Int
  | Add Expr Expr
  | Mul Expr Expr

interpreter :: Expr -> Int
interpreter = case _ of
  Var a -> a
  Add a b -> interpreter a + interpreter b
  Mul a b -> interpreter a * interpreter b

main :: Effect Unit
main = do
  logShow $
    runParser (true <$ (parens $ string "test")) """(              test)             """
  logShow $ runParser (count 4 $ char 'a') "aaaaa"
  logShow $ interpreter $ Add (Mul (Var 10) (Var 40)) (Var 20)