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.Staging 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