Add term Function.($).

[haskell/symantic.git] / symantic-grammar / Language / Symantic / Grammar / ContextFree.hs

diff --git a/symantic-grammar/Language/Symantic/Grammar/ContextFree.hs b/symantic-grammar/Language/Symantic/Grammar/ContextFree.hs
index 5a247ff6746a1ae2c28822ba7d69ffada00cd50f..7c11d2b2d91d5bfdb8cf1995ad39307a4decbb7a 100644 (file)
--- a/symantic-grammar/Language/Symantic/Grammar/ContextFree.hs
+++ b/symantic-grammar/Language/Symantic/Grammar/ContextFree.hs
@@ -6,6 +6,7 @@ import Control.Monad
 import Data.Semigroup (Semigroup(..))
 import Data.String (IsString(..))
 import Prelude hiding (any)
+import qualified Data.List as L
 
 import Language.Symantic.Grammar.Meta
 import Language.Symantic.Grammar.Fixity
@@ -43,11 +44,12 @@ instance Gram_CF EBNF where
                f bo (op, SideL) <> " - " <> g bo (op, SideR)
                where op = infixL 6
 
-cf_of_Terminal :: Terminal g a -> CF g a
-cf_of_Terminal (Terminal g) = CF g
-
-cf_of_Reg :: Reg lr g a -> CF g a
-cf_of_Reg (Reg g) = CF g
+class ContextFreeOf gram where
+       cfOf :: gram g a -> CF g a
+instance ContextFreeOf Terminal where
+       cfOf (Terminal g) = CF g
+instance ContextFreeOf (Reg lr) where
+       cfOf (Reg g) = CF g
 
 -- ** Class 'Gram_CF'
 -- | Symantics for context-free grammars.
@@ -76,12 +78,18 @@ class (Gram_Alt g, Gram_App g) => Gram_AltApp g where
        option x g = g <+> pure x
        optional :: g a -> g (Maybe a)
        optional v = Just <$> v <+> pure Nothing
+       manyFoldL :: b -> (a -> b -> b) -> g a -> g b
+       manyFoldL e f a = someFoldL e f a <+> pure e
+       someFoldL :: b -> (a -> b -> b) -> g a -> g b
+       someFoldL e f a = f <$> a <*> manyFoldL e f a
        many :: g a -> g [a]
-       many a = some a <+> pure []
+       many = fmap L.reverse . manyFoldL [] (:)
        some :: g a -> g [a]
-       some a = (:) <$> a <*> many a
-       skipMany :: g a -> g ()
-       skipMany = void . many
+       some = fmap L.reverse . someFoldL [] (:)
+       manySkip :: g a -> g ()
+       manySkip = void . many
+       someSkip :: g a -> g ()
+       someSkip = void . some
        --manyTill :: g a -> g end -> g [a]
        --manyTill g end = go where go = ([] <$ end) <|> ((:) <$> g <*> go)
        inside
@@ -95,8 +103,8 @@ class (Gram_Alt g, Gram_App g) => Gram_AltApp g where
                (f <$ begin <*> in_ <* end) <+> next
 deriving instance Gram_AltApp RuleEBNF
 instance Gram_AltApp EBNF where
-       many (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}"  where op = infixN0
-       some (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}-" where op = infixN0
+       manyFoldL _ _ (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}"  where op = infixN0
+       someFoldL _ _ (EBNF g) = EBNF $ \rm _po -> "{" <> g rm (op, SideL) <> "}-" where op = infixN0
        option _x (EBNF g) = EBNF $ \rm _po ->
                "[" <> g rm (op, SideL) <> "]" where op = infixN0
 
@@ -112,13 +120,13 @@ class
  ) => Gram_Comment g where
        commentable :: g () -> g () -> g () -> g ()
        commentable = rule3 "commentable" $ \space line block ->
-               skipMany $ choice [space, line, block]
+               manySkip $ choice [space, line, block]
        comment_line :: CF g String -> CF g String
        comment_line prefix = rule "comment_line" $
                prefix *> many (any `minus` (void (char '\n') <+> eoi))
        comment_block :: CF g String -> Reg lr g String -> CF g String
        comment_block begin end = rule "comment_block" $
-               begin *> many (any `minus` end) <* cf_of_Reg end
+               begin *> many (any `minus` end) <* cfOf end
        lexeme :: CF g a -> CF g a
        lexeme = rule1 "lexeme" $ \g ->
                g <* commentable