]> Git — Sourcephile - haskell/symantic-parser.git/blob - test/Golden.hs
rename {Automaton => Machine}
[haskell/symantic-parser.git] / test / Golden.hs
1 {-# LANGUAGE NoMonomorphismRestriction #-}
2 {-# LANGUAGE Rank2Types #-}
3 {-# LANGUAGE TemplateHaskell #-}
4 {-# LANGUAGE UnboxedTuples #-}
5 module Golden where
6
7 import Control.Monad (Monad(..))
8 import Data.Char (Char)
9 import Data.Either (Either(..))
10 import Data.Function (($))
11 import Data.Semigroup (Semigroup(..))
12 import Data.String (String, IsString(..))
13 import Data.Text (Text)
14 import Data.Text.IO (readFile)
15 import System.IO (IO, FilePath)
16 import Test.Tasty
17 import Test.Tasty.Golden
18 import Text.Show (Show(..))
19 import qualified Data.ByteString.Lazy as BSL
20 import qualified Data.IORef as IORef
21 import qualified Data.Text.Lazy as TL
22 import qualified Data.Text.Lazy.Encoding as TL
23 import qualified Language.Haskell.TH.Syntax as TH
24
25 import qualified Symantic.Parser as P
26 import qualified Symantic.Parser.Staging as H
27 import qualified Golden.Grammar as Grammar
28 --import Golden.Utils
29
30 goldensIO :: IO TestTree
31 goldensIO = return $ testGroup "Golden"
32 [ goldensGrammar
33 , goldensMachine
34 , goldensParser
35 ]
36
37 goldensGrammar :: TestTree
38 goldensGrammar = testGroup "Grammar"
39 [ testGroup "DumpComb" $ tests $ \name repr ->
40 let file = "test/Golden/Grammar/"<>name<>".dump" in
41 goldenVsStringDiff file diffGolden file $ do
42 resetTHNameCounter
43 return $ fromString $ show $
44 P.dumpComb $ P.observeSharing repr
45 , testGroup "OptimizeComb" $ tests $ \name repr ->
46 let file = "test/Golden/Grammar/"<>name<>".opt.dump" in
47 goldenVsStringDiff file diffGolden file $ do
48 resetTHNameCounter
49 return $ fromString $ show $
50 P.dumpComb $ P.optimizeComb $ P.observeSharing repr
51 ]
52 where
53 tests :: P.Grammar repr =>
54 P.Satisfiable repr Char =>
55 (forall a. String -> repr a -> TestTree) -> [TestTree]
56 tests test =
57 [ test "unit" $ P.unit
58 , test "unit-unit" $ P.unit P.*> P.unit
59 , test "app" $ P.pure (H.Haskell H.id) P.<*> P.unit
60 , test "many-a" $ P.many (P.char 'a')
61 , test "boom" $ Grammar.boom
62 , test "brainfuck" $ Grammar.brainfuck
63 , test "many-char-eof" $ P.many (P.char 'r') P.<* P.eof
64 , test "eof" $ P.eof
65 ]
66
67 goldensMachine :: TestTree
68 goldensMachine = testGroup "Machine"
69 [ testGroup "DumpInstr" $ tests $ \name repr ->
70 let file = "test/Golden/Machine/"<>name<>".dump" in
71 goldenVsStringDiff file diffGolden file $ do
72 resetTHNameCounter
73 return $ fromString $ show $
74 P.dumpInstr $ {-P.machine @() $ -}repr
75 ]
76 where
77 tests ::
78 P.Executable repr =>
79 P.Readable repr Char =>
80 (forall vs es ret. String -> repr Text vs es ret -> TestTree) -> [TestTree]
81 tests test =
82 [ test "unit" $ P.machine $ P.unit
83 , test "unit-unit" $ P.machine $ P.unit P.*> P.unit
84 , test "a-or-b" $ P.machine $ P.char 'a' P.<|> P.char 'b'
85 , test "app" $ P.machine $ P.pure (H.Haskell H.id) P.<*> P.unit
86 , test "many-a" $ P.machine $ P.many (P.char 'a')
87 , test "boom" $ P.machine $ Grammar.boom
88 , test "brainfuck" $ P.machine $ Grammar.brainfuck
89 , test "many-char-eof" $ P.machine $ P.many (P.char 'r') P.<* P.eof
90 , test "eof" $ P.machine $ P.eof
91 , test "many-char-fail" $ P.machine $ P.many (P.char 'a') P.<* P.char 'b'
92 ]
93
94 goldensParser :: TestTree
95 goldensParser = testGroup "Parser"
96 [ testGroup "runParser" $ tests $ \name p ->
97 let file = "test/Golden/Parser/"<>name in
98 goldenVsStringDiff (file<>".txt") diffGolden (file<>".dump") $ do
99 input :: Text <- readFile (file<>".txt")
100 return $ fromString $
101 case p input of
102 Left err -> show err
103 Right a -> show a
104 ]
105 where
106 tests :: (forall a. Show a => String -> (Text -> Either (P.ParsingError Text) a) -> TestTree) -> [TestTree]
107 tests test =
108 [ test "char" $$(P.runParser $ P.char 'a')
109 , test "string" $$(P.runParser $ P.string "ab")
110 , test "many-char" $$(P.runParser $ P.many (P.char 'a'))
111 , test "alt-right" $$(P.runParser $ P.string "aa" P.<|> P.string "ab")
112 , test "alt-right-try" $$(P.runParser $ P.try (P.string "aa") P.<|> P.string "ab")
113 , test "alt-left" $$(P.runParser $ P.string "aa" P.<|> P.string "ab")
114 , test "many-char-eof" $$(P.runParser $ P.many (P.char 'r') P.<* P.eof)
115 , test "eof" $$(P.runParser $ P.eof)
116 , test "eof-fail" $$(P.runParser $ P.eof)
117 -- , test "alt-char-fail" $$(P.runParser $ P.char 'a' P.<|> P.char 'b')
118 -- , test "alt-char-fail" $$(P.runParser $ P.some (P.char 'a') P.<|> P.string "b")
119 , test "many-char-fail" $$(P.runParser $ P.many (P.char 'a') P.<* P.char 'b')
120 -- , test "alt-char-try-fail" $$(P.runParser $ P.try (P.char 'a') P.<|> P.char 'b')
121 ]
122
123 -- | Resetting 'TH.counter' makes 'makeLetName' deterministic,
124 -- except when profiling is enabled, in this case those tests may fail
125 -- due to a different numbering of the 'def' and 'ref' combinators.
126 resetTHNameCounter :: IO ()
127 resetTHNameCounter = IORef.writeIORef TH.counter 0
128
129 -- * Golden testing utilities
130
131 diffGolden :: FilePath -> FilePath -> [String]
132 diffGolden ref new = ["diff", "-u", ref, new]
133
134 unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
135 unLeft = \case
136 Left err -> return $ TL.encodeUtf8 $ TL.pack err
137 Right a -> return a