src/Symantic/Parser.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2 module Symantic.Parser
   3  ( module Symantic.Parser.Grammar
   4  --, module Symantic.Parser.Staging
   5  , module Symantic.Parser
   6  ) where
   7 import Symantic.Parser.Grammar
   8 import qualified Symantic.Parser.Staging as Hask
   9
  10 --import Prelude hiding (fmap, pure, (<*), (*>), (<*>), (<$>), (<$), pred, repeat)
  11 import Data.Int (Int)
  12 -- import Data.Char (Char)
  13 import Prelude (undefined)
  14 import Data.String (String)
  15 import Text.Show (Show)
  16 import Data.Eq (Eq)
  17 -- import Control.Monad (liftM)
  18 -- import Data.Char (isAlpha, isAlphaNum, isSpace, isUpper, isDigit, digitToInt, chr, ord)
  19 -- import Data.Set (fromList, member)
  20 -- import Data.Maybe (catMaybes)
  21 -- import Text.Read (readMaybe)
  22 import Language.Haskell.TH (TExpQ)
  23
  24 import qualified Prelude
  25
  26 {-
  27 ee = pure id
  28 e0 = e0 <* e0 <* e0
  29 e1 = e1 <* e0
  30 e2 = e2 <* e0
  31 e3 = ee <* e1 <* e2
  32 l0 = lets e0
  33 l1 = lets e1
  34 l2 = lets e2
  35 l3 = lets e3
  36 -}
  37
  38 data Expr = Var String | Num Int | Add Expr Expr deriving Show
  39 data Asgn = Asgn String Expr deriving Show
  40
  41 data BrainFuckOp = RightPointer | LeftPointer | Increment | Decrement | Output | Input | Loop [BrainFuckOp] deriving (Show, Eq)
  42
  43 {-
  44 cinput = m --try (string "aaa") <|> string "db" --(string "aab" <|> string "aac") --(char 'a' <|> char 'b') *> string "ab"
  45   where
  46     --m = match "ab" (lookAhead item) op empty
  47     --op 'a' = item $> runtime "aaaaa"
  48     --op 'b' = item $> runtime "bbbbb"
  49     m = bf <* item
  50     -- match :: Eq a => [Pure repr a] -> repr a -> (Pure repr a -> repr b) -> repr b -> repr b
  51     bf = match [char '>'] item op empty
  52     op (Hask.Runtime '>' _) = string ">"
  53 -}
  54
  55 --defuncTest = runtime Just <$> (runtime (+) <$> (item $> runtime 1) <*> (item $> runtime 8))
  56
  57 -- manyTest = many (string "ab" $> (runtime 'c'))
  58
  59 --nfb = negLook (char 'a') <|> void (string "ab")
  60
  61 --skipManyInspect = skipMany (char 'a')
  62
  63 boom :: Applicable repr => repr ()
  64 boom =
  65   let foo = (-- newRegister_ unit (\r0 ->
  66        let goo = (-- newRegister_ unit (\r1 ->
  67              let hoo = {-get r0 <~> get r1 *>-} goo *> hoo in hoo
  68             ) *> goo
  69        in goo) *> pure Hask.unit
  70   in foo *> foo
  71
  72 runtime :: a -> TExpQ a -> Hask.Runtime a
  73 runtime e c = Hask.Runtime (Hask.Eval e) (Hask.Code c)
  74
  75 brainfuck ::
  76  forall repr.
  77  Applicable repr =>
  78  Charable repr =>
  79  Selectable repr =>
  80  Matchable repr =>
  81  Lookable repr =>
  82  Alternable repr =>
  83  Foldable repr =>
  84  repr [BrainFuckOp]
  85 brainfuck = whitespace *> bf
  86   where
  87     whitespace = skipMany (noneOf "<>+-[],.$")
  88     lexeme :: repr a -> repr a
  89     lexeme p = p <* whitespace
  90     -- match :: Eq a => [Pure repr a] -> repr a -> (Pure repr a -> repr b) -> repr b -> repr b
  91     bf :: repr [BrainFuckOp]
  92     bf = many (lexeme (match ((\c -> runtime c [||c||]) Prelude.<$> "><+-.,[") (look item) op empty))
  93     -- op :: Pure repr Char -> repr BrainFuckOp
  94     op (Hask.Runtime (Hask.Eval c) _) = case c of
  95      '>' -> item $> runtime RightPointer [||RightPointer||]
  96      '<' -> item $> runtime LeftPointer  [||LeftPointer||]
  97      '+' -> item $> runtime Increment    [||Increment||]
  98      '-' -> item $> runtime Decrement    [||Decrement||]
  99      '.' -> item $> runtime Output       [||Output||]
 100      ',' -> item $> runtime Input        [||Input||]
 101      '[' -> between (lexeme item) (char ']') (runtime Loop [||Loop||] <$> bf)
 102      _ -> undefined
 103