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