test/Parser/Brainfuck.hs

   1 {-# LANGUAGE DeriveLift #-}
   2 {-# LANGUAGE NoMonomorphismRestriction #-}
   3 {-# LANGUAGE TemplateHaskell #-}
   4 module Parser.Brainfuck where
   5
   6 import Data.Char (Char)
   7 import Data.Eq (Eq(..))
   8 import Text.Show (Show(..))
   9 import qualified Prelude
  10 import qualified Language.Haskell.TH.Syntax as TH
  11
  12 import Symantic.Univariant.Trans
  13 import qualified Symantic.Parser as P
  14 import qualified Symantic.Parser.Haskell as H
  15
  16 data BrainFuckOp
  17   = RightPointer
  18   | LeftPointer
  19   | Increment
  20   | Decrement
  21   | Output
  22   | Input
  23   | Loop [BrainFuckOp]
  24   deriving (Show, Eq, TH.Lift)
  25
  26 haskell :: TH.Lift a => a -> P.TermGrammar a
  27 haskell a = H.Term (H.ValueCode a [||a||])
  28
  29 brainfuck :: forall repr.
  30   P.Grammar Char repr =>
  31   repr [BrainFuckOp]
  32 brainfuck = whitespace P.*> bf
  33   where
  34   whitespace = P.skipMany (P.noneOf "<>+-[],.$")
  35   lexeme p = p P.<* whitespace
  36   bf :: repr [BrainFuckOp]
  37   bf = P.many (lexeme (P.match (P.look P.anyChar) (haskell Prelude.<$> "><+-.,[") op P.empty))
  38   op :: H.Term H.ValueCode Char -> repr BrainFuckOp
  39   op (trans -> H.ValueCode c _) = case c of
  40     '>' -> P.anyChar P.$> H.Term (H.ValueCode RightPointer [||RightPointer||])
  41     '<' -> P.anyChar P.$> H.Term (H.ValueCode LeftPointer  [||LeftPointer||])
  42     '+' -> P.anyChar P.$> H.Term (H.ValueCode Increment    [||Increment||])
  43     '-' -> P.anyChar P.$> H.Term (H.ValueCode Decrement    [||Decrement||])
  44     '.' -> P.anyChar P.$> H.Term (H.ValueCode Output       [||Output||])
  45     ',' -> P.anyChar P.$> H.Term (H.ValueCode Input        [||Input||])
  46     '[' -> P.between (lexeme P.anyChar) (P.char ']') (H.Term (H.ValueCode Loop [||Loop||]) P.<$> bf)
  47     _ -> Prelude.undefined