{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Language.Symantic.Grammar.EBNF where import Control.Applicative (Applicative(..)) import Control.Monad import Data.Bool as Bool import Data.Semigroup hiding (option) import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as Text import Prelude hiding (any) -- * Type 'EBNF' -- | Extended Backus-Naur-Form, following the -- -- notations, augmented with the following notations: -- -- * @("U+", code_point)@: for (aka. Unicode). -- * @(char, "…", char)@: for character range. -- * @(rule, "&", rule)@: for the intersection. -- * @(rule, "-", rule)@: for the difference. -- * @(rule, " ", rule)@: for rule application. data EBNF a = EBNF { unEBNF :: RuleMode -> (Infix, LR) -> Text } runEBNF :: EBNF a -> Text runEBNF (EBNF g) = g RuleMode_Body (infixN0, L) -- | Get textual rendition of given EBNF rule. renderEBNF :: RuleDef a -> Text renderEBNF = runEBNF . unRuleDef ebnf_const :: Text -> EBNF a ebnf_const t = EBNF $ \_rm _op -> t -- * Class 'Gram_Rule' type Id a = a -> a class Gram_Rule g where rule :: Text -> Id (g a) rule _n = id rule1 :: Text -> Id (g a -> g b) rule1 _n g = g rule2 :: Text -> Id (g a -> g b -> g c) rule2 _n g = g rule3 :: Text -> Id (g a -> g b -> g c -> g d) rule3 _n g = g rule4 :: Text -> Id (g a -> g b -> g c -> g d -> g e) rule4 _n g = g -- ** Type 'RuleMode' data RuleMode = RuleMode_Body -- ^ Generate the body of the rule. | RuleMode_Ref -- ^ Generate a ref to the rule. deriving (Eq, Show) -- ** Type 'RuleDef' newtype RuleDef a = RuleDef { unRuleDef :: EBNF a } deriving (Functor, Applicative) deriving instance Gram_RuleDef RuleDef instance Gram_Rule RuleDef where rule n = rule_def (ebnf_const n) rule1 n g a = rule_def (ebnf_const n `ebnf_arg` unRuleDef a) (g a) rule2 n g a b = rule_def (ebnf_const n `ebnf_arg` unRuleDef a `ebnf_arg` unRuleDef b) (g a b) rule3 n g a b c = rule_def (ebnf_const n `ebnf_arg` unRuleDef a `ebnf_arg` unRuleDef b `ebnf_arg` unRuleDef c) (g a b c) rule4 n g a b c d = rule_def (ebnf_const n `ebnf_arg` unRuleDef a `ebnf_arg` unRuleDef b `ebnf_arg` unRuleDef c `ebnf_arg` unRuleDef d) (g a b c d) -- *** Class 'Gram_RuleDef' class Gram_RuleDef g where rule_def :: EBNF () -> g a -> RuleDef a rule_arg :: Text -> g a instance Show (EBNF a) where show = Text.unpack . runEBNF instance Functor EBNF where fmap _f (EBNF x) = EBNF x instance Applicative EBNF where pure _ = ebnf_const $ "\"\"" EBNF f <*> EBNF x = EBNF $ \bo po -> infix_paren po op $ f bo (op, L) <> ", " <> x bo (op, R) where op = infixB L 10 instance Gram_Rule EBNF where rule n g = EBNF $ \rm po -> case rm of RuleMode_Body -> unEBNF g RuleMode_Ref po RuleMode_Ref -> n rule1 n g a = EBNF $ \rm po -> case rm of RuleMode_Body -> unEBNF (g a) RuleMode_Ref po RuleMode_Ref -> unEBNF (ebnf_const n `ebnf_arg` a) RuleMode_Ref po rule2 n g a b = EBNF $ \rm po -> case rm of RuleMode_Body -> unEBNF (g a b) RuleMode_Ref po RuleMode_Ref -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b) RuleMode_Ref po rule3 n g a b c = EBNF $ \rm po -> case rm of RuleMode_Body -> unEBNF (g a b c) RuleMode_Ref po RuleMode_Ref -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b `ebnf_arg` c) RuleMode_Ref po rule4 n g a b c d = EBNF $ \rm po -> case rm of RuleMode_Body -> unEBNF (g a b c d) RuleMode_Ref po RuleMode_Ref -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b `ebnf_arg` c `ebnf_arg` d) RuleMode_Ref po instance Gram_RuleDef EBNF where rule_arg = ebnf_const rule_def call body = RuleDef $ EBNF $ \mo po -> case mo of RuleMode_Ref -> unEBNF call mo po RuleMode_Body -> Text.intercalate " " $ [ unEBNF call RuleMode_Ref (infixN0, L) , "=" , unEBNF body RuleMode_Ref (infixN0, R) , ";" ] -- | Helper for 'Gram_Rule' 'EBNF'. ebnf_arg :: EBNF a -> EBNF b -> EBNF () ebnf_arg (EBNF a) (EBNF b) = EBNF $ \bo po -> infix_paren po op $ a bo (op, L) <> " " <> b bo (op, R) where op = infixL 11 infixl 5 `ebnf_arg` -- ** Type 'Precedence' type Precedence = Int -- ** Type 'Associativity' -- type Associativity = LR data Associativity = AssocL -- ^ Associate to the left: @a ¹ b ² c == (a ¹ b) ² c@ | AssocR -- ^ Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@ | AssocB LR -- ^ Associate to both side, but to 'LR' when reading. deriving (Eq, Show) -- ** Type 'Infix' data Infix = Infix { infix_assoc :: Maybe Associativity , infix_prece :: Precedence } deriving (Eq, Show) infixL :: Precedence -> Infix infixL = Infix (Just AssocL) infixR :: Precedence -> Infix infixR = Infix (Just AssocR) infixB :: LR -> Precedence -> Infix infixB = Infix . Just . AssocB infixN :: Precedence -> Infix infixN = Infix Nothing infixN0 :: Infix infixN0 = infixN 0 infixN5 :: Infix infixN5 = infixN 5 infix_paren :: (Semigroup s, IsString s) => (Infix, LR) -> Infix -> s -> s infix_paren (po, lr) op s = if infix_prece op < infix_prece po || infix_prece op == infix_prece po && Bool.not associate then fromString "(" <> s <> fromString ")" else s where associate = case (lr, infix_assoc po) of (_, Just AssocB{}) -> True (L, Just AssocL) -> True (R, Just AssocR) -> True _ -> False -- ** Type 'LR' data LR = L -- ^ Left | R -- ^ Right deriving (Eq, Show)