Grammar.hs

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TemplateHaskell #-}
module Golden.Grammar where

import Data.Char (Char)
import Data.Eq (Eq)
import Data.Int (Int)
import Data.String (String)
import Prelude (undefined)
import Text.Show (Show)
import qualified Prelude
import qualified Language.Haskell.TH as TH

import Symantic.Parser
import qualified Symantic.Parser.Haskell as H

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 (H.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 H.unit
  in foo *> foo

haskell :: a -> TH.CodeQ a -> H.Haskell a
haskell e c = H.Haskell (H.ValueCode (H.Value e) c)

brainfuck :: Satisfiable repr Char => Grammar repr => repr [BrainFuckOp]
brainfuck = whitespace *> bf
  where
    whitespace = skipMany (noneOf "<>+-[],.$")
    lexeme p = p <* whitespace
    -- match :: Eq a => [Pure repr a] -> repr a -> (Pure repr a -> repr b) -> repr b -> repr b
    bf = many (lexeme (match ((\c -> haskell c [||c||]) Prelude.<$> "><+-.,[") (look anyChar) op empty))
    --op :: H.Haskell Char -> repr BrainFuckOp
    op (H.Haskell (H.ValueCode (H.Value c) _)) = case c of
     '>' -> anyChar $> haskell RightPointer [||RightPointer||]
     '<' -> anyChar $> haskell LeftPointer  [||LeftPointer||]
     '+' -> anyChar $> haskell Increment    [||Increment||]
     '-' -> anyChar $> haskell Decrement    [||Decrement||]
     '.' -> anyChar $> haskell Output       [||Output||]
     ',' -> anyChar $> haskell Input        [||Input||]
     '[' -> between (lexeme anyChar) (char ']') (haskell Loop [||Loop||] <$> bf)
     _ -> undefined
    op _ = undefined