Massage .cabal files.

[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..cde5c6a51cc1469dfaec8c1bdad6817c77e3864c 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
@@ -16,7 +17,7 @@ import Language.Symantic.Grammar.Regular
 -- * Type 'CF'
 -- | Context-free grammar.
 newtype CF g a = CF { unCF :: g a }
- deriving (IsString, Functor, Gram_Terminal, Applicative, Gram_App)
+ deriving (IsString, Functor, Gram_Char, Gram_String, Applicative, Gram_App)
 deriving instance Gram_Error err g => Gram_Error err (CF g)
 deriving instance Gram_Reader st g => Gram_Reader st (CF g)
 deriving instance Gram_State st g => Gram_State st (CF g)
@@ -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,15 +103,16 @@ 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
 
 -- * Class 'Gram_Comment'
 -- | Symantics for handling comments after each 'lexeme'.
 class
- ( Gram_Terminal g
+ ( Gram_Char g
+ , Gram_String g
  , Gram_Rule g
  , Gram_Alt g
  , Gram_App g
@@ -111,22 +120,22 @@ class
  , Gram_CF g
  ) => Gram_Comment g where
        commentable :: g () -> g () -> g () -> g ()
-       commentable = rule3 "commentable" $ \space line block ->
-               skipMany $ 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
+       commentable = rule3 "Commentable" $ \sp line block ->
+               manySkip $ choice [sp, line, block]
+       commentLine :: CF g String -> CF g String
+       commentLine prefix = rule "CommentLine" $
+               prefix *> many (any `minus` (void eol <+> eoi))
+       commentBlock :: CF g String -> Reg lr g String -> CF g String
+       commentBlock begin end = rule "CommentBlock" $
+               begin *> many (any `minus` end) <* cfOf end
        lexeme :: CF g a -> CF g a
-       lexeme = rule1 "lexeme" $ \g ->
+       lexeme = rule1 "Lexeme" $ \g ->
                g <* commentable
-                (void $ string " " <+> string "\n ")
-                (void $ comment_line (string "--"))
-                (void $ comment_block (string "{-") (string "-}"))
+                (void $ space <+> (eol *> space))
+                (void $ commentLine (string "--"))
+                (void $ commentBlock (string "{-") (string "-}"))
        parens :: CF g a -> CF g a
-       parens = rule1 "parens" $
+       parens = rule1 "Parens" $
                between
                 (lexeme $ char '(')
                 (lexeme $ char ')')
@@ -139,8 +148,8 @@ instance Gram_Comment EBNF
 gram_comment :: forall g. (Gram_Comment g, Gram_RuleEBNF g) => [CF g ()]
 gram_comment =
  [ void $ commentable (void $ argEBNF "space") (void $ argEBNF "line") (void $ argEBNF "block")
- , void $ comment_line (argEBNF "prefix")
- , void $ comment_block (argEBNF "begin") (argEBNF "end" :: RegL g String)
+ , void $ commentLine (argEBNF "prefix")
+ , void $ commentBlock (argEBNF "begin") (argEBNF "end" :: RegL g String)
  , void $ lexeme (argEBNF "g")
  , void $ parens (argEBNF "g")
  , void $ inside id (argEBNF "begin") (argEBNF "in") (argEBNF "end") (argEBNF "next")