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