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. P.Satisfiable repr Char => P.Grammar repr => repr [BrainFuckOp]
  30 brainfuck = whitespace P.*> bf
  31   where
  32   whitespace = P.skipMany (P.noneOf "<>+-[],.$")
  33   lexeme p = p P.<* whitespace
  34   bf :: P.Grammar repr => repr [BrainFuckOp]
  35   bf = P.many (lexeme (P.match (P.look P.anyChar) (haskell Prelude.<$> "><+-.,[") op P.empty))
  36   op :: H.Term H.ValueCode Char -> repr BrainFuckOp
  37   op (trans -> H.ValueCode c _) = case c of
  38     '>' -> P.anyChar P.$> H.Term (H.ValueCode RightPointer [||RightPointer||])
  39     '<' -> P.anyChar P.$> H.Term (H.ValueCode LeftPointer  [||LeftPointer||])
  40     '+' -> P.anyChar P.$> H.Term (H.ValueCode Increment    [||Increment||])
  41     '-' -> P.anyChar P.$> H.Term (H.ValueCode Decrement    [||Decrement||])
  42     '.' -> P.anyChar P.$> H.Term (H.ValueCode Output       [||Output||])
  43     ',' -> P.anyChar P.$> H.Term (H.ValueCode Input        [||Input||])
  44     '[' -> P.between (lexeme P.anyChar) (P.char ']') (H.Term (H.ValueCode Loop [||Loop||]) P.<$> bf)
  45     _ -> Prelude.undefined