symantic-grammar/Language/Symantic/Grammar/Test.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 module Test 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 Gram_AltApp
  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.anyChar
  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  = Gram_AltApp.empty
  38         (<+>)  = (Gram_AltApp.<|>)
  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  ]
 109
 110 main :: IO ()
 111 main =
 112         defaultMain $
 113         testGroup "Language.Symantic"
 114          [hunits]