src/Symantic/Parser.hs

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