symantic-grammar/Language/Symantic/Grammar/EBNF.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   4 {-# LANGUAGE NoMonomorphismRestriction #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE StandaloneDeriving #-}
   7 {-# OPTIONS_GHC -fno-warn-tabs #-}
   8 module Language.Symantic.Grammar.EBNF where
   9
  10 import Control.Applicative (Applicative(..))
  11 import Control.Monad
  12 import Data.Bool as Bool
  13 import Data.Semigroup hiding (option)
  14 import Data.String (IsString(..))
  15 import Data.Text (Text)
  16 import qualified Data.Text as Text
  17 import Prelude hiding (any)
  18
  19 -- * Type 'EBNF'
  20 -- | Extended Backus-Naur-Form, following the
  21 -- <http://standards.iso.org/ittf/PubliclyAvailableStandards/s026153_ISO_IEC_14977_1996(E).zip ISO-IEC-14977>
  22 -- notations, augmented with the following notations:
  23 --
  24 -- * @("U+", code_point)@: for <http://unicode.org/versions/Unicode8.0.0/ ISO-IEC-10646> (aka. Unicode).
  25 -- * @(char, "…", char)@: for character range.
  26 -- * @(rule, "&", rule)@: for the intersection.
  27 -- * @(rule, "-", rule)@: for the difference.
  28 -- * @(rule, " ", rule)@: for rule application.
  29 data EBNF a = EBNF { unEBNF :: RuleMode -> (Infix, LR) -> Text }
  30
  31 runEBNF :: EBNF a -> Text
  32 runEBNF (EBNF g) = g RuleMode_Body (infixN0, L)
  33
  34 -- | Get textual rendition of given EBNF rule.
  35 renderEBNF :: RuleDef a -> Text
  36 renderEBNF = runEBNF . unRuleDef
  37
  38 ebnf_const :: Text -> EBNF a
  39 ebnf_const t = EBNF $ \_rm _op -> t
  40
  41 -- * Class 'Gram_Rule'
  42 type Id a = a -> a
  43 class Gram_Rule g where
  44         rule :: Text -> Id (g a)
  45         rule _n = id
  46         rule1 :: Text -> Id (g a -> g b)
  47         rule1 _n g = g
  48         rule2 :: Text -> Id (g a -> g b -> g c)
  49         rule2 _n g = g
  50         rule3 :: Text -> Id (g a -> g b -> g c -> g d)
  51         rule3 _n g = g
  52         rule4 :: Text -> Id (g a -> g b -> g c -> g d -> g e)
  53         rule4 _n g = g
  54
  55 -- ** Type 'RuleMode'
  56 data RuleMode
  57  =   RuleMode_Body -- ^ Generate the body of the rule.
  58  |   RuleMode_Ref  -- ^ Generate a ref to the rule.
  59  deriving (Eq, Show)
  60
  61 -- ** Type 'RuleDef'
  62 newtype RuleDef a = RuleDef { unRuleDef :: EBNF a }
  63  deriving (Functor, Applicative)
  64 deriving instance Gram_RuleDef RuleDef
  65 instance Gram_Rule RuleDef where
  66         rule  n           = rule_def (ebnf_const n)
  67         rule1 n g a       = rule_def (ebnf_const n `ebnf_arg` unRuleDef a) (g a)
  68         rule2 n g a b     = rule_def (ebnf_const n `ebnf_arg` unRuleDef a `ebnf_arg` unRuleDef b) (g a b)
  69         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)
  70         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)
  71
  72 -- *** Class 'Gram_RuleDef'
  73 class Gram_RuleDef g where
  74         rule_def :: EBNF () -> g a -> RuleDef a
  75         rule_arg :: Text -> g a
  76 instance Show (EBNF a) where
  77         show = Text.unpack . runEBNF
  78 instance Functor EBNF where
  79         fmap _f (EBNF x) = EBNF x
  80 instance Applicative EBNF where
  81         pure _ = ebnf_const $ "\"\""
  82         EBNF f <*> EBNF x = EBNF $ \bo po -> infix_paren po op $
  83                 f bo (op, L) <> ", " <> x bo (op, R)
  84                 where op = infixB L 10
  85 instance Gram_Rule EBNF where
  86         rule n g = EBNF $ \rm po ->
  87                 case rm of
  88                  RuleMode_Body -> unEBNF g RuleMode_Ref po
  89                  RuleMode_Ref -> n
  90         rule1 n g a = EBNF $ \rm po ->
  91                 case rm of
  92                  RuleMode_Body -> unEBNF (g a) RuleMode_Ref po
  93                  RuleMode_Ref  -> unEBNF (ebnf_const n `ebnf_arg` a) RuleMode_Ref po
  94         rule2 n g a b = EBNF $ \rm po ->
  95                 case rm of
  96                  RuleMode_Body -> unEBNF (g a b) RuleMode_Ref po
  97                  RuleMode_Ref  -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b) RuleMode_Ref po
  98         rule3 n g a b c = EBNF $ \rm po ->
  99                 case rm of
 100                  RuleMode_Body -> unEBNF (g a b c) RuleMode_Ref po
 101                  RuleMode_Ref  -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b `ebnf_arg` c) RuleMode_Ref po
 102         rule4 n g a b c d = EBNF $ \rm po ->
 103                 case rm of
 104                  RuleMode_Body -> unEBNF (g a b c d) RuleMode_Ref po
 105                  RuleMode_Ref  -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b `ebnf_arg` c `ebnf_arg` d) RuleMode_Ref po
 106 instance Gram_RuleDef EBNF where
 107         rule_arg = ebnf_const
 108         rule_def call body =
 109                 RuleDef $ EBNF $ \mo po ->
 110                         case mo of
 111                          RuleMode_Ref -> unEBNF call mo po
 112                          RuleMode_Body ->
 113                                 Text.intercalate " " $
 114                                  [ unEBNF call RuleMode_Ref (infixN0, L)
 115                                  , "="
 116                                  , unEBNF body RuleMode_Ref (infixN0, R)
 117                                  , ";"
 118                                  ]
 119
 120 -- | Helper for 'Gram_Rule' 'EBNF'.
 121 ebnf_arg :: EBNF a -> EBNF b -> EBNF ()
 122 ebnf_arg (EBNF a) (EBNF b) = EBNF $ \bo po -> infix_paren po op $
 123         a bo (op, L) <> " " <> b bo (op, R)
 124         where op = infixL 11
 125 infixl 5 `ebnf_arg`
 126
 127 -- ** Type 'Precedence'
 128 type Precedence = Int
 129
 130 -- ** Type 'Associativity'
 131 -- type Associativity = LR
 132 data Associativity
 133  =   AssocL -- ^ Associate to the left:  @a ¹ b ² c == (a ¹ b) ² c@
 134  |   AssocR -- ^ Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@
 135  |   AssocB LR -- ^ Associate to both side, but to 'LR' when reading.
 136  deriving (Eq, Show)
 137
 138 -- ** Type 'Infix'
 139 data Infix
 140  =   Infix
 141  {   infix_assoc :: Maybe Associativity
 142  ,   infix_prece :: Precedence
 143  } deriving (Eq, Show)
 144
 145 infixL :: Precedence -> Infix
 146 infixL = Infix (Just AssocL)
 147
 148 infixR :: Precedence -> Infix
 149 infixR = Infix (Just AssocR)
 150
 151 infixB :: LR -> Precedence -> Infix
 152 infixB = Infix . Just . AssocB
 153
 154 infixN :: Precedence -> Infix
 155 infixN = Infix Nothing
 156
 157 infixN0 :: Infix
 158 infixN0 = infixN 0
 159
 160 infixN5 :: Infix
 161 infixN5 = infixN 5
 162
 163 infix_paren
 164  :: (Semigroup s, IsString s)
 165  => (Infix, LR) -> Infix -> s -> s
 166 infix_paren (po, lr) op s =
 167         if infix_prece op <  infix_prece po
 168         || infix_prece op == infix_prece po
 169         && Bool.not associate
 170          then fromString "(" <> s <> fromString ")"
 171          else s
 172         where
 173         associate =
 174                 case (lr, infix_assoc po) of
 175                  (_, Just AssocB{}) -> True
 176                  (L, Just AssocL) -> True
 177                  (R, Just AssocR) -> True
 178                  _ -> False
 179
 180 -- ** Type 'LR'
 181 data LR
 182  = L -- ^ Left
 183  | R -- ^ Right
 184  deriving (Eq, Show)