{-  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 FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Text.GrammarCombinators.Utils.UnfoldDepthFirst where

import Text.GrammarCombinators.Base

-- TODO: use UnfoldLoops and UnfoldRecursion instead of redoing everything?

class (ProductionRule p) =>
      SimpleRecProductionRule p phi r rr | p -> phi, p -> r, p -> rr where
  ref' :: phi ix -> p (rr ix) -> p (r ix)
  cutRecursion :: phi ix -> p (rr ix)
  cutRecursion _ = die

class SimpleLoopProductionRule p phi r rr | p -> phi, p -> r, p -> rr where
  manyRef' :: phi ix -> p (rr ix) -> p [r ix]
  many1Ref' :: phi ix -> p (rr ix) -> p [r ix]

newtype UnfoldDepthFirstRule p (phi :: * -> *) (r :: * -> *) t (rr :: * -> *) v = MkFRR {
  foldReachableFromRule :: UDFGrammar p phi r t rr -> p v
  }

type UDFGrammar p phi r t rr =
  forall ix. phi ix -> p (rr ix)

instance (ProductionRule p) => ProductionRule (UnfoldDepthFirstRule p phi r t rr) where
  ra >>> rb = MkFRR $ \g -> foldReachableFromRule ra g >>> foldReachableFromRule rb g
  ra ||| rb = MkFRR $ \g -> foldReachableFromRule ra g |||  foldReachableFromRule rb g
  die = MkFRR $ \_ -> die
  endOfInput = MkFRR $ \_ -> endOfInput

instance (BiasedProductionRule p) => BiasedProductionRule (UnfoldDepthFirstRule p phi r t rr) where
  ra >||| rb = MkFRR $ \g -> foldReachableFromRule ra g >|||  foldReachableFromRule rb g
  ra <||| rb = MkFRR $ \g -> foldReachableFromRule ra g <|||  foldReachableFromRule rb g

instance (EpsProductionRule p) => EpsProductionRule (UnfoldDepthFirstRule p phi r t rr) where
  epsilon v = MkFRR $ \_ -> epsilon v

instance (LiftableProductionRule p) => LiftableProductionRule (UnfoldDepthFirstRule p phi r t rr) where
  epsilonL v q = MkFRR $ \_ -> epsilonL v q

instance (TokenProductionRule p t) =>
         TokenProductionRule (UnfoldDepthFirstRule p phi r t rr) t where
  token tt = MkFRR $ \_ -> token tt
  anyToken = MkFRR $ \_ -> anyToken
  
instance (SimpleRecProductionRule p phi r rr) =>
         RecProductionRule (UnfoldDepthFirstRule p phi r t rr) phi r where
  ref idx = MkFRR $ \g -> ref' idx (g idx) 

instance (PenaltyProductionRule p) =>
         PenaltyProductionRule (UnfoldDepthFirstRule p phi r t rr) where
  penalty _ r = r

instance (ProductionRule p,
          LiftableProductionRule p,
          SimpleRecProductionRule p phi r rr,
          SimpleLoopProductionRule p phi r rr) =>
         LoopProductionRule (UnfoldDepthFirstRule p phi r t rr) phi r where
  manyRef idx = MkFRR $ \g -> manyRef' idx (g idx) 
  many1Ref idx = MkFRR $ \g -> many1Ref' idx (g idx)

newtype WrapUR p r ix = WUR { unWUR :: p (r ix) }

declareDead :: (EqFam phi, ProductionRule p,
                SimpleRecProductionRule p phi r rr) =>
               phi ix ->
               UDFGrammar p phi r t rr ->
               UDFGrammar p phi r t rr 
declareDead idx g = unWUR . overrideIdx (WUR . g) idx (WUR $ cutRecursion idx)


unfoldDepthFirst'' :: forall p phi r rr t v.
                   (ProductionRule p, EqFam phi,
                    TokenProductionRule p t,
                    EpsProductionRule p,
                    BiasedProductionRule p,
                    PenaltyProductionRule p,
                    SimpleRecProductionRule p phi r rr,
                    SimpleLoopProductionRule p phi r rr) =>
                   UnfoldDepthFirstRule p phi r t rr v ->
                   GAnyExtendedContextFreeGrammar phi t r rr ->
                   (UDFGrammar p phi r t rr -> UDFGrammar p phi r t rr) ->
                   p v
unfoldDepthFirst'' r grammar rg =
  foldReachableFromRule r (rg (unfoldDepthFirst' grammar rg)) 

unfoldDepthFirst' :: forall p phi r rr t ix.
                   (ProductionRule p, EqFam phi,
                    EpsProductionRule p,
                    PenaltyProductionRule p,
                    BiasedProductionRule p,
                    TokenProductionRule p t,
                    SimpleRecProductionRule p phi r rr,
                    SimpleLoopProductionRule p phi r rr) =>
                   GAnyExtendedContextFreeGrammar phi t r rr ->
                   (UDFGrammar p phi r t rr -> UDFGrammar p phi r t rr) ->
                   phi ix -> p (rr ix)
unfoldDepthFirst' grammar rg idx =
  let
    nrg :: UDFGrammar p phi r t rr -> UDFGrammar p phi r t rr
    nrg g = declareDead idx (rg g)
  in unfoldDepthFirst'' (grammar idx) grammar nrg 

unfoldDepthFirstProper :: forall p phi r rr t ix.
                   (ProductionRule p, EqFam phi,
                    EpsProductionRule p,
                    PenaltyProductionRule p,
                    BiasedProductionRule p,
                    TokenProductionRule p t,
                    SimpleRecProductionRule p phi r rr,
                    SimpleLoopProductionRule p phi r rr) =>
                   GAnyExtendedContextFreeGrammar phi t r rr ->
                   phi ix -> p (rr ix)
unfoldDepthFirstProper grammar = unfoldDepthFirst' grammar (\g -> g) 

unfoldDepthFirst :: forall p phi r rr t ix.
                   (ProductionRule p, EqFam phi,
                    EpsProductionRule p,
                    PenaltyProductionRule p,
                    BiasedProductionRule p,
                    TokenProductionRule p t,
                    SimpleRecProductionRule p phi r rr,
                    SimpleLoopProductionRule p phi r rr) =>
                   GAnyExtendedContextFreeGrammar phi t r rr ->
                   phi ix -> p (r ix)
unfoldDepthFirst grammar idx = unfoldDepthFirst'' (ref idx) grammar (\g -> g)