Fix Mono{Foldable,Functor} and {Semi,Is}Sequence constraints.

[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 ae739315b60dbbc7bd68859bbd3db943d4d66fb0..26363e3cf7cc2414f697893f05d88c31ac379f98 100644 (file)
--- a/symantic-grammar/Language/Symantic/Grammar/ContextFree.hs
+++ b/symantic-grammar/Language/Symantic/Grammar/ContextFree.hs
@@ -69,15 +69,21 @@ class (Alter g, Applicative g) => Alt g where
        skipMany = void . many
        --manyTill :: g a -> g end -> g [a]
        --manyTill g end = go where go = ([] <$ end) <|> ((:) <$> g <*> go)
-       inside :: (a -> b) -> CF g begin -> CF g a -> CF g end -> CF g b -> CF g b
-       inside f begin i end n =
-               (f <$ begin <*> i <* end) <+> n
+       inside
+        :: (in_ -> next)
+        -> CF g begin
+        -> CF g in_
+        -> CF g end
+        -> CF g next
+        -> CF g next
+       inside f begin in_ end next =
+               (f <$ begin <*> in_ <* end) <+> next
 deriving instance Alt RuleDef
 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
+               "[" <> g rm (op, L) <> "]" where op = infixN0
 
 -- ** Class 'App'
 class Applicative g => App g where
@@ -106,25 +112,25 @@ class
  , Gram_Terminal g
  ) => Gram_Lexer g where
        commentable :: g () -> g () -> g () -> g ()
-       commentable = rule3 "commentable" $ \g line block ->
-               skipMany $ choice [g, line, block]
+       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 start end = rule "comment_block" $
-               start *> many (any `minus` void end)
+       comment_block begin end = rule "comment_block" $
+               begin *> many (any `minus` end) <* cf_of_Reg end
        lexeme :: CF g a -> CF g a
        lexeme = rule1 "lexeme" $ \g ->
                g <* commentable
-                (void $ char ' ')
+                (void $ string " " <+> string "\n ")
                 (void $ comment_line (string "--"))
                 (void $ comment_block (string "{-") (string "-}"))
        parens :: CF g a -> CF g a
        parens = rule1 "parens" $
                between
-                (lexeme $ string "(")
-                (lexeme $ string ")")
+                (lexeme $ char '(')
+                (lexeme $ char ')')
        symbol :: String -> CF g String
        symbol = lexeme . string
 deriving instance Gram_Lexer g => Gram_Lexer (CF g)
@@ -135,8 +141,8 @@ gram_lexer :: forall g. (Gram_Lexer g, Gram_RuleDef g) => [CF g ()]
 gram_lexer =
  [ void $ commentable (void $ rule_arg "space") (void $ rule_arg "line") (void $ rule_arg "block")
  , void $ comment_line (rule_arg "prefix")
- , void $ comment_block (rule_arg "start") (rule_arg "end" :: RegL g String)
+ , void $ comment_block (rule_arg "begin") (rule_arg "end" :: RegL g String)
  , void $ lexeme (rule_arg "g")
  , void $ parens (rule_arg "g")
- , void $ inside id (rule_arg "begin") (rule_arg "i") (rule_arg "end") (rule_arg "next")
+ , void $ inside id (rule_arg "begin") (rule_arg "in") (rule_arg "end") (rule_arg "next")
  ]