{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
module Grammar.Brainfuck where

import Data.Char (Char)
import Data.Eq (Eq(..))
import Text.Show (Show(..))
import qualified Prelude
import qualified Language.Haskell.TH.Syntax as TH

import Symantic.Univariant.Trans
import qualified Symantic.Parser as P
import qualified Symantic.Parser.Haskell as H

data Operator
  = RightPointer
  | LeftPointer
  | Increment
  | Decrement
  | Output
  | Input
  | Loop [Operator]
  deriving (Show, Eq, TH.Lift)

haskell :: TH.Lift a => a -> P.TermGrammar a
haskell a = H.Term (H.ValueCode a [||a||])

grammar :: forall repr.
  P.Grammar Char repr =>
  repr [Operator]
grammar = whitespace P.*> bf
  where
  whitespace = P.skipMany (P.noneOf "<>+-[],.$")
  lexeme p = p P.<* whitespace
  bf :: repr [Operator]
  bf = P.many (lexeme (P.match (P.look P.anyChar) (haskell Prelude.<$> "><+-.,[") op P.empty))
  op :: H.Term H.ValueCode Char -> repr Operator
  op (trans -> H.ValueCode c _) = case c of
    '>' -> P.anyChar P.$> P.code RightPointer
    '<' -> P.anyChar P.$> P.code LeftPointer
    '+' -> P.anyChar P.$> P.code Increment
    '-' -> P.anyChar P.$> P.code Decrement
    '.' -> P.anyChar P.$> P.code Output
    ',' -> P.anyChar P.$> P.code Input
    '[' -> P.between (lexeme P.anyChar) (P.char ']') (H.Term (H.ValueCode Loop [||Loop||]) P.<$> bf)
    _ -> Prelude.undefined