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