]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser.hs
Remove unsafePerformIO to get StableName-s
[haskell/symantic-parser.git] / 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