Add indent.
[haskell/symantic.git] / symantic-grammar / Language / Symantic / Grammar / EBNF.hs
index 22f552be1771d1f6a3bbfc9e01472b2490180f7c..9c414fae930d26dd6f55789cbe99ca318ccef355 100644 (file)
@@ -1,20 +1,12 @@
-{-# 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.Semigroup
 import Data.Text (Text)
 import qualified Data.Text as Text
-import Prelude hiding (any)
+
+import Language.Symantic.Grammar.Meta
+import Language.Symantic.Grammar.Fixity
 
 -- * Type 'EBNF'
 -- | Extended Backus-Naur-Form, following the
@@ -26,68 +18,103 @@ import Prelude hiding (any)
 -- * @(rule, "&", rule)@: for the intersection.
 -- * @(rule, "-", rule)@: for the difference.
 -- * @(rule, " ", rule)@: for rule application.
-data EBNF a = EBNF { unEBNF :: RuleMode -> (Infix, LR) -> Text }
-
+--
+-- Inherited attributes are:
+--
+-- * 'RuleMode' is the requested rendering mode of a 'Rule' (body or reference).
+-- * 'Infix' and 'Side' are the properties of the parent operator,
+--   used to enclose the operand in parenthesis only when needed.
+--
+-- Synthetized attributes are:
+--
+-- * 'Text' of the 'EBNF' rendition.
+newtype EBNF a = EBNF { unEBNF :: RuleMode -> (Infix, Side) -> Text }
+instance Gram_Reader st EBNF where
+       askBefore (EBNF e) = EBNF e
+       askAfter  (EBNF e) = EBNF e
+instance Gram_State st EBNF where
+       stateBefore (EBNF e) = EBNF e
+       stateAfter  (EBNF e) = EBNF e
+instance Gram_Error err EBNF where
+       catch (EBNF e) = EBNF e
+
+-- | Get textual rendition of given 'EBNF'.
 runEBNF :: EBNF a -> Text
-runEBNF (EBNF g) = g RuleMode_Body (infixN0, L)
+runEBNF (EBNF g) = g RuleMode_Body (infixN0, SideL)
 
--- | Get textual rendition of given EBNF rule.
-renderEBNF :: RuleDef a -> Text
-renderEBNF = runEBNF . unRuleDef
+-- | Get textual rendition of given 'RuleEBNF'.
+renderEBNF :: RuleEBNF a -> Text
+renderEBNF = runEBNF . unRuleEBNF
 
+-- | 'EBNF' returns a constant rendition.
 ebnf_const :: Text -> EBNF a
 ebnf_const t = EBNF $ \_rm _op -> t
 
--- * Class 'Gram_Rule'
-type Id a = a -> a
+-- | 'EBNF' which adds an argument to be applied.
+ebnf_arg :: EBNF a -> EBNF b -> EBNF ()
+ebnf_arg (EBNF a) (EBNF b) = EBNF $ \bo po -> parenInfix po op $
+       a bo (op, SideL) <> " " <> b bo (op, SideR)
+       where op = infixL 11
+infixl 5 `ebnf_arg`
+
+-- ** Type 'RuleMode'
+data RuleMode
+ =   RuleMode_Body -- ^ Request to generate the body of the rule.
+ |   RuleMode_Ref  -- ^ Request to generate a reference to the rule.
+ deriving (Eq, Show)
+
+-- * Type 'Rule'
+type Rule a = a -> a
+
+-- ** Class 'Gram_Rule'
 class Gram_Rule g where
-       rule :: Text -> Id (g a)
+       rule :: Text -> Rule (g a)
        rule _n = id
-       rule1 :: Text -> Id (g a -> g b)
+       rule1 :: Text -> Rule (g a -> g b)
        rule1 _n g = g
-       rule2 :: Text -> Id (g a -> g b -> g c)
+       rule2 :: Text -> Rule (g a -> g b -> g c)
        rule2 _n g = g
-       rule3 :: Text -> Id (g a -> g b -> g c -> g d)
+       rule3 :: Text -> Rule (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 :: Text -> Rule (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 }
+-- * Type 'RuleEBNF'
+newtype RuleEBNF a = RuleEBNF { unRuleEBNF :: EBNF a }
  deriving (Functor, Applicative)
-deriving instance Gram_RuleDef RuleDef
-deriving instance Try 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
+deriving instance Gram_RuleEBNF RuleEBNF
+deriving instance Gram_Error err RuleEBNF
+deriving instance Gram_Reader st RuleEBNF
+deriving instance Gram_State st RuleEBNF
+instance Gram_Rule RuleEBNF where
+       rule  n           = ruleEBNF (ebnf_const n)
+       rule1 n g a       = ruleEBNF (ebnf_const n `ebnf_arg` unRuleEBNF a) (g a)
+       rule2 n g a b     = ruleEBNF (ebnf_const n `ebnf_arg` unRuleEBNF a `ebnf_arg` unRuleEBNF b) (g a b)
+       rule3 n g a b c   = ruleEBNF (ebnf_const n `ebnf_arg` unRuleEBNF a `ebnf_arg` unRuleEBNF b `ebnf_arg` unRuleEBNF c) (g a b c)
+       rule4 n g a b c d = ruleEBNF (ebnf_const n `ebnf_arg` unRuleEBNF a `ebnf_arg` unRuleEBNF b `ebnf_arg` unRuleEBNF c `ebnf_arg` unRuleEBNF d) (g a b c d)
+
+-- ** Class 'Gram_RuleEBNF'
+-- | Symantics for rendering 'EBNF' rules.
+-- 
+-- * 'ruleEBNF' renders a rule, either its body or a reference to it, according to 'RuleMode'.
+-- * 'argEBNF' renders an argument.
+class Gram_RuleEBNF g where
+       ruleEBNF :: EBNF () -> g a -> RuleEBNF a
+       argEBNF  :: 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
+       EBNF f <*> EBNF x = EBNF $ \bo po -> parenInfix po op $
+               f bo (op, SideL) <> ", " <> x bo (op, SideR)
+               where op = infixB SideL 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
+                RuleMode_Ref  -> n
        rule1 n g a = EBNF $ \rm po ->
                case rm of
                 RuleMode_Body -> unEBNF (g a) RuleMode_Ref po
@@ -104,88 +131,16 @@ instance Gram_Rule EBNF where
                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 ->
+instance Gram_RuleEBNF EBNF where
+       argEBNF = ebnf_const
+       ruleEBNF call body =
+               RuleEBNF $ EBNF $ \mo po ->
                        case mo of
                         RuleMode_Ref -> unEBNF call mo po
                         RuleMode_Body ->
-                               Text.intercalate " " $
-                                [ unEBNF call RuleMode_Ref (infixN0, L)
+                               Text.intercalate " "
+                                [ unEBNF call RuleMode_Ref (infixN0, SideL)
                                 , "="
-                                , unEBNF body RuleMode_Ref (infixN0, R)
+                                , unEBNF body RuleMode_Ref (infixN0, SideR)
                                 , ";"
                                 ]
-
--- | 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)
-
--- * Type 'Try'
-class Try g where
-       try :: g a -> g a
-instance Try EBNF where
-       try = id