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