Add first golden tests for the Automaton
authorJulien Moutinho <julm+symantic-parser@sourcephile.fr>
Wed, 21 Oct 2020 06:12:43 +0000 (08:12 +0200)
committerJulien Moutinho <julm+symantic-parser@sourcephile.fr>
Wed, 21 Oct 2020 06:12:43 +0000 (08:12 +0200)
src/Symantic/Parser/Automaton.hs
src/Symantic/Parser/Automaton/Dump.hs
src/Symantic/Parser/Automaton/Instructions.hs
symantic-parser.cabal
test/Golden.hs
test/Golden/Automaton/app.dump [new file with mode: 0644]
test/Golden/Automaton/boom.dump [new file with mode: 0644]
test/Golden/Automaton/unit-unit.dump [new file with mode: 0644]
test/Golden/Automaton/unit.dump [new file with mode: 0644]

index 4c4864c0f62ba5366a8295d7e8708e0936786042..484dbdaa05d4115a26aff42c85293bfb6f0515c7 100644 (file)
@@ -10,7 +10,10 @@ import Symantic.Parser.Grammar
 import Data.Function ((.))
 import qualified Language.Haskell.TH.Syntax as TH
 
-generateAutomaton ::
-  Grammar repr =>
-  ObserveSharing TH.Name (OptimizeComb TH.Name repr) a -> repr a
-generateAutomaton = optimizeComb . observeSharing
+automaton :: forall inp repr a.
+  InputPosition inp =>
+  Executable repr =>
+  Grammar (Automaton inp a) =>
+  ObserveSharing TH.Name (OptimizeComb TH.Name (Automaton inp a)) a ->
+  repr inp '[] ('Succ 'Zero) a a
+automaton = runAutomaton . optimizeComb . observeSharing
index e6ef26ff70ad6f15228cf8c9baf92b635f9e9b71..50196a41671249257772ec2e8c63babd81df5604 100644 (file)
@@ -48,6 +48,8 @@ instance Inputable DumpInstr where
   tell k = DumpInstr $ Tree.Node "tell" [unDumpInstr k]
 instance Routinable DumpInstr where
   label n k = DumpInstr $ Tree.Node ("label "<>show n) [unDumpInstr k]
-  call n k = DumpInstr $ Tree.Node ("call "<>show n) [unDumpInstr k]
   jump n = DumpInstr $ Tree.Node ("jump "<>show n) []
+  call n k = DumpInstr $ Tree.Node ("call "<>show n) [unDumpInstr k]
   ret = DumpInstr $ Tree.Node "ret" []
+instance Readable DumpInstr where
+  read _p k = DumpInstr $ Tree.Node "read" [unDumpInstr k]
index ccd455a947abbb1fdc857f8bc27b7593a442e15f..8438820dc992f10bb03360172336500c3a6459ad 100644 (file)
@@ -4,6 +4,7 @@
 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 (($), (.))
@@ -15,16 +16,16 @@ import qualified Symantic.Parser.Staging as Hask
 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 ::
@@ -84,17 +85,28 @@ data Instr input valueStack (exceptionStack::Peano) returnValue a where
     [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
@@ -113,45 +125,84 @@ type Executable repr =
   , 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)
@@ -165,20 +216,31 @@ instance
     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
 
@@ -193,11 +255,11 @@ data Automaton inp a x = Automaton { unAutomaton ::
   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
@@ -218,6 +280,8 @@ instance
     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
@@ -242,3 +306,6 @@ instance Letable TH.Name (Automaton inp a) where
   ref _isRec n = Automaton $ \case
     Ret -> Jump (Addr n)
     k -> Call (Addr n) k
+instance Foldable (Automaton inp a) where
+  chainPre = undefined
+  chainPost = undefined
index 7ad2857bd52be55611f1c04ebb61de49ee117460..9c8eb8f41e80113a97c31a86eada13e9944966fd 100644 (file)
@@ -85,7 +85,11 @@ Test-Suite symantic-parser-test
     NamedFieldPuns
     NoImplicitPrelude
     RecordWildCards
+    RankNTypes,
+    ScopedTypeVariables
+    TypeApplications
     TypeFamilies
+    TypeOperators
     ViewPatterns
   ghc-options:
     -Wall
index 40d27311f7313bf54d7c3bf75477769ee43c57cb..36d65235beb0c474f55a78102f1f068631ad3a9f 100644 (file)
@@ -1,4 +1,5 @@
 {-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE Rank2Types #-}
 module Golden where
 
@@ -19,30 +20,27 @@ import qualified Language.Haskell.TH.Syntax as TH
 
 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
@@ -51,10 +49,35 @@ goldensGrammar = testGroup "Grammar"
     [ 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]
diff --git a/test/Golden/Automaton/app.dump b/test/Golden/Automaton/app.dump
new file mode 100644 (file)
index 0000000..638eb3a
--- /dev/null
@@ -0,0 +1,2 @@
+push InstrPureHaskell (Haskell ())
+` ret
diff --git a/test/Golden/Automaton/boom.dump b/test/Golden/Automaton/boom.dump
new file mode 100644 (file)
index 0000000..a07e1a5
--- /dev/null
@@ -0,0 +1,31 @@
+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
diff --git a/test/Golden/Automaton/unit-unit.dump b/test/Golden/Automaton/unit-unit.dump
new file mode 100644 (file)
index 0000000..2cb8c86
--- /dev/null
@@ -0,0 +1,7 @@
+push InstrPureHaskell (const id)
+` label Addr {unLabel = let_1}
+  ` push InstrPureHaskell ()
+    ` liftI2 InstrPureHaskell ($)
+      ` call Addr {unLabel = let_1}
+        ` liftI2 InstrPureHaskell ($)
+          ` ret
diff --git a/test/Golden/Automaton/unit.dump b/test/Golden/Automaton/unit.dump
new file mode 100644 (file)
index 0000000..f2dfba8
--- /dev/null
@@ -0,0 +1,2 @@
+push InstrPureHaskell ()
+` ret