test/Golden/Grammar.hs

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