]> Git — Sourcephile - haskell/symantic-parser.git/blob - test/Golden/Grammar.hs
Polish code and dumps
[haskell/symantic-parser.git] / test / Golden / Grammar.hs
1 {-# LANGUAGE NoMonomorphismRestriction #-}
2 {-# LANGUAGE TemplateHaskell #-}
3 module Golden.Grammar where
4
5 import Data.Eq (Eq)
6 import Data.Int (Int)
7 import Data.String (String)
8 import Language.Haskell.TH (TExpQ)
9 import Prelude (undefined)
10 import Text.Show (Show)
11 import qualified Prelude
12
13 import Symantic.Parser
14 import qualified Symantic.Parser.Staging as Hask
15
16 data Expr = Var String | Num Int | Add Expr Expr deriving Show
17 data Asgn = Asgn String Expr deriving Show
18
19 data BrainFuckOp = RightPointer | LeftPointer | Increment | Decrement | Output | Input | Loop [BrainFuckOp] deriving (Show, Eq)
20
21 {-
22 cinput = m --try (string "aaa") <|> string "db" --(string "aab" <|> string "aac") --(char 'a' <|> char 'b') *> string "ab"
23 where
24 --m = match "ab" (lookAhead item) op empty
25 --op 'a' = item $> haskell "aaaaa"
26 --op 'b' = item $> haskell "bbbbb"
27 m = bf <* item
28 -- match :: Eq a => [Pure repr a] -> repr a -> (Pure repr a -> repr b) -> repr b -> repr b
29 bf = match [char '>'] item op empty
30 op (Hask.ValueCode '>' _) = string ">"
31 -}
32
33 --defuncTest = haskell Just <$> (haskell (+) <$> (item $> haskell 1) <*> (item $> haskell 8))
34
35 -- manyTest = many (string "ab" $> (haskell 'c'))
36
37 --nfb = negLook (char 'a') <|> void (string "ab")
38
39 --skipManyInspect = skipMany (char 'a')
40
41 boom :: Applicable repr => repr ()
42 boom =
43 let foo = (-- newRegister_ unit (\r0 ->
44 let goo = (-- newRegister_ unit (\r1 ->
45 let hoo = {-get r0 <~> get r1 *>-} goo *> hoo in hoo
46 ) *> goo
47 in goo) *> pure Hask.unit
48 in foo *> foo
49
50 haskell :: a -> TExpQ a -> Hask.Haskell a
51 haskell e c = Hask.Haskell (Hask.ValueCode (Hask.Value e) (Hask.Code c))
52
53 brainfuck :: Grammar repr => repr [BrainFuckOp]
54 brainfuck = whitespace *> bf
55 where
56 whitespace = skipMany (noneOf "<>+-[],.$")
57 lexeme p = p <* whitespace
58 -- match :: Eq a => [Pure repr a] -> repr a -> (Pure repr a -> repr b) -> repr b -> repr b
59 bf = many (lexeme (match ((\c -> haskell c [||c||]) Prelude.<$> "><+-.,[") (look item) op empty))
60 -- op :: Pure repr Char -> repr BrainFuckOp
61 op (Hask.Haskell (Hask.ValueCode (Hask.Value c) _)) = case c of
62 '>' -> item $> haskell RightPointer [||RightPointer||]
63 '<' -> item $> haskell LeftPointer [||LeftPointer||]
64 '+' -> item $> haskell Increment [||Increment||]
65 '-' -> item $> haskell Decrement [||Decrement||]
66 '.' -> item $> haskell Output [||Output||]
67 ',' -> item $> haskell Input [||Input||]
68 '[' -> between (lexeme item) (char ']') (haskell Loop [||Loop||] <$> bf)
69 _ -> undefined
70 op _ = undefined