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 qualified Control.Applicative as Alt
  10 import Control.Monad
  11 import qualified Data.Char as Char
  12 import Data.Functor.Identity
  13 import Data.Monoid ((<>))
  14 import Data.String (IsString(..))
  15 import qualified Data.Text as Text
  16 import Prelude hiding (any, (^), exp)
  17 import qualified Text.Megaparsec as P
  18
  19 import Language.Symantic.Grammar
  20
  21 -- * Type 'ParsecT'
  22 type ParsecC e s = (P.Token s ~ Char, P.Stream s, P.ErrorComponent e)
  23 instance ParsecC e s => IsString (P.ParsecT e s m [Char]) where
  24         fromString = P.string
  25 instance ParsecC e s => Gram_Rule (P.ParsecT e s m) where
  26         rule = P.label . Text.unpack
  27 instance ParsecC e s => Gram_Terminal (P.ParsecT e s m) where
  28         any          = P.anyChar
  29         eoi          = P.eof
  30         char         = P.char
  31         string       = P.string
  32         unicat cat   = P.satisfy $ (`elem` cats) . Char.generalCategory
  33                 where cats = unicode_categories cat
  34         range (l, h) = P.satisfy $ \c -> l <= c && c <= h
  35         but (Terminal f) (Terminal p) = Terminal $ P.notFollowedBy (P.try p) *> f
  36 instance ParsecC e s => Alter (P.ParsecT e s m) where
  37         empty  = Alt.empty
  38         (<+>)  = (Alt.<|>)
  39         choice = P.choice
  40 instance ParsecC e s => 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 => App (P.ParsecT e s m)
  47 instance ParsecC e s => Alt (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         minus (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f
  52 instance ParsecC e s => Gram_Meta P.SourcePos (P.ParsecT e s m) where
  53         metaG p = do
  54                 pos <- P.getPosition
  55                 ($ pos) <$> p
  56 instance ParsecC e s => Gram_Lexer (P.ParsecT e s m)
  57
  58 runParserT :: Monad m
  59  => P.ParsecT P.Dec s m a -> s
  60  -> m (Either (P.ParseError (P.Token s) P.Dec) a)
  61 runParserT p = P.runParserT p ""
  62
  63 runParser
  64  :: P.ParsecT P.Dec s Identity a -> s
  65  -> Either (P.ParseError (P.Token s) P.Dec) a
  66 runParser p = P.runParser p ""
  67
  68 elide :: String -> String
  69 elide s | length s > 42 = take 42 s ++ ['…']
  70 elide s = s
  71
  72 tests :: TestTree
  73 tests = testGroup "Grammar"
  74  [ testGroup "Terminal" $
  75         let (==>) inp exp =
  76                 testCase (elide $ Text.unpack exp) $
  77                 runEBNF (unTerminal (void inp)) @?= exp
  78                 ; infix 1 ==> in
  79          [ string "" ==> "\"\""
  80          , string "abé\"to" ==> "\"abé\", U+34, \"to\""
  81          , string "\"" ==> "U+34"
  82          , range ('a', 'z') ==> "\"a\"…\"z\""
  83          , unicat Unicat_Letter ==> "Unicat_Letter"
  84          , unicat (Unicat Char.LowercaseLetter) ==> "Unicat LowercaseLetter"
  85          ]
  86  , testGroup "Reg" $
  87         let (==>) inp exp =
  88                 testCase (elide $ Text.unpack exp) $
  89                 runEBNF (unReg (void inp)) @?= exp
  90                 ; infix 1 ==> in
  91          [ (<>) <$> string "0" .*> someR (char '1') ==> "\"0\", {\"1\"}-"
  92          , (<>) <$> someL (char '1') <*. string "0" ==> "{\"1\"}-, \"0\""
  93          ]
  94  , testGroup "CF" $
  95         let (==>) inp exp =
  96                 testCase (elide $ Text.unpack exp) $
  97                 runEBNF (unCF (void inp)) @?= exp
  98                 ; infix 1 ==> in
  99          [ (<>) <$> string "0" <*> string "1" ==> "\"0\", \"1\""
 100          , (<>) <$> string "0" <* string "X" <*> string "1" ==> "\"0\", \"X\", \"1\""
 101          , (<>) <$> (string "0" <+> string "1") <*> string "2" ==> "(\"0\" | \"1\"), \"2\""
 102          , (<>) <$> string "0" <*> (string "1" <+> string "2") ==> "\"0\", (\"1\" | \"2\")"
 103          , string "0" <+> string "1" <+> string "2" ==> "\"0\" | \"1\" | \"2\""
 104          , choice [string "0", string "1", string "2"] ==> "\"0\" | \"1\" | \"2\""
 105          , (<>) <$> choice
 106                  [ (<>) <$> string "0" <*> string "1"
 107                  , string "2" <+> string "3"
 108                  , string "4"
 109                  ] <*> string "5" ==> "(\"0\", \"1\" | \"2\" | \"3\" | \"4\"), \"5\""
 110          , concat <$> many (string "0") ==> "{\"0\"}"
 111          , () <$ char 'a' <* char 'b' <* char 'c' ==> "\"a\", \"b\", \"c\""
 112          ,let g0  = (<>) <$> string "0" .*> someR (char '1') in
 113                 (<>) <$> string "0" <& g0 ==> "\"0\" & \"0\", {\"1\"}-"
 114          ,let g0  = (<>) <$> string "0" .*> someR (char '1') in
 115                 let g1 = (<>) <$> someL (char '1') <*. string "0" in
 116                 string "0" `minus` g0 `minus` g1 ==>
 117                 "\"0\" - \"0\", {\"1\"}- - {\"1\"}-, \"0\""
 118          , (<>)
 119                  <$> many (string "0" <+> string "1")
 120                  <*> some (string "2") ==> "{\"0\" | \"1\"}, {\"2\"}-"
 121          ]
 122  ]
 123
 124 main :: IO ()
 125 main =
 126         defaultMain $
 127         testGroup "Language.Symantic"
 128          [tests]