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 deriving instance Try RuleDef
  66 instance Gram_Rule RuleDef where
  67         rule  n           = rule_def (ebnf_const n)
  68         rule1 n g a       = rule_def (ebnf_const n `ebnf_arg` unRuleDef a) (g a)
  69         rule2 n g a b     = rule_def (ebnf_const n `ebnf_arg` unRuleDef a `ebnf_arg` unRuleDef b) (g a b)
  70         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)
  71         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)
  72
  73 -- *** Class 'Gram_RuleDef'
  74 class Gram_RuleDef g where
  75         rule_def :: EBNF () -> g a -> RuleDef a
  76         rule_arg :: Text -> g a
  77 instance Show (EBNF a) where
  78         show = Text.unpack . runEBNF
  79 instance Functor EBNF where
  80         fmap _f (EBNF x) = EBNF x
  81 instance Applicative EBNF where
  82         pure _ = ebnf_const $ "\"\""
  83         EBNF f <*> EBNF x = EBNF $ \bo po -> infix_paren po op $
  84                 f bo (op, L) <> ", " <> x bo (op, R)
  85                 where op = infixB L 10
  86 instance Gram_Rule EBNF where
  87         rule n g = EBNF $ \rm po ->
  88                 case rm of
  89                  RuleMode_Body -> unEBNF g RuleMode_Ref po
  90                  RuleMode_Ref -> n
  91         rule1 n g a = EBNF $ \rm po ->
  92                 case rm of
  93                  RuleMode_Body -> unEBNF (g a) RuleMode_Ref po
  94                  RuleMode_Ref  -> unEBNF (ebnf_const n `ebnf_arg` a) RuleMode_Ref po
  95         rule2 n g a b = EBNF $ \rm po ->
  96                 case rm of
  97                  RuleMode_Body -> unEBNF (g a b) RuleMode_Ref po
  98                  RuleMode_Ref  -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b) RuleMode_Ref po
  99         rule3 n g a b c = EBNF $ \rm po ->
 100                 case rm of
 101                  RuleMode_Body -> unEBNF (g a b c) RuleMode_Ref po
 102                  RuleMode_Ref  -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b `ebnf_arg` c) RuleMode_Ref po
 103         rule4 n g a b c d = EBNF $ \rm po ->
 104                 case rm of
 105                  RuleMode_Body -> unEBNF (g a b c d) RuleMode_Ref po
 106                  RuleMode_Ref  -> unEBNF (ebnf_const n `ebnf_arg` a `ebnf_arg` b `ebnf_arg` c `ebnf_arg` d) RuleMode_Ref po
 107 instance Gram_RuleDef EBNF where
 108         rule_arg = ebnf_const
 109         rule_def call body =
 110                 RuleDef $ EBNF $ \mo po ->
 111                         case mo of
 112                          RuleMode_Ref -> unEBNF call mo po
 113                          RuleMode_Body ->
 114                                 Text.intercalate " " $
 115                                  [ unEBNF call RuleMode_Ref (infixN0, L)
 116                                  , "="
 117                                  , unEBNF body RuleMode_Ref (infixN0, R)
 118                                  , ";"
 119                                  ]
 120
 121 -- | Helper for 'Gram_Rule' 'EBNF'.
 122 ebnf_arg :: EBNF a -> EBNF b -> EBNF ()
 123 ebnf_arg (EBNF a) (EBNF b) = EBNF $ \bo po -> infix_paren po op $
 124         a bo (op, L) <> " " <> b bo (op, R)
 125         where op = infixL 11
 126 infixl 5 `ebnf_arg`
 127
 128 -- ** Type 'Precedence'
 129 type Precedence = Int
 130
 131 -- ** Type 'Associativity'
 132 -- type Associativity = LR
 133 data Associativity
 134  =   AssocL -- ^ Associate to the left:  @a ¹ b ² c == (a ¹ b) ² c@
 135  |   AssocR -- ^ Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@
 136  |   AssocB LR -- ^ Associate to both side, but to 'LR' when reading.
 137  deriving (Eq, Show)
 138
 139 -- ** Type 'Infix'
 140 data Infix
 141  =   Infix
 142  {   infix_assoc :: Maybe Associativity
 143  ,   infix_prece :: Precedence
 144  } deriving (Eq, Show)
 145
 146 infixL :: Precedence -> Infix
 147 infixL = Infix (Just AssocL)
 148
 149 infixR :: Precedence -> Infix
 150 infixR = Infix (Just AssocR)
 151
 152 infixB :: LR -> Precedence -> Infix
 153 infixB = Infix . Just . AssocB
 154
 155 infixN :: Precedence -> Infix
 156 infixN = Infix Nothing
 157
 158 infixN0 :: Infix
 159 infixN0 = infixN 0
 160
 161 infixN5 :: Infix
 162 infixN5 = infixN 5
 163
 164 infix_paren
 165  :: (Semigroup s, IsString s)
 166  => (Infix, LR) -> Infix -> s -> s
 167 infix_paren (po, lr) op s =
 168         if infix_prece op <  infix_prece po
 169         || infix_prece op == infix_prece po
 170         && Bool.not associate
 171          then fromString "(" <> s <> fromString ")"
 172          else s
 173         where
 174         associate =
 175                 case (lr, infix_assoc po) of
 176                  (_, Just AssocB{}) -> True
 177                  (L, Just AssocL) -> True
 178                  (R, Just AssocR) -> True
 179                  _ -> False
 180
 181 -- ** Type 'LR'
 182 data LR
 183  = L -- ^ Left
 184  | R -- ^ Right
 185  deriving (Eq, Show)
 186
 187 -- * Type 'Try'
 188 class Try g where
 189         try :: g a -> g a
 190 instance Try EBNF where
 191         try = id