Remove Alternative uses in grammars.

diff --git a/Language/Symantic/Compiling/Term/Grammar.hs b/Language/Symantic/Compiling/Term/Grammar.hs
index 4ed4378f6306da5f6b954cfc74f5ba75c11dd42e..15b62f3847344606fa1014369006f4001bb5ecb6 100644 (file)
--- a/Language/Symantic/Compiling/Term/Grammar.hs
+++ b/Language/Symantic/Compiling/Term/Grammar.hs
@@ -7,7 +7,6 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Language.Symantic.Compiling.Term.Grammar where
 
-import Control.Applicative (Alternative(..))
 import Control.Arrow (left)
 import Control.Monad (foldM, void, (=<<))
 import qualified Data.Char as Char
@@ -224,8 +223,7 @@ data Mod a = Mod Mod_Path a
 
 -- * Class 'Gram_Term_Name'
 class
- ( Alternative g
- , Alt g
+ ( Alt g
  , Alter g
  , Alter g
  , App g
@@ -319,8 +317,7 @@ instance Gram_Term_Name RuleDef
 
 -- * Class 'Gram_Term_Type'
 class
- ( Alternative g
- , Alt g
+ ( Alt g
  , Alter g
  , App g
  , Gram_CF g
@@ -364,8 +361,7 @@ data Error_Term_Gram
 
 -- * Class 'Gram_Term'
 class
- ( Alternative g
- , Alt g
+ ( Alt g
  , Alter g
  , App g
  , Gram_CF g
@@ -538,6 +534,7 @@ instance
 class Gram_Term_AtomsT meta ts t g where
        term_atomsT :: Proxy t -> [CF g (ProTok meta ts)]
        term_atomsT _t = []
+instance Gram_Term_AtomsT meta ts t RuleDef
 
 gram_term
  :: forall g.

diff --git a/Language/Symantic/Lib/Alternative.hs b/Language/Symantic/Lib/Alternative.hs
index 54517ec1c8e68c9ad9d59e69a059cf696ab6fafc..a2d80f606a3f75d2f888bdcd48d05be4e70bd18d 100644 (file)
--- a/Language/Symantic/Lib/Alternative.hs
+++ b/Language/Symantic/Lib/Alternative.hs
@@ -12,7 +12,7 @@ import Data.Type.Equality ((:~:)(Refl))
 import Prelude hiding (Functor(..), (<$>), id, const)
 
 import Language.Symantic.Parsing
-import Language.Symantic.Parsing.Grammar
+import Language.Symantic.Parsing.Grammar hiding (Alter(..))
 import Language.Symantic.Typing
 import Language.Symantic.Compiling
 import Language.Symantic.Lib.Lambda

diff --git a/Language/Symantic/Lib/Integer.hs b/Language/Symantic/Lib/Integer.hs
index 5093e0f246e645ed96e1039b40ec9eb38e13a6ae..c5f5bc9abeb1d1c2acd0e0e9a6e31f9d6c378e21 100644 (file)
--- a/Language/Symantic/Lib/Integer.hs
+++ b/Language/Symantic/Lib/Integer.hs
@@ -4,7 +4,6 @@
 -- | Symantic for 'Integer'.
 module Language.Symantic.Lib.Integer where
 
-import Control.Applicative (Alternative(..))
 import Data.Proxy
 import qualified Data.Text as Text
 import Data.Type.Equality ((:~:)(Refl))
@@ -85,7 +84,6 @@ instance -- TokenizeT
 instance -- Gram_Term_AtomsT
  ( Alt g
  , Alter g
- , Alternative g
  , Gram_Rule g
  , Gram_Lexer g
  , Gram_Meta meta g

diff --git a/Language/Symantic/Parsing/EBNF.hs b/Language/Symantic/Parsing/EBNF.hs
index ed490387e5b3fc61033e9ab288e9cabafc027478..eb3c6abbc28db4970ee19e919a9279ec4fcc3fb3 100644 (file)
--- a/Language/Symantic/Parsing/EBNF.hs
+++ b/Language/Symantic/Parsing/EBNF.hs
@@ -7,7 +7,7 @@
 {-# OPTIONS_GHC -fno-warn-tabs #-}
 module Language.Symantic.Parsing.EBNF where
 
-import Control.Applicative (Applicative(..), Alternative(..))
+import Control.Applicative (Applicative(..))
 import Control.Monad
 import Data.Bool as Bool
 import Data.Char as Char
@@ -50,8 +50,12 @@ data RuleMode
 
 -- ** Type 'RuleDef'
 newtype RuleDef a = RuleDef { unRuleDef :: EBNF a }
- deriving (Functor, Gram_Terminal, Applicative, App
- , Alternative, Alter, Alt, Gram_RegL, Gram_RegR, Gram_CF)
+ deriving (Functor, Gram_Terminal, Applicative, App)
+deriving instance Alter RuleDef
+deriving instance Alt RuleDef
+deriving instance Gram_RegL RuleDef
+deriving instance Gram_RegR RuleDef
+deriving instance Gram_CF RuleDef
 deriving instance Gram_RuleDef RuleDef
 deriving instance Gram_RuleDef g => Gram_RuleDef (RegR g)
 deriving instance Gram_RuleDef g => Gram_RuleDef (RegL g)
@@ -124,23 +128,20 @@ instance Applicative EBNF where
                f bo (op, L) <> ", " <> x bo (op, R)
                where op = infixB L 10
 instance App EBNF
-instance Alternative EBNF where
+instance Alter EBNF where
        empty = ebnf_const $ "\"\""
-       EBNF g <|> EBNF q = EBNF $ \bo po -> infix_paren po op $
+       EBNF g <+> EBNF q = EBNF $ \bo po -> infix_paren po op $
                g bo (op, L) <> " | " <> q bo (op, R)
                where op = infixB L 2
-       many (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}"  where op = infixN0
-       some (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}-" where op = infixN0
-instance Alter EBNF where
-       nil = ebnf_const $ "\"\""
        choice [] = empty
        choice [g] = g
        choice l@(_:_) = EBNF $ \bo po -> infix_paren po op $
                Text.intercalate " | " $
                (unEBNF <$> l) <*> pure bo <*> pure (op, L)
                where op = infixB L 2
-       star (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}"  where op = infixN0
 instance Alt EBNF where
+       many (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}"  where op = infixN0
+       some (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, L) <> "}-" where op = infixN0
        option _x (EBNF g) = EBNF $ \rm _po ->
                "[" <> g rm (op, L) <> "]"  where op = infixN0
 instance Gram_Terminal EBNF where

diff --git a/Language/Symantic/Parsing/Grammar.hs b/Language/Symantic/Parsing/Grammar.hs
index f17dc148b9d529c0d1632d5fbb37ffebdba0b209..b3a518f55a6eae5f4c08bf05f9b3fea18baf0d3b 100644 (file)
--- a/Language/Symantic/Parsing/Grammar.hs
+++ b/Language/Symantic/Parsing/Grammar.hs
@@ -10,7 +10,7 @@
 -- with: @cabal test ebnf --show-details=always@.
 module Language.Symantic.Parsing.Grammar where
 
-import Control.Applicative (Applicative(..), Alternative(..))
+import Control.Applicative (Applicative(..))
 import Control.Monad
 import qualified Data.Bool as Bool
 import qualified Data.Char as Char
@@ -104,7 +104,8 @@ unicode_categories c =
 -- * Type 'Reg'
 -- | Left or right regular grammar.
 newtype Reg (lr::LR) g a = Reg { unReg :: g a }
- deriving (IsString, Functor, Gram_Terminal, Alter)
+ deriving (IsString, Functor, Gram_Terminal)
+deriving instance Alter g => Alter (Reg lr g)
 deriving instance Gram_Rule g => Gram_Rule (Reg lr g)
 deriving instance (Functor g, Alter g, Gram_RegL g) => Gram_RegL (RegL g)
 deriving instance (Functor g, Alter g, Gram_RegR g) => Gram_RegR (RegR g)
@@ -123,34 +124,23 @@ type RegR = Reg 'R
 -- ** Class 'Alter'
 -- | Like 'Alternative' but without the 'Applicative' super-class,
 -- because a regular grammar is not closed under 'Applicative'.
+-- And also because the alternative operator has to backtrack
+-- when the first alternative fails.
 class Alter g where
-       nil    :: g a
+       empty  :: g a
        (<+>)  :: g a -> g a -> g a
        choice :: [g a] -> g a
-       star   :: g a -> g [a]
-       default nil    :: Alternative g => g a
-       default (<+>)  :: Alternative g => g a -> g a -> g a
-       default choice :: Alternative g => [g a] -> g a
-       default star   :: Alternative g => g a -> g [a]
-       nil    = empty
-       (<+>)  = (<|>)
        choice = foldr (<+>) empty
-       -- star g = (:) <$> g *> star g <+> nil
-       
-       star a = many_a
-               where
-               many_a = some_a <+> pure []
-               some_a = ((:) <$> a) <*> many_a
+deriving instance Alter p => Alter (Terminal p)
 
 infixl 3 <+>
-deriving instance Alter p => Alter (Terminal p)
 
 -- ** Class 'Gram_RegR'
 -- | Symantics for right regular grammars.
 class (Functor g, Alter g) => Gram_RegR g where
        (.*>) :: Terminal g (a -> b) -> RegR g a -> RegR g b
        manyR :: Terminal g a -> RegR g [a]
-       manyR g = (:) <$> g .*> manyR g <+> nil
+       manyR g = (:) <$> g .*> manyR g <+> empty
        someR :: Terminal g a -> RegR g [a]
        someR g = (:) <$> g .*> manyR g
 infixl 4 .*>
@@ -161,15 +151,19 @@ class (Functor g, Alter g) => Gram_RegL g where
        (<*.) :: RegL g (a -> b) -> Terminal g a -> RegL g b
        manyL :: Terminal g a -> RegL g [a]
        manyL g' = reverse <$> go g'
-               where go g = flip (:) <$> go g <*. g <+> nil
+               where go g = flip (:) <$> go g <*. g <+> empty
        someL :: Terminal g a -> RegL g [a]
        someL g = (\cs c -> cs ++ [c]) <$> manyL g <*. g
 infixl 4 <*.
 
 -- * Class 'Alt'
-class (Alternative g, Alter g) => Alt g where
+class (Alter g, Applicative g) => Alt g where
        option :: a -> g a -> g a
        option x g = g <+> pure x
+       many :: g a -> g [a]
+       many a = some a <+> pure []
+       some :: g a -> g [a]
+       some a = (:) <$> a <*> many a
        skipMany :: g a -> g ()
        skipMany = void . many
        --manyTill :: g a -> g end -> g [a]
@@ -183,7 +177,9 @@ class Applicative g => App g where
 -- * Type 'CF'
 -- | Context-free grammar.
 newtype CF g a = CF { unCF :: g a }
- deriving (IsString, Functor, Gram_Terminal, Applicative, App, Alternative, Alter, Alt)
+ deriving (IsString, Functor, Gram_Terminal, Applicative, App)
+deriving instance Alter g => Alter (CF g)
+deriving instance Alt g => Alt (CF g)
 deriving instance Gram_Rule g => Gram_Rule (CF g)
 deriving instance Gram_RegL g => Gram_RegL (CF g)
 deriving instance Gram_RegR g => Gram_RegR (CF g)
@@ -218,7 +214,6 @@ instance Gram_Meta meta g => Gram_Meta meta (CF g) where
 class
  ( Alt g
  , Alter g
- , Alternative g
  , App g
  , Gram_CF g
  , Gram_Rule g
@@ -269,9 +264,9 @@ class
                                in \case
                                 Just (in_, b) -> insert_infix nod_a in_ b
                                 Nothing -> Right nod_a)
-                        <$> star preG
+                        <$> many preG
                         <*> aG
-                        <*> star postG
+                        <*> many postG
                         <*> option Nothing (curry Just <$> inG <*> go aG preG inG postG)
                
                insert_unifix :: (Unifix, a -> a) -> OpTree a -> OpTree a

diff --git a/Language/Symantic/Parsing/Grammar/Test.hs b/Language/Symantic/Parsing/Grammar/Test.hs
index e992e8d177040431fa14deb6f24344aba6ea0001..f9859be91b1045de21cb480d0d70b59fb136e87b 100644 (file)
--- a/Language/Symantic/Parsing/Grammar/Test.hs
+++ b/Language/Symantic/Parsing/Grammar/Test.hs
@@ -8,7 +8,8 @@ module Parsing.Grammar.Test where
 import Test.Tasty
 import Test.Tasty.HUnit
 
-import Control.Applicative (Applicative(..), Alternative(..))
+import Control.Applicative (Applicative(..))
+import qualified Control.Applicative as Alt
 import Control.Monad
 import Data.Monoid ((<>))
 -- import Control.Comonad
@@ -40,7 +41,8 @@ instance ParsecC e s => Gram_Terminal (P.ParsecT e s m) where
        range (l, h) = P.satisfy $ \c -> l <= c && c <= h
        but (Terminal f) (Terminal p) = Terminal $ P.notFollowedBy (P.try p) *> f
 instance ParsecC e s => Alter (P.ParsecT e s m) where
-       x <+> y = P.try x <|> y
+       empty = Alt.empty
+       x <+> y = P.try x Alt.<|> y
 instance ParsecC e s => Gram_RegR (P.ParsecT e s m) where
        Terminal f .*> Reg x = Reg $ f <*> x
 instance ParsecC e s => Gram_RegL (P.ParsecT e s m) where
@@ -100,14 +102,13 @@ tests = testGroup "Grammar"
                ; infix 1 ==> in
         [ (<>) <$> string "0" <*> string "1" ==> "\"0\", \"1\""
         , (<>) <$> string "0" <* string "X" <*> string "1" ==> "\"0\", \"X\", \"1\""
-        , (<>) <$> (string "0" <|> string "1") <*> string "2" ==> "(\"0\" | \"1\"), \"2\""
         , (<>) <$> (string "0" <+> string "1") <*> string "2" ==> "(\"0\" | \"1\"), \"2\""
         , (<>) <$> string "0" <*> (string "1" <+> string "2") ==> "\"0\", (\"1\" | \"2\")"
-        , string "0" <|> string "1" <|> string "2" ==> "\"0\" | \"1\" | \"2\""
+        , string "0" <+> string "1" <+> string "2" ==> "\"0\" | \"1\" | \"2\""
         , choice [string "0", string "1", string "2"] ==> "\"0\" | \"1\" | \"2\""
         , (<>) <$> choice
                 [ (<>) <$> string "0" <*> string "1"
-                , string "2" <|> string "3"
+                , string "2" <+> string "3"
                 , string "4"
                 ] <*> string "5" ==> "(\"0\", \"1\" | \"2\" | \"3\" | \"4\"), \"5\""
         , concat <$> many (string "0") ==> "{\"0\"}"
@@ -119,7 +120,7 @@ tests = testGroup "Grammar"
                string "0" `minus` g0 `minus` g1 ==>
                "\"0\" - \"0\", {\"1\"}- - {\"1\"}-, \"0\""
         , (<>)
-                <$> many (string "0" <|> string "1")
+                <$> many (string "0" <+> string "1")
                 <*> some (string "2") ==> "{\"0\" | \"1\"}, {\"2\"}-"
         ]
  ]

diff --git a/Language/Symantic/Typing/Type.hs b/Language/Symantic/Typing/Type.hs
index 918ea74a1e36fd1a80453ada43f25b8187a6c358..fcd0f938535954d067eb9594ea646643b42b3576 100644 (file)
--- a/Language/Symantic/Typing/Type.hs
+++ b/Language/Symantic/Typing/Type.hs
@@ -7,7 +7,7 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Language.Symantic.Typing.Type where
 
-import Control.Applicative (Applicative(..), Alternative(..))
+import Control.Applicative (Applicative(..))
 import qualified Data.Char as Char
 import Data.Monoid ((<>))
 import Data.Proxy
@@ -322,7 +322,6 @@ type TokType meta = EToken meta '[Proxy Token_Type]
 class
  ( Alt p
  , Alter p
- , Alternative p
  , App p
  , Gram_CF p
  , Gram_Rule p