]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser.hs
Polish
[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 , module Symantic.Univariant.Trans
7 ) where
8 import Symantic.Univariant.Trans
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