test/Parser/Brainfuck.hs

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