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

--import Prelude hiding (fmap, pure, (<*), (*>), (<*>), (<$>), (<$), pred, repeat)
import Data.Int (Int)
-- import Data.Char (Char)
import Prelude (undefined)
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 $> haskell "aaaaa"
    --op 'b' = item $> haskell "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 (Hask.ValueCode '>' _) = string ">"
-}

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

-- manyTest = many (string "ab" $> (haskell '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 Hask.unit
  in foo *> foo

haskell :: a -> TExpQ a -> Hask.Haskell a
haskell e c = Hask.Haskell (Hask.ValueCode (Hask.Value e) (Hask.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 -> haskell c [||c||]) Prelude.<$> "><+-.,[") (look item) op empty))
    -- op :: Pure repr Char -> repr BrainFuckOp
    op (Hask.Haskell (Hask.ValueCode (Hask.Value c) _)) = case c of
     '>' -> item $> haskell RightPointer [||RightPointer||]
     '<' -> item $> haskell LeftPointer  [||LeftPointer||]
     '+' -> item $> haskell Increment    [||Increment||]
     '-' -> item $> haskell Decrement    [||Decrement||]
     '.' -> item $> haskell Output       [||Output||]
     ',' -> item $> haskell Input        [||Input||]
     '[' -> between (lexeme item) (char ']') (haskell Loop [||Loop||] <$> bf)
     _ -> undefined
    op _ = undefined