{-  Copyright 2010 Dominique Devriese

    This file is part of the grammar-combinators library.

    The grammar-combinators library is free software: you can
    redistribute it and/or modify it under the terms of the GNU
    Lesser General Public License as published by the Free
    Software Foundation, either version 3 of the License, or (at
    your option) any later version.

    Foobar is distributed in the hope that it will be useful, but
    WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
    GNU Lesser General Public License for more details.

    You should have received a copy of the GNU Lesser General
    Public License along with Foobar. If not, see
    <http://www.gnu.org/licenses/>.
-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Text.GrammarCombinators.Transform.CombineGrammars (
  combineGrammars
  ) where

import Text.GrammarCombinators.Base

newtype CGW p (phiL :: * -> *) (phiR :: * -> *) (rL :: * -> *) (rR :: * -> *) t v = MkCGW { unCGW :: p v }

instance (EpsProductionRule p, ProductionRule p,
          RecProductionRule p (MergeDomain phiL phiR) (EitherFunctor rL rR)) => 
         RecProductionRule (CGW p phiL phiR rL rR t) phiL rL where
           ref idx = MkCGW $ unLeftR $>> ref (LeftIdx idx)

instance (EpsProductionRule p, ProductionRule p,
          LoopProductionRule p (MergeDomain phiL phiR) (EitherFunctor rL rR)) => 
         LoopProductionRule (CGW p phiL phiR rL rR t) phiL rL where
           manyRef idx = MkCGW $ map unLeftR $>> manyRef (LeftIdx idx)

instance (EpsProductionRule p, ProductionRule p,
          RecProductionRule p (MergeDomain phiL phiR) (EitherFunctor rL rR)) => 
         ProductionRuleWithLibrary (CGW p phiL phiR rL rR t) phiR rR where
           lib idx = MkCGW $ unRightR $>> ref (RightIdx idx)

instance (ProductionRule p) => 
         ProductionRule (CGW p phiL phiR rL rR t) where
           (MkCGW pl) >>> (MkCGW pr) = MkCGW (pl >>> pr)
           (MkCGW pl) ||| (MkCGW pr) = MkCGW (pl ||| pr)
           endOfInput = MkCGW endOfInput
           die = MkCGW die

instance (LiftableProductionRule p) => 
         LiftableProductionRule (CGW p phiL phiR rL rR t) where
           epsilonL q v = MkCGW (epsilonL q v)

instance (EpsProductionRule p) => 
         EpsProductionRule (CGW p phiL phiR rL rR t) where
           epsilon v = MkCGW (epsilon v)

instance (TokenProductionRule p t) => 
         TokenProductionRule (CGW p phiL phiR rL rR t) t where
           token tt = MkCGW (token tt)
           anyToken = MkCGW anyToken

newtype IGW p (phiL :: * -> *) (phiR :: * -> *) (rL :: * -> *) (rR :: * -> *) t v =
  IGW { unIGW :: p v }

instance (EpsProductionRule p) => EpsProductionRule (IGW p phiL phiR rL rR t) where
  epsilon v = IGW $ epsilon v

instance (LiftableProductionRule p) => LiftableProductionRule (IGW p phiL phiR rL rR t) where
  epsilonL q v = IGW $ epsilonL q v

instance (TokenProductionRule p t) => TokenProductionRule (IGW p phiL phiR rL rR t) t where
  token tt = IGW $ token tt
  anyToken = IGW anyToken

instance (ProductionRule p) => ProductionRule (IGW p phiL phiR rL rR t) where
  (IGW pl) >>> (IGW pr) = IGW (pl >>> pr)
  (IGW pl) ||| (IGW pr) = IGW (pl ||| pr)
  endOfInput = IGW endOfInput
  die = IGW die

instance (EpsProductionRule p, ProductionRule p, RecProductionRule p (MergeDomain phiL phiR) (EitherFunctor rL rR)) => 
         RecProductionRule (IGW p phiL phiR rL rR t) (MergeDomain phiR phiL) (EitherFunctor rR rL) where
  ref (LeftIdx idx) = IGW $ (LeftR $>> (unRightR $>> ref (RightIdx idx)))
  ref (RightIdx idx) = IGW $ (RightR $>> (unLeftR $>> ref (LeftIdx idx)))

instance (EpsProductionRule p, ProductionRule p, LoopProductionRule p (MergeDomain phiL phiR) (EitherFunctor rL rR)) => 
         LoopProductionRule (IGW p phiL phiR rL rR t) (MergeDomain phiR phiL) (EitherFunctor rR rL) where
  manyRef (LeftIdx idx) = IGW $ (map LeftR $>> (map unRightR $>> manyRef (RightIdx idx)))
  manyRef (RightIdx idx) = IGW $ (map RightR $>> (map unLeftR $>> manyRef (LeftIdx idx)))
  many1Ref (LeftIdx idx) = IGW $ (map LeftR $>> (map unRightR $>> many1Ref (RightIdx idx)))
  many1Ref (RightIdx idx) = IGW $ (map RightR $>> (map unLeftR $>> many1Ref (LeftIdx idx)))

invertGrammar :: 
  (EpsProductionRule p, ProductionRule p) =>
  (forall ix'. MergeDomain phiL phiR ix' -> p (EitherFunctor rL rR ix')) ->
  MergeDomain phiR phiL ix -> p (EitherFunctor rR rL ix)
invertGrammar g (LeftIdx idx) = (LeftR . unRightR) $>> g (RightIdx idx)                 
invertGrammar g (RightIdx idx) = (RightR . unLeftR) $>> g (LeftIdx idx)                 

-- | Combine two grammars into a single one. The argument grammars are over
--   different domains 'phiL' and 'phiR', but they are allowed to refer to 
--   each other's non-terminals
--   using the 'lib' primitive from the 'ProductionRuleWithLibrary' type class.
--   The resulting grammar is over the combined domain 'MergeDomain phiL phiR'.
combineGrammars :: forall p phiL phiR rL rR rrL rrR t ix.
  (EpsProductionRule p, ProductionRule p, TokenProductionRule p t,
   RecProductionRule p (MergeDomain phiL phiR) (EitherFunctor rL rR),
   LoopProductionRule p (MergeDomain phiL phiR) (EitherFunctor rL rR)) =>
  (forall p' ix'. (ProductionRule p', EpsProductionRule p', TokenProductionRule p' t,
                  RecProductionRule p' phiL rL,
                  LoopProductionRule p' phiL rL,
                  ProductionRuleWithLibrary p' phiR rR) => phiL ix' -> p' (rrL ix')) -> 
  (forall p' ix'. (ProductionRule p', EpsProductionRule p', TokenProductionRule p' t,
                  RecProductionRule p' phiR rR,
                  LoopProductionRule p' phiR rR,
                  ProductionRuleWithLibrary p' phiL rL) => phiR ix' -> p' (rrR ix')) ->
  MergeDomain phiL phiR ix -> p (EitherFunctor rrL rrR ix)
combineGrammars gL _ (LeftIdx idx) = LeftR $>> unCGW (gL idx)
combineGrammars gL gR (RightIdx idx) = unIGW (invertGrammar (combineGrammars gR gL) (RightIdx idx))