]> Git — Sourcephile - haskell/symantic.git/blob - symantic-grammar/test/HUnit.hs
Update to lastest symantic-document
[haskell/symantic.git] / symantic-grammar / test / HUnit.hs
1 {-# LANGUAGE ConstraintKinds #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 module HUnit where
4
5 import Test.Tasty
6 import Test.Tasty.HUnit
7
8 import Control.Applicative (Applicative(..))
9 import Control.Monad
10 import Data.Semigroup ((<>))
11 import Data.String (IsString(..))
12 import qualified Control.Applicative as Applicative
13 import qualified Data.Char as Char
14 import qualified Data.Text as Text
15 import qualified Text.Megaparsec as P
16 import qualified Text.Megaparsec.Char as P
17
18 import Language.Symantic.Grammar
19
20 -- * Type 'ParsecT'
21 type ParsecC e s = (P.Token s ~ Char, P.Stream s, Ord e)
22 instance (ParsecC e s, Gram_String (P.ParsecT e s m)) => IsString (P.ParsecT e s m String) where
23 fromString = string
24 instance ParsecC e s => Gram_Rule (P.ParsecT e s m) where
25 rule = P.label . Text.unpack
26 instance ParsecC e s => Gram_Char (P.ParsecT e s m) where
27 any = P.anySingle
28 eoi = P.eof
29 char = P.char
30 unicat cat = P.satisfy $ (`elem` cats) . Char.generalCategory
31 where cats = unicode_categories cat
32 range (l, h) = P.satisfy $ \c -> l <= c && c <= h
33 but (Terminal f) (Terminal p) = Terminal $ P.notFollowedBy (P.try p) *> f
34 instance ParsecC e String => Gram_String (P.ParsecT e String m) where
35 string = P.string
36 instance ParsecC e s => Gram_Alt (P.ParsecT e s m) where
37 empty = Applicative.empty
38 (<+>) = (Applicative.<|>)
39 choice = P.choice
40 instance ParsecC e s => Gram_Try (P.ParsecT e s m) where
41 try = P.try
42 instance ParsecC e s => Gram_RegR (P.ParsecT e s m) where
43 Terminal f .*> Reg x = Reg $ f <*> x
44 instance ParsecC e s => Gram_RegL (P.ParsecT e s m) where
45 Reg f <*. Terminal x = Reg $ f <*> x
46 instance ParsecC e s => Gram_App (P.ParsecT e s m)
47 instance ParsecC e s => Gram_AltApp (P.ParsecT e s m)
48 instance ParsecC e s => Gram_CF (P.ParsecT e s m) where
49 CF f <& Reg p = CF $ P.lookAhead f <*> p
50 Reg f &> CF p = CF $ P.lookAhead f <*> p
51 CF f `minus` Reg p = CF $ P.notFollowedBy (P.try p) *> f
52 instance ParsecC e String => Gram_Comment (P.ParsecT e String m)
53
54 elide :: Text.Text -> String
55 elide s | Text.length s > 42 = take 42 (Text.unpack s) <> ['…']
56 elide s = Text.unpack s
57
58 hunits :: TestTree
59 hunits = testGroup "Grammar"
60 [ testGroup "Terminal" $
61 let (==>) input expected =
62 testCase (elide expected) $
63 runEBNF (unTerminal (void input)) @?= expected
64 ; infix 1 ==> in
65 [ string "" ==> "\"\""
66 , string "abé\"to" ==> "\"abé\", U+34, \"to\""
67 , string "\"" ==> "U+34"
68 , range ('a', 'z') ==> "\"a\"…\"z\""
69 , unicat Unicat_Letter ==> "Unicat_Letter"
70 , unicat (Unicat Char.LowercaseLetter) ==> "Unicat LowercaseLetter"
71 ]
72 , testGroup "Reg" $
73 let (==>) input expected =
74 testCase (elide expected) $
75 runEBNF (unReg (void input)) @?= expected
76 ; infix 1 ==> in
77 [ (<>) <$> string "0" .*> someR (char '1') ==> "\"0\", {\"1\"}-"
78 , (<>) <$> someL (char '1') <*. string "0" ==> "{\"1\"}-, \"0\""
79 ]
80 , testGroup "CF" $
81 let (==>) input expected =
82 testCase (elide expected) $
83 runEBNF (unCF (void input)) @?= expected
84 ; infix 1 ==> in
85 [ (<>) <$> string "0" <*> string "1" ==> "\"0\", \"1\""
86 , (<>) <$> string "0" <* string "X" <*> string "1" ==> "\"0\", \"X\", \"1\""
87 , (<>) <$> (string "0" <+> string "1") <*> string "2" ==> "(\"0\" | \"1\"), \"2\""
88 , (<>) <$> string "0" <*> (string "1" <+> string "2") ==> "\"0\", (\"1\" | \"2\")"
89 , string "0" <+> string "1" <+> string "2" ==> "\"0\" | \"1\" | \"2\""
90 , choice [string "0", string "1", string "2"] ==> "\"0\" | \"1\" | \"2\""
91 , (<>) <$> choice
92 [ (<>) <$> string "0" <*> string "1"
93 , string "2" <+> string "3"
94 , string "4"
95 ] <*> string "5" ==> "(\"0\", \"1\" | \"2\" | \"3\" | \"4\"), \"5\""
96 , concat <$> many (string "0") ==> "{\"0\"}"
97 , () <$ char 'a' <* char 'b' <* char 'c' ==> "\"a\", \"b\", \"c\""
98 ,let g0 = (<>) <$> string "0" .*> someR (char '1') in
99 (<>) <$> string "0" <& g0 ==> "\"0\" & \"0\", {\"1\"}-"
100 ,let g0 = (<>) <$> string "0" .*> someR (char '1') in
101 let g1 = (<>) <$> someL (char '1') <*. string "0" in
102 string "0" `minus` g0 `minus` g1 ==>
103 "\"0\" - \"0\", {\"1\"}- - {\"1\"}-, \"0\""
104 , (<>)
105 <$> many (string "0" <+> string "1")
106 <*> some (string "2") ==> "{\"0\" | \"1\"}, {\"2\"}-"
107 ]
108 ]