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