Language/Symantic/Parsing/Grammar/Test.hs

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