impl: make `HideName` support newer constructors

[haskell/symantic-parser.git] / src / Symantic / Parser.hs

diff --git a/src/Symantic/Parser.hs b/src/Symantic/Parser.hs
index 721e0e64255eee9c9c9067aca69cdd47ace7ec9d..d3e5fb6752118e57ba564e406b2b9abfb138e738 100644 (file)
--- a/src/Symantic/Parser.hs
+++ b/src/Symantic/Parser.hs
@@ -1,106 +1,28 @@
-{-# LANGUAGE TemplateHaskell #-}
 module Symantic.Parser
- ( module Symantic.Parser.Grammar
- --, module Symantic.Parser.Staging
- , module Symantic.Parser
- , module Symantic.Univariant.Trans
- ) where
-import Symantic.Univariant.Trans
-import Symantic.Parser.Grammar
-import qualified Symantic.Parser.Staging as Hask
-
---import Prelude hiding (fmap, pure, (<*), (*>), (<*>), (<$>), (<$), pred, repeat)
-import Data.Int (Int)
--- import Data.Char (Char)
-import Prelude (undefined)
-import Data.String (String)
-import Text.Show (Show)
-import Data.Eq (Eq)
--- import Control.Monad (liftM)
--- import Data.Char (isAlpha, isAlphaNum, isSpace, isUpper, isDigit, digitToInt, chr, ord)
--- import Data.Set (fromList, member)
--- import Data.Maybe (catMaybes)
--- import Text.Read (readMaybe)
-import Language.Haskell.TH (TExpQ)
-
-import qualified Prelude
-
-{-
-ee = pure id
-e0 = e0 <* e0 <* e0
-e1 = e1 <* e0
-e2 = e2 <* e0
-e3 = ee <* e1 <* e2
-l0 = lets e0
-l1 = lets e1
-l2 = lets e2
-l3 = lets e3
--}
-
-data Expr = Var String | Num Int | Add Expr Expr deriving Show
-data Asgn = Asgn String Expr deriving Show
-
-data BrainFuckOp = RightPointer | LeftPointer | Increment | Decrement | Output | Input | Loop [BrainFuckOp] deriving (Show, Eq)
-
-{-
-cinput = m --try (string "aaa") <|> string "db" --(string "aab" <|> string "aac") --(char 'a' <|> char 'b') *> string "ab"
-  where
-    --m = match "ab" (lookAhead item) op empty
-    --op 'a' = item $> haskell "aaaaa"
-    --op 'b' = item $> haskell "bbbbb"
-    m = bf <* item
-    -- match :: Eq a => [Pure repr a] -> repr a -> (Pure repr a -> repr b) -> repr b -> repr b
-    bf = match [char '>'] item op empty
-    op (Hask.ValueCode '>' _) = string ">"
--}
+  ( module Symantic.Parser.Grammar
+  , module Symantic.Parser.Machine
+  , module Symantic.Parser
+  ) where
 
---defuncTest = haskell Just <$> (haskell (+) <$> (item $> haskell 1) <*> (item $> haskell 8))
-
--- manyTest = many (string "ab" $> (haskell 'c'))
-
---nfb = negLook (char 'a') <|> void (string "ab")
-
---skipManyInspect = skipMany (char 'a')
-
-boom :: Applicable repr => repr ()
-boom =
-  let foo = (-- newRegister_ unit (\r0 ->
-       let goo = (-- newRegister_ unit (\r1 ->
-             let hoo = {-get r0 <~> get r1 *>-} goo *> hoo in hoo
-            ) *> goo
-       in goo) *> pure Hask.unit
-  in foo *> foo
-
-haskell :: a -> TExpQ a -> Hask.Haskell a
-haskell e c = Hask.Haskell (Hask.ValueCode (Hask.Value e) (Hask.Code c))
-
-brainfuck ::
- forall repr.
- Applicable repr =>
- Charable repr =>
- Selectable repr =>
- Matchable repr =>
- Lookable repr =>
- Alternable repr =>
- Foldable repr =>
- repr [BrainFuckOp]
-brainfuck = whitespace *> bf
-  where
-    whitespace = skipMany (noneOf "<>+-[],.$")
-    lexeme :: repr a -> repr a
-    lexeme p = p <* whitespace
-    -- match :: Eq a => [Pure repr a] -> repr a -> (Pure repr a -> repr b) -> repr b -> repr b
-    bf :: repr [BrainFuckOp]
-    bf = many (lexeme (match ((\c -> haskell c [||c||]) Prelude.<$> "><+-.,[") (look item) op empty))
-    -- op :: Pure repr Char -> repr BrainFuckOp
-    op (Hask.Haskell (Hask.ValueCode (Hask.Value c) _)) = case c of
-     '>' -> item $> haskell RightPointer [||RightPointer||]
-     '<' -> item $> haskell LeftPointer  [||LeftPointer||]
-     '+' -> item $> haskell Increment    [||Increment||]
-     '-' -> item $> haskell Decrement    [||Decrement||]
-     '.' -> item $> haskell Output       [||Output||]
-     ',' -> item $> haskell Input        [||Input||]
-     '[' -> between (lexeme item) (char ']') (haskell Loop [||Loop||] <$> bf)
-     _ -> undefined
-    op _ = undefined
+import Control.Monad.ST (ST, RealWorld)
+import Data.Function (($))
+import Language.Haskell.TH (CodeQ)
+import qualified Language.Haskell.TH.Syntax as TH
 
+import Symantic.Parser.Grammar
+import Symantic.Parser.Machine
+
+-- * Type 'Parser'
+type Parser inp a = Machine Gen inp a
+
+-- ** Type 'Parsed'
+type Parsed inp a = ST RealWorld (Result inp a)
+
+runParser :: forall inp a.
+  Inputable inp =>
+  Machinable (InputToken inp) Gen =>
+  Parser inp a ->
+  CodeQ (inp -> Parsed inp a)
+runParser p = TH.Code $ do
+  mach <- TH.runIO $ machine p
+  TH.examineCode $ generateCode mach