-- | Symantics for context-free grammars.
module Language.Symantic.Grammar.ContextFree where

import Control.Applicative (Applicative(..))
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
import Language.Symantic.Grammar.EBNF
import Language.Symantic.Grammar.Terminal
import Language.Symantic.Grammar.Regular

-- * Type 'CF'
-- | Context-free grammar.
newtype CF g a = CF { unCF :: g a }
 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)
deriving instance Gram_Alt g => Gram_Alt (CF g)
deriving instance Gram_Try g => Gram_Try (CF g)
deriving instance Gram_AltApp g => Gram_AltApp (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)
deriving instance Gram_CF g => Gram_CF (CF g)
deriving instance Gram_CF RuleEBNF
deriving instance Gram_RuleEBNF g => Gram_RuleEBNF (CF g)
instance Gram_CF EBNF where
        CF (EBNF f) <& Reg (EBNF g) =
                CF $ EBNF $ \bo po -> pairIfNeeded pairParen po op $
                f bo (op, SideL) <> " & " <> g bo (op, SideR)
                where op = infixB SideL 4
        Reg (EBNF f) &> CF (EBNF g) =
                CF $ EBNF $ \bo po -> pairIfNeeded pairParen po op $
                f bo (op, SideL) <> " & " <> g bo (op, SideR)
                where op = infixB SideL 4
        CF (EBNF f) `minus` Reg (EBNF g) =
                CF $ EBNF $ \bo po -> pairIfNeeded pairParen po op $
                f bo (op, SideL) <> " - " <> g bo (op, SideR)
                where op = infixL 6

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.
class Gram_CF g where
        -- | NOTE: CFL ∩ RL is a CFL.
        -- See ISBN 81-7808-347-7, Theorem 7.27, p.286
        (<&) :: CF g (a -> b) -> Reg lr g a -> CF g b
        infixl 4 <&
        (&>) :: Reg lr g (a -> b) -> CF g a -> CF g b
        infixl 4  &>
        -- | NOTE: CFL - RL is a CFL.
        -- See ISBN 81-7808-347-7, Theorem 7.29, p.289
        minus :: CF g a -> Reg lr g b -> CF g a

-- ** Class 'Gram_App'
class Applicative g => Gram_App g where
        between :: g open -> g close -> g a -> g a
        between open close g = open *> g <* close
deriving instance Gram_App RuleEBNF
instance Gram_App EBNF

-- ** Class 'Gram_AltApp'
-- | Symantics when 'Gram_Alt' and 'Gram_App' are allowed by the grammar.
class (Gram_Alt g, Gram_App g) => Gram_AltApp g where
        option :: a -> g a -> g a
        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 = fmap L.reverse . manyFoldL [] (:)
        some :: g a -> g [a]
        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
         :: (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 Gram_AltApp RuleEBNF
instance Gram_AltApp EBNF where
        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_Char g
 , Gram_String g
 , Gram_Rule g
 , Gram_Alt g
 , Gram_App g
 , Gram_AltApp g
 , Gram_CF g
 ) => Gram_Comment g where
        commentable :: g () -> g () -> g () -> g ()
        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 ->
                g <* commentable
                 (void $ space <+> (eol *> space))
                 (void $ commentLine (string "--"))
                 (void $ commentBlock (string "{-") (string "-}"))
        parens :: CF g a -> CF g a
        parens = rule1 "Parens" $
                between
                 (lexeme $ char '(')
                 (lexeme $ char ')')
        symbol :: String -> CF g String
        symbol = lexeme . string
deriving instance Gram_Comment g => Gram_Comment (CF g)
instance Gram_Comment RuleEBNF
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 $ 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")
 ]