1 {-# LANGUAGE NoMonomorphismRestriction #-}
2 {-# LANGUAGE TemplateHaskell #-}
3 module Golden.Grammar where
5 import Data.Char (Char)
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
14 import Symantic.Parser
15 import qualified Symantic.Parser.Haskell as H
17 data Expr = Var String | Num Int | Add Expr Expr deriving Show
18 data Asgn = Asgn String Expr deriving Show
20 data BrainFuckOp = RightPointer | LeftPointer | Increment | Decrement | Output | Input | Loop [BrainFuckOp] deriving (Show, Eq)
23 cinput = m --try (string "aaa") <|> string "db" --(string "aab" <|> string "aac") --(char 'a' <|> char 'b') *> string "ab"
25 --m = match "ab" (lookAhead item) op empty
26 --op 'a' = item $> haskell "aaaaa"
27 --op 'b' = item $> haskell "bbbbb"
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 ">"
34 --defuncTest = haskell Just <$> (haskell (+) <$> (item $> haskell 1) <*> (item $> haskell 8))
36 -- manyTest = many (string "ab" $> (haskell 'c'))
38 --nfb = negLook (char 'a') <|> void (string "ab")
40 --skipManyInspect = skipMany (char 'a')
42 boom :: Applicable repr => repr ()
44 let foo = (-- newRegister_ unit (\r0 ->
45 let goo = (-- newRegister_ unit (\r1 ->
46 let hoo = {-get r0 <~> get r1 *>-} goo *> hoo in hoo
48 in goo) *> pure H.unit
51 haskell :: a -> TH.CodeQ a -> H.Haskell a
52 haskell e c = H.Haskell (H.ValueCode (H.Value e) c)
54 brainfuck :: Satisfiable repr Char => Grammar repr => repr [BrainFuckOp]
55 brainfuck = whitespace *> bf
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)