{-# LANGUAGE TemplateHaskell #-}
module Symantic.Parser
 ( module Symantic.Parser.Grammar
 --, module Symantic.Parser.Staging
 , module Symantic.Parser
 ) where
import Symantic.Parser.Grammar
import qualified Symantic.Parser.Staging as S

--import Prelude hiding (fmap, pure, (<*), (*>), (<*>), (<$>), (<$), pred, repeat)
import Data.Int (Int)
import Data.Char (Char)
import Data.String (String)
import Text.Show (Show)
import Data.Eq (Eq)
import Control.Monad (liftM)
import Data.Char (isAlpha, isAlphaNum, isSpace, isUpper, isDigit, digitToInt, chr, ord)
import Data.Set (fromList, member)
import Data.Maybe (catMaybes)
import Text.Read (readMaybe)
import Language.Haskell.TH (TExpQ)

import qualified Prelude

{-
ee = pure id
e0 = e0 <* e0 <* e0
e1 = e1 <* e0
e2 = e2 <* e0
e3 = ee <* e1 <* e2
l0 = lets e0
l1 = lets e1
l2 = lets e2
l3 = lets e3
-}

data Expr = Var String | Num Int | Add Expr Expr deriving Show
data Asgn = Asgn String Expr deriving Show

data BrainFuckOp = RightPointer | LeftPointer | Increment | Decrement | Output | Input | Loop [BrainFuckOp] deriving (Show, Eq)

{-
cinput = m --try (string "aaa") <|> string "db" --(string "aab" <|> string "aac") --(char 'a' <|> char 'b') *> string "ab"
  where
    --m = match "ab" (lookAhead item) op empty
    --op 'a' = item $> runtime "aaaaa"
    --op 'b' = item $> runtime "bbbbb"
    m = bf <* item
    -- match :: Eq a => [Pure repr a] -> repr a -> (Pure repr a -> repr b) -> repr b -> repr b
    bf = match [char '>'] item op empty
    op (S.Runtime '>' _) = string ">"
-}

--defuncTest = runtime Just <$> (runtime (+) <$> (item $> runtime 1) <*> (item $> runtime 8))

-- manyTest = many (string "ab" $> (runtime 'c'))

--nfb = negLook (char 'a') <|> void (string "ab")

--skipManyInspect = skipMany (char 'a')

boom :: Applicable repr => repr ()
boom =
  let foo = (-- newRegister_ unit (\r0 ->
       let goo = (-- newRegister_ unit (\r1 ->
             let hoo = {-get r0 <~> get r1 *>-} goo *> hoo in hoo
            ) *> goo
       in goo) *> pure S.unit
  in foo *> foo

runtime :: a -> TExpQ a -> S.Runtime a
runtime e c = S.Runtime (S.Eval e) (S.Code c)

brainfuck ::
 forall repr.
 Applicable repr =>
 Charable repr =>
 Selectable repr =>
 Matchable repr =>
 Lookable repr =>
 Alternable repr =>
 Foldable repr =>
 repr [BrainFuckOp]
brainfuck = whitespace *> bf
  where
    whitespace = skipMany (noneOf "<>+-[],.$")
    lexeme :: repr a -> repr a
    lexeme p = p <* whitespace
    -- match :: Eq a => [Pure repr a] -> repr a -> (Pure repr a -> repr b) -> repr b -> repr b
    bf :: repr [BrainFuckOp]
    bf = many (lexeme (match ((\c -> runtime c [||c||]) Prelude.<$> "><+-.,[") (look item) op empty))
    -- op :: Pure repr Char -> repr BrainFuckOp
    op (S.Runtime (S.Eval c) _) = case c of
     '>' -> item $> runtime RightPointer [||RightPointer||]
     '<' -> item $> runtime LeftPointer  [||LeftPointer||]
     '+' -> item $> runtime Increment    [||Increment||]
     '-' -> item $> runtime Decrement    [||Decrement||]
     '.' -> item $> runtime Output       [||Output||]
     ',' -> item $> runtime Input        [||Input||]
     '[' -> between (lexeme item) (char ']') (runtime Loop [||Loop||] <$> bf)