Language/Symantic/Parsing/Grammar/Test.hs

   1 {-# LANGUAGE ConstrainedClassMethods #-}
   2 {-# LANGUAGE ConstraintKinds #-}
   3 {-# LANGUAGE DataKinds #-}
   4 {-# LANGUAGE DefaultSignatures #-}
   5 {-# LANGUAGE DeriveFunctor #-}
   6 {-# LANGUAGE FlexibleContexts #-}
   7 {-# LANGUAGE FlexibleInstances #-}
   8 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   9 {-# LANGUAGE LambdaCase #-}
  10 {-# LANGUAGE MultiParamTypeClasses #-}
  11 {-# LANGUAGE NamedFieldPuns #-}
  12 {-# LANGUAGE NoMonomorphismRestriction #-}
  13 {-# LANGUAGE OverloadedStrings #-}
  14 {-# LANGUAGE PolyKinds #-}
  15 {-# LANGUAGE Rank2Types #-}
  16 {-# LANGUAGE StandaloneDeriving #-}
  17 {-# LANGUAGE TypeFamilies #-}
  18 {-# LANGUAGE TypeOperators #-}
  19 {-# OPTIONS_GHC -fno-warn-tabs #-}
  20 {-# OPTIONS_GHC -fno-warn-orphans #-}
  21 -- | This module defines symantics
  22 -- for regular or context-free grammars.
  23 -- It is intended to be imported qualified.
  24 module Parsing.Grammar.Test where
  25
  26 import Control.Applicative (Applicative(..), Alternative(..))
  27 import Data.Maybe
  28 import Control.Monad
  29 -- import Control.Comonad
  30 import qualified Data.Char as Char
  31 import Data.Foldable hiding (any)
  32 import Data.Functor.Identity
  33 import qualified Data.List as List
  34 import Data.Semigroup ((<>))
  35 import Data.Proxy
  36 import Data.Text (Text)
  37 import Data.String (IsString(..))
  38 import qualified Data.Text as Text
  39 import qualified Data.Text.IO as Text
  40 import Prelude hiding (any, (^))
  41 import qualified Text.Megaparsec as P
  42 import qualified Text.Megaparsec.Lexer as L
  43
  44 import qualified Language.Symantic.Compiling as Sym
  45 import qualified Language.Symantic.Typing as Sym
  46 import qualified Language.Symantic.Parsing as Sym
  47 import Language.Symantic.Parsing.Grammar
  48
  49 -- * Type 'ParsecT'
  50 type ParsecC e s = (P.Token s ~ Char, P.Stream s, P.ErrorComponent e)
  51 instance ParsecC e s => IsString (P.ParsecT e s m [Char]) where
  52         fromString = P.string
  53 instance ParsecC e s => Gram_Rule (P.ParsecT e s m) where
  54         rule = P.label . Text.unpack
  55 instance ParsecC e s => Gram_Term (P.ParsecT e s m) where
  56         any          = P.anyChar
  57         eof          = P.eof
  58         char         = P.char
  59         string       = P.string
  60         unicat cat   = P.satisfy $ (`List.elem` cats) . Char.generalCategory
  61                 where cats = unicode_categories cat
  62         range (l, h) = P.satisfy $ \c -> l <= c && c <= h
  63 instance ParsecC e s => Alter (P.ParsecT e s m) where
  64         x <+> y = P.try x <|> y
  65 instance ParsecC e s => Gram_RegR (P.ParsecT e s m) where
  66         Term f .*> Reg x = Reg $ f <*> x
  67 instance ParsecC e s => Gram_RegL (P.ParsecT e s m) where
  68         Reg f <*. Term x = Reg $ f <*> x
  69 instance ParsecC e s => App (P.ParsecT e s m)
  70 instance ParsecC e s => Alt (P.ParsecT e s m)
  71 instance ParsecC e s => Gram_CF (P.ParsecT e s m) where
  72         CF f <& Reg p      = CF $ P.lookAhead f <*> p
  73         Reg f &> CF p      = CF $ P.lookAhead f <*> p
  74         but (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f
  75 instance ParsecC e s => Gram_Context (P.ParsecT e s m) where
  76         type Context (P.ParsecT e s m) = P.SourcePos
  77         context = (P.getPosition >>=)
  78 instance ParsecC e s => Gram_Lexer (P.ParsecT e s m)
  79 instance ParsecC e s => Sym.Gram_Type (P.ParsecT e s m)
  80
  81 runParserT :: Monad m
  82  => P.ParsecT P.Dec s m a -> s
  83  -> m (Either (P.ParseError (P.Token s) P.Dec) a)
  84 runParserT p = P.runParserT p ""
  85
  86 runParser
  87  :: P.ParsecT P.Dec s Identity a -> s
  88  -> Either (P.ParseError (P.Token s) P.Dec) a
  89 runParser p = P.runParser p ""
  90
  91
  92
  93 {-
  94 -- Tests
  95 g1  = (<>) <$> string "0" <*> string "1"
  96 g2  = (<>) <$> string "0" <* string "X" <*> string "1"
  97 g3  = (<>) <$> (string "0" <|> string "1") <*> string "2"
  98 g4  = string "0" <|> string "1" <|> string "2"
  99 g5  = choice [string "0", string "1", string "2"]
 100 g6  = (<>) <$> choice [(<>) <$> string "0" <*> string "1", string "2" <|> string "3", string "4"] <*> string "5"
 101 g7  = concat <$> many (string "0")
 102 g8  = (concat <$>) $ (<>) <$> many (string "0" <|> string "1") <*> some (string "2")
 103 g9  = (<>) <$> string "0" .*> someR (char '1')
 104 g10 = (<>) <$> someL (char '1') <*. string "0"
 105 g11 = string "0" `but` g9 `but` g10
 106 g12 = (<>) <$> string "0" <& g9
 107 g13 = string "abé\"to"
 108 g14 = string "\""
 109 g15 = string ""
 110 g16 = many $ unicat [Unicat_Letter]
 111 g17 = many $ range ('a', 'z')
 112 g18 = ("" <$) $ commentable (void g1) (void g2) (void g3)
 113 g19 = ("" <$) $ choice [g5]
 114 g20 = "" <$ char 'a' <* char 'b' <* char 'c'
 115 g21 = "" <$ comment_line "--"
 116 g22 = "" <$ lexeme (string "A")
 117 g23 = "" <$ keywords
 118
 119 main :: IO ()
 120 main = do
 121         putStrLn "EBNF"
 122         {-
 123         forM_
 124          [ g1, g2, g3, g4, g5, g6, g7, g8
 125          , g11, g12, g13, g14, g15, g16, g17, g18
 126          , g19, g20, g21, g22, cf_of_reg g23
 127          ] $ \g -> do
 128                 Text.putStrLn $ runEBNF RuleMode_Def $ unCF g
 129         -}
 130         forM_
 131          [ "" <$ comment_line (rule_arg "prefix")
 132          , "" <$ comment_block (rule_arg "start") (rule_arg "end" :: Reg 'L RuleDef String)
 133          , "" <$ commentable (void $ rule_arg "space") (void $ rule_arg "line") (void $ rule_arg "block")
 134          , "" <$ lexeme (rule_arg "p")
 135          , "" <$ parens (rule_arg "p")
 136          , "" <$ inside id (rule_arg "begin") (rule_arg "i") (rule_arg "end") (rule_arg "next")
 137          , "" <$ infixrP const (rule_arg "next") (rule_arg "sep") (rule_arg "root")
 138          {-
 139          , "" <$ typeP
 140          , "" <$ type_list
 141          , "" <$ type_tuple2
 142          , "" <$ type_fun
 143          , "" <$ type_app
 144          , "" <$ type_atom
 145          , "" <$ type_name
 146          -}
 147          ] $ \g -> do
 148                 Text.putStrLn $ runEBNF $ unRuleDef $ unCF g
 149         putStrLn ""
 150         {-
 151         putStrLn "Tests"
 152         forM_
 153          [ "Bool"
 154          , "(Bool)"
 155          , "((Bool))"
 156          , "Bool, Int"
 157          , "(Bool, Int)"
 158          , "((Bool, Int), Char)"
 159          , "(Bool, Int) -> Char"
 160          , "(Bool -> Int)"
 161          , "((Bool, Int), Char)"
 162          , "String"
 163          , "[Char]"
 164          , "[Char] -> String"
 165          , "String -> [Char]"
 166          , "Maybe Bool"
 167          , "Either Bool Int"
 168          , "Bool -> Int"
 169          , "(Bool -> Int) -> Char"
 170          , "(Bool -> Int) Char"
 171          , "Bool -> (Int -> Char)"
 172          , "Bool -> Int -> Char"
 173          ] $ \s -> do
 174                 putStr (show (s::Text))
 175                 Text.putStr " ==> "
 176                 print $ (compile_type <$>) $ runIdentity $ runParser (unCF (typeP <* eof)) s
 177         -}
 178
 179 -}