]> Git — Sourcephile - haskell/symantic-parser.git/blob - test/Grammar/Brainfuck.hs
more on failures
[haskell/symantic-parser.git] / test / Grammar / 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 Grammar.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 Operator
21 = RightPointer
22 | LeftPointer
23 | Increment
24 | Decrement
25 | Output
26 | Input
27 | Loop [Operator]
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 grammar :: forall repr.
34 P.Grammar Char repr =>
35 repr [Operator]
36 grammar = whitespace P.*> bf
37 where
38 whitespace = P.skipMany (P.noneOf "<>+-[],.$")
39 lexeme p = p P.<* whitespace
40 bf :: repr [Operator]
41 bf = P.many (lexeme (P.match (P.look P.anyChar) (haskell Prelude.<$> "><+-.,[") op P.empty))
42 op :: H.Term H.ValueCode Char -> repr Operator
43 op (trans -> H.ValueCode c _) = case c of
44 '>' -> P.anyChar P.$> P.code RightPointer
45 '<' -> P.anyChar P.$> P.code LeftPointer
46 '+' -> P.anyChar P.$> P.code Increment
47 '-' -> P.anyChar P.$> P.code Decrement
48 '.' -> P.anyChar P.$> P.code Output
49 ',' -> P.anyChar P.$> P.code Input
50 '[' -> P.between (lexeme P.anyChar) (P.char ']') (H.Term (H.ValueCode Loop [||Loop||]) P.<$> bf)
51 _ -> Prelude.undefined