]> Git — Sourcephile - haskell/symantic-parser.git/blob - test/Golden.hs
grammar: open the Comb data-type
[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.Haskell as H
27 import qualified Parser
28 --import qualified Golden.Splice
29
30 goldensIO :: IO TestTree
31 goldensIO = return $ testGroup "Golden"
32 [ goldensGrammar
33 -- Commented-out for the release
34 -- because resetTHNameCounter is not enough:
35 -- TH names still change between runs
36 -- with and without --accept
37 , goldensMachine
38 , goldensParser
39 --, Golden.Splice.goldens
40 ]
41
42 goldensGrammar :: TestTree
43 goldensGrammar = testGroup "Grammar"
44 [ testGroup "ViewGrammar" $ tests $ \name repr ->
45 let file = "test/Golden/Grammar/"<>name<>".dump" in
46 goldenVsStringDiff file diffGolden file $ do
47 resetTHNameCounter
48 return $ fromString $ show $
49 P.viewGrammar $ P.observeSharing repr
50 , testGroup "OptimizeGrammar" $ tests $ \name repr ->
51 let file = "test/Golden/Grammar/"<>name<>".opt.dump" in
52 goldenVsStringDiff file diffGolden file $ do
53 resetTHNameCounter
54 return $ fromString $ show $
55 P.viewGrammar $ P.optimizeGrammar $ P.observeSharing repr
56 ]
57 where
58 tests :: P.Grammar Char repr =>
59 (forall a. String -> repr a -> TestTree) -> [TestTree]
60 tests test =
61 [ test "unit" $ P.unit
62 , test "unit-unit" $ P.unit P.*> P.unit
63 , test "app" $ P.pure H.id P.<*> P.unit
64 , test "string" $ P.string "abcd"
65 , test "tokens" $ P.tokens "abcd"
66 , test "many-a" $ P.many (P.char 'a')
67 , test "boom" $ Parser.boom
68 , test "brainfuck" $ Parser.brainfuck
69 , test "many-char-eof" $ P.many (P.char 'r') P.<* P.eof
70 , test "eof" $ P.eof
71 , test "nandlang" $ Parser.nandlang
72 ]
73
74 goldensMachine :: TestTree
75 goldensMachine = testGroup "Machine"
76 [ testGroup "DumpInstr" $ tests $ \name repr ->
77 let file = "test/Golden/Machine/"<>name<>".dump" in
78 goldenVsStringDiff file diffGolden file $ do
79 resetTHNameCounter
80 return $ fromString $ show $
81 P.viewMachine repr
82 ]
83 where
84 tests ::
85 P.Executable Char repr =>
86 (forall vs es ret. String -> repr Text vs es ret -> TestTree) -> [TestTree]
87 tests test =
88 [ test "unit" $ P.machine $ P.unit
89 , test "unit-unit" $ P.machine $ P.unit P.*> P.unit
90 , test "string" $ P.machine $ P.string "abcd"
91 , test "a-or-b" $ P.machine $ P.char 'a' P.<|> P.char 'b'
92 , test "app" $ P.machine $ P.pure H.id P.<*> P.unit
93 , test "many-a" $ P.machine $ P.many (P.char 'a')
94 , test "some-string" $ P.machine $ P.some (P.string "abcd")
95 , test "boom" $ P.machine $ Parser.boom
96 , test "brainfuck" $ P.machine $ Parser.brainfuck
97 , test "many-char-eof" $ P.machine $ P.many (P.char 'r') P.<* P.eof
98 , test "eof" $ P.machine $ P.eof
99 , test "many-char-fail" $ P.machine $ P.many (P.char 'a') P.<* P.char 'b'
100 , test "nandlang" $ P.machine $ Parser.nandlang
101 ]
102
103 goldensParser :: TestTree
104 goldensParser = testGroup "Parser"
105 [ testGroup "runParser" $ tests $ \name p ->
106 let file = "test/Golden/Parser/"<>name in
107 goldenVsStringDiff (file<>".txt") diffGolden (file<>".dump") $ do
108 input :: Text <- readFile (file<>".txt")
109 return $ fromString $
110 case p input of
111 Left err -> show err
112 Right a -> show a
113 ]
114 where
115 tests :: (forall a. Show a => String -> (Text -> Either (P.ParsingError Text) a) -> TestTree) -> [TestTree]
116 tests test =
117 [ test "char" $$(P.runParser $ P.char 'a')
118 , test "string" $$(P.runParser $ P.string "abc")
119 , test "string-fail-horizon" $$(P.runParser $ P.string "abc")
120 , test "many-char" $$(P.runParser $ P.many (P.char 'a'))
121 , test "some-string" $$(P.runParser $ P.some (P.string "abcd"))
122 , test "some-string-fail" $$(P.runParser $ P.some (P.string "abcd"))
123 , test "some-string-eof-fail" $$(P.runParser $ P.some (P.string "abcd") P.<* P.eof)
124 , test "alt-right-notry" $$(P.runParser $ P.traverse P.char "aa" P.<|> P.traverse P.char "ab")
125 , test "alt-right-try" $$(P.runParser $ P.string "aa" P.<|> P.string "ab")
126 , test "alt-left" $$(P.runParser $ P.string "aa" P.<|> P.string "ab")
127 , test "many-char-eof" $$(P.runParser $ P.many (P.char 'r') P.<* P.eof)
128 , test "eof" $$(P.runParser $ P.eof)
129 , test "eof-fail" $$(P.runParser $ P.eof)
130 , test "alt-char-fail" $$(P.runParser $ P.char 'a' P.<|> P.char 'b')
131 , test "many-char-fail" $$(P.runParser $ P.many (P.char 'a') P.<* P.char 'b')
132 , test "many-oneOf" $$(P.runParser $ P.many (P.oneOf ['a', 'b', 'c', 'd']) P.<* P.eof)
133 ]
134
135 -- | Resetting 'TH.counter' makes 'makeLetName' deterministic,
136 -- except when flags change, like profiling
137 -- or even --accept unfortunately,
138 -- in those case the 'goldensMachine' tests may fail
139 -- due to a different numbering of the 'def' and 'ref' combinators.
140 resetTHNameCounter :: IO ()
141 resetTHNameCounter = IORef.writeIORef TH.counter 0
142
143 -- * Golden testing utilities
144
145 diffGolden :: FilePath -> FilePath -> [String]
146 diffGolden ref new = ["diff", "-u", ref, new]
147
148 unLeft :: Either String BSL.ByteString -> IO BSL.ByteString
149 unLeft = \case
150 Left err -> return $ TL.encodeUtf8 $ TL.pack err
151 Right a -> return a