module Symantic.Parser.Automaton.Instructions where
import Data.Bool (Bool)
+import Data.Char (Char)
import Data.Either (Either)
import Data.Eq (Eq)
import Data.Function (($), (.))
import Symantic.Parser.Grammar
import Symantic.Univariant.Trans
+import Prelude (undefined)
+
-- * Class 'InputPosition'
-- | TODO
class InputPosition inp where
+instance InputPosition ()
-- * Type 'Instr'
-- | 'Instr'uctions for the 'Automaton'.
data Instr input valueStack (exceptionStack::Peano) returnValue a where
- -- | @('Ret')@ returns the value in a singleton value-stack.
- Ret ::
- Instr inp '[ret] es ret a
-- | @('Push' x k)@ pushes @(x)@ on the value-stack
-- and continues with the next 'Instr'uction @(k)@.
Push ::
[Instr inp vs es ret a] ->
Instr inp vs es ret a ->
Instr inp (x ': vs) es ret a
+ -- | @('Label' a k)@.
Label ::
Addr ret ->
- Instr inp xs ('Succ es) ret a ->
- Instr inp xs ('Succ es) ret a
- Call ::
- Addr ret ->
- Instr inp (x ': xs) ('Succ es) ret a ->
- Instr inp xs ('Succ es) ret a
+ Instr inp vs ('Succ es) ret a ->
+ Instr inp vs ('Succ es) ret a
+ -- | @('Jump' a k)@.
Jump ::
Addr ret ->
Instr inp '[] ('Succ es) ret a
+ -- | @('Call' a k)@.
+ Call ::
+ Addr ret ->
+ Instr inp (x ': vs) ('Succ es) ret a ->
+ Instr inp vs ('Succ es) ret a
+ -- | @('Ret')@ returns the value in a singleton value-stack.
+ Ret ::
+ Instr inp '[ret] es ret a
+ -- | @('Sat' p k)@.
+ Read ::
+ InstrPure (Char -> Bool) ->
+ Instr inp (Char ': vs) ('Succ es) ret a ->
+ Instr inp vs ('Succ es) ret a
-- ** Type 'InstrPure'
data InstrPure a
, Exceptionable repr
, Inputable repr
, Routinable repr
+ , Readable repr
)
-- ** Class 'Stackable'
class Stackable (repr :: * -> [*] -> Peano -> * -> * -> *) where
- push :: InstrPure x -> repr inp (x ': vs) n ret a -> repr inp vs n ret a
- pop :: repr inp vs n ret a -> repr inp (x ': vs) n ret a
- liftI2 :: InstrPure (x -> y -> z) -> repr inp (z ': vs) es ret a -> repr inp (y ': x ': vs) es ret a
- swap :: repr inp (x ': y ': vs) n r a -> repr inp (y ': x ': vs) n r a
+ push ::
+ InstrPure x ->
+ repr inp (x ': vs) n ret a ->
+ repr inp vs n ret a
+ pop ::
+ repr inp vs n ret a ->
+ repr inp (x ': vs) n ret a
+ liftI2 ::
+ InstrPure (x -> y -> z) ->
+ repr inp (z ': vs) es ret a ->
+ repr inp (y ': x ': vs) es ret a
+ swap ::
+ repr inp (x ': y ': vs) n r a ->
+ repr inp (y ': x ': vs) n r a
-- ** Class 'Branchable'
class Branchable (repr :: * -> [*] -> Peano -> * -> * -> *) where
- case_ :: repr inp (x ': vs) n r a -> repr inp (y ': vs) n r a -> repr inp (Either x y ': vs) n r a
- choices :: [InstrPure (x -> Bool)] -> [repr inp vs es ret a] -> repr inp vs es ret a -> repr inp (x ': vs) es ret a
+ case_ ::
+ repr inp (x ': vs) n r a ->
+ repr inp (y ': vs) n r a ->
+ repr inp (Either x y ': vs) n r a
+ choices ::
+ [InstrPure (x -> Bool)] ->
+ [repr inp vs es ret a] ->
+ repr inp vs es ret a ->
+ repr inp (x ': vs) es ret a
-- ** Class 'Exceptionable'
class Exceptionable (repr :: * -> [*] -> Peano -> * -> * -> *) where
fail :: repr inp vs ('Succ es) ret a
- commit :: repr inp vs es ret a -> repr inp vs ('Succ es) ret a
- catch :: repr inp vs ('Succ es) ret a -> repr inp (inp ': vs) es ret a -> repr inp vs es ret a
+ commit ::
+ repr inp vs es ret a ->
+ repr inp vs ('Succ es) ret a
+ catch ::
+ repr inp vs ('Succ es) ret a ->
+ repr inp (inp ': vs) es ret a ->
+ repr inp vs es ret a
-- ** Class 'Inputable'
class Inputable (repr :: * -> [*] -> Peano -> * -> * -> *) where
- seek :: repr inp vs es r a -> repr inp (inp ': vs) es r a
- tell :: repr inp (inp ': vs) es ret a -> repr inp vs es ret a
+ seek ::
+ repr inp vs es r a ->
+ repr inp (inp ': vs) es r a
+ tell ::
+ repr inp (inp ': vs) es ret a ->
+ repr inp vs es ret a
-- ** Class 'Routinable'
class Routinable (repr :: * -> [*] -> Peano -> * -> * -> *) where
- label :: Addr ret -> repr inp vs ('Succ es) ret a -> repr inp vs ('Succ es) ret a
- call :: Addr ret -> repr inp (x ': vs) ('Succ es) ret a -> repr inp vs ('Succ es) ret a
- ret :: repr inp '[ret] es ret a
- jump :: Addr ret -> repr inp '[] ('Succ es) ret a
+ label ::
+ Addr ret ->
+ repr inp vs ('Succ es) ret a ->
+ repr inp vs ('Succ es) ret a
+ call ::
+ Addr ret ->
+ repr inp (x ': vs) ('Succ es) ret a ->
+ repr inp vs ('Succ es) ret a
+ ret ::
+ repr inp '[ret] es ret a
+ jump ::
+ Addr ret ->
+ repr inp '[] ('Succ es) ret a
+
+-- ** Class 'Readable'
+class Readable (repr :: * -> [*] -> Peano -> * -> * -> *) where
+ read ::
+ InstrPure (Char -> Bool) ->
+ repr inp (Char ': vs) ('Succ es) ret a ->
+ repr inp vs ('Succ es) ret a
instance
- ( Stackable repr
- , Branchable repr
- , Exceptionable repr
- , Inputable repr
- , Routinable repr
- ) => Trans (Instr inp vs es ret) (repr inp vs es ret) where
+ Executable repr =>
+ Trans (Instr inp vs es ret) (repr inp vs es ret) where
trans = \case
Push x k -> push x (trans k)
Pop k -> pop (trans k)
Swap k -> swap (trans k)
Choices ps bs d -> choices ps (trans Functor.<$> bs) (trans d)
Label n k -> label n (trans k)
+ Jump n -> jump n
Call n (k::Instr inp (x ': vs) ('Succ es') ret a) ->
call n (trans k :: repr inp (x ': vs) ('Succ es') ret a)
Ret -> ret
- Jump n -> jump n
+ Read p k -> read p (trans k)
-- ** Type 'Peano'
-- | Type-level natural numbers, using the Peano recursive encoding.
data Peano = Zero | Succ Peano
--- | @('App' k)@ pops @(x)@ and @(x2y)@ from the value-stack, pushes @(x2y x)@ and continues with the next 'Instr'uction @(k)@.
+-- | @('Fmap' f k)@.
+pattern Fmap ::
+ InstrPure (x -> y) ->
+ Instr inp (y ': xs) es ret a ->
+ Instr inp (x ': xs) es ret a
+pattern Fmap f k = Push f (LiftI2 (InstrPureHaskell (Hask.Flip Hask.:@ (Hask.:$))) k)
+
+-- | @('App' k)@ pops @(x)@ and @(x2y)@ from the value-stack,
+-- pushes @(x2y x)@ and continues with the next 'Instr'uction @(k)@.
pattern App :: Instr inp (y : vs) es ret a -> Instr inp (x : (x -> y) : vs) es ret a
pattern App k = LiftI2 (InstrPureHaskell (Hask.:$)) k
--- | @('If' ok ko)@ pops a 'Bool' from the value-stack and continues either with the 'Instr'uction @(ok)@ if it is 'True' or @(ko)@ otherwise.
+-- | @('If' ok ko)@ pops a 'Bool' from the value-stack
+-- and continues either with the 'Instr'uction @(ok)@ if it is 'True'
+-- or @(ko)@ otherwise.
pattern If :: Instr inp vs es ret a -> Instr inp vs es ret a -> Instr inp (Bool ': vs) es ret a
pattern If ok ko = Choices [InstrPureHaskell Hask.Id] [ok] ko
Instr inp vs ('Succ es) ret a
}
-automaton ::
+runAutomaton ::
forall inp a es repr.
Executable repr =>
Automaton inp a a -> (repr inp '[] ('Succ es) a) a
-automaton =
+runAutomaton =
trans @(Instr inp '[] ('Succ es) a) .
($ Ret) .
unAutomaton
Catch (l (Commit k)) (parsecHandler (r k))
try (Automaton x) = Automaton $ \k ->
Catch (x (Commit k)) (Seek Fail)
+instance Charable (Automaton inp a) where
+ satisfy p = Automaton $ Read (InstrPureHaskell p)
instance Selectable (Automaton inp a) where
branch (Automaton lr) (Automaton l) (Automaton r) = Automaton $ \k ->
-- TODO: join points
ref _isRec n = Automaton $ \case
Ret -> Jump (Addr n)
k -> Call (Addr n) k
+instance Foldable (Automaton inp a) where
+ chainPre = undefined
+ chainPost = undefined
{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Rank2Types #-}
module Golden where
import qualified Symantic.Parser as P
import qualified Symantic.Parser.Staging as Hask
-import Golden.Grammar
+import qualified Golden.Grammar as Grammar
goldensIO :: IO TestTree
goldensIO = return $ testGroup "Golden"
[ goldensGrammar
+ , goldensAutomaton
]
-
goldensGrammar :: TestTree
goldensGrammar = testGroup "Grammar"
[ testGroup "DumpComb" $
tests $ \name repr ->
let file = "test/Golden/Grammar/"<>name<>".dump" in
goldenVsStringDiff file diffGolden file $ do
- -- XXX: Resetting 'TH.counter' makes 'makeLetName' deterministic,
- -- except when profiling is enabled, in this case those tests may fail
- -- due to a different numbering of the 'def' and 'ref' combinators.
- IORef.writeIORef TH.counter 0
+ resetTHNameCounter
return $ fromString $ show $ P.dumpComb $ P.observeSharing repr
, testGroup "OptimizeComb" $
tests $ \name repr ->
let file = "test/Golden/Grammar/"<>name<>".opt.dump" in
goldenVsStringDiff file diffGolden file $ do
- IORef.writeIORef TH.counter 0
+ resetTHNameCounter
return $ fromString $ show $ P.dumpComb $ P.optimizeComb $ P.observeSharing repr
]
where
[ test "unit" $ P.unit
, test "unit-unit" $ P.unit P.*> P.unit
, test "app" $ P.pure (Hask.Haskell Hask.id) P.<*> P.unit
- , test "boom" $ boom
- , test "brainfuck" $ brainfuck
+ , test "boom" $ Grammar.boom
+ , test "brainfuck" $ Grammar.brainfuck
]
+goldensAutomaton :: TestTree
+goldensAutomaton = testGroup "Automaton"
+ [ testGroup "DumpInstr" $
+ tests $ \name repr ->
+ let file = "test/Golden/Automaton/"<>name<>".dump" in
+ goldenVsStringDiff file diffGolden file $ do
+ resetTHNameCounter
+ return $ fromString $ show $ P.dumpInstr $ {-P.automaton @() $ -}repr
+ ]
+ where
+ tests :: P.Executable repr => (forall vs es ret a. String -> repr () vs es ret a -> TestTree) -> [TestTree]
+ tests test =
+ [ test "unit" $ P.automaton $ P.unit
+ , test "unit-unit" $ P.automaton $ P.unit P.*> P.unit
+ , test "app" $ P.automaton $ P.pure (Hask.Haskell Hask.id) P.<*> P.unit
+ , test "boom" $ P.automaton $ Grammar.boom
+ , test "brainfuck" $ P.automaton $ Grammar.brainfuck
+ ]
+
+-- | Resetting 'TH.counter' makes 'makeLetName' deterministic,
+-- except when profiling is enabled, in this case those tests may fail
+-- due to a different numbering of the 'def' and 'ref' combinators.
+resetTHNameCounter :: IO ()
+resetTHNameCounter = IORef.writeIORef TH.counter 0
+
-- * Golden testing utilities
diffGolden :: FilePath -> FilePath -> [String]
--- /dev/null
+push InstrPureHaskell ((.) ((flip ($)) (const id)) . ((.) (.) . ((.) (.) . ((.) (const id) . const id))))
+` label Addr {unLabel = let_5}
+ ` push InstrPureHaskell (const id)
+ ` label Addr {unLabel = let_2}
+ ` push InstrPureHaskell (const id)
+ ` call Addr {unLabel = let_5}
+ ` liftI2 InstrPureHaskell ($)
+ ` call Addr {unLabel = let_2}
+ ` liftI2 InstrPureHaskell ($)
+ ` liftI2 InstrPureHaskell ($)
+ ` call Addr {unLabel = let_5}
+ ` liftI2 InstrPureHaskell ($)
+ ` liftI2 InstrPureHaskell ($)
+ ` label Addr {unLabel = let_3}
+ ` push InstrPureHaskell ()
+ ` liftI2 InstrPureHaskell ($)
+ ` label Addr {unLabel = let_4}
+ ` push InstrPureHaskell (const id)
+ ` label Addr {unLabel = let_1}
+ ` push InstrPureHaskell (const id)
+ ` call Addr {unLabel = let_4}
+ ` liftI2 InstrPureHaskell ($)
+ ` call Addr {unLabel = let_1}
+ ` liftI2 InstrPureHaskell ($)
+ ` liftI2 InstrPureHaskell ($)
+ ` call Addr {unLabel = let_4}
+ ` liftI2 InstrPureHaskell ($)
+ ` liftI2 InstrPureHaskell ($)
+ ` call Addr {unLabel = let_3}
+ ` liftI2 InstrPureHaskell ($)
+ ` ret