Brainfuck.hs

{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE TemplateHaskell #-}
module Parser.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 BrainFuckOp
  = RightPointer
  | LeftPointer
  | Increment
  | Decrement
  | Output
  | Input
  | Loop [BrainFuckOp]
  deriving (Show, Eq, TH.Lift)

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

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