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

module Text.GrammarCombinators.Utils.IsReachable (
  foldReachable,
  foldReachableProper,
  isReachable,
  isReachableProper
  ) where

import Text.GrammarCombinators.Base
import Text.GrammarCombinators.Utils.UnfoldDepthFirst

import Control.Monad.State

newtype SeenGram phi = MkSG { seenIdx :: forall ix. phi ix -> Bool }
newtype Folder phi n = MkFF { foldIdxs :: (forall ix. phi ix -> n -> n) -> n -> n }
newtype FoldReachableIntRule phi (r :: * -> *) t (rr :: * -> *) n v = MkFRIR {
  foldRule :: State (SeenGram phi) (Folder phi n)
  }
combineFolders :: Folder phi n -> Folder phi n -> Folder phi n
combineFolders a b = MkFF $ \f n -> foldIdxs a f $ foldIdxs b f n
foldDeadEnd :: FoldReachableIntRule phi r t rr n v 
foldDeadEnd = MkFRIR $ return $ MkFF $ \_ n -> n
foldVia :: FoldReachableIntRule phi r t rr n v -> FoldReachableIntRule phi r t rr n v' -> FoldReachableIntRule phi r t rr n v''  
foldVia ra rb = MkFRIR $ do fa <- foldRule ra
                            fb <- foldRule rb
                            return $ combineFolders fa fb
setSeen :: (EqFam phi) => phi ix -> SeenGram phi -> SeenGram phi
setSeen idx s = MkSG $ overrideIdxK (seenIdx s) idx True
putSeen :: (EqFam phi) => phi ix -> State (SeenGram phi) ()
putSeen idx = modify $ setSeen idx
noFold :: Folder phi n
noFold = MkFF $ const id
foldIdx :: phi ix -> Folder phi n
foldIdx idx = MkFF $ \f n -> f idx n
foldRef :: (EqFam phi) =>
           phi ix -> FoldReachableIntRule phi r t rr n (rr ix) -> 
           FoldReachableIntRule phi r t rr n v
foldRef idx r = MkFRIR $ do s <- get
                            if seenIdx s idx
                              then return noFold
                              else do putSeen idx
                                      frec <- foldRule r 
                                      return $ combineFolders frec $ foldIdx idx

instance ProductionRule (FoldReachableIntRule phi r t rr n) where
  ra >>> rb = foldVia ra rb
  ra ||| rb = foldVia ra rb
  die = foldDeadEnd
  endOfInput = foldDeadEnd

instance PenaltyProductionRule (FoldReachableIntRule phi r t rr n) where
  penalty _ r = MkFRIR $ foldRule r

instance BiasedProductionRule (FoldReachableIntRule phi r t rr n) where
  (>|||) = (|||)
  (<|||) = (|||)

instance EpsProductionRule (FoldReachableIntRule phi r t rr n) where
  epsilon _ = foldDeadEnd

instance LiftableProductionRule (FoldReachableIntRule phi r t rr n) where
  epsilonL _ _ = foldDeadEnd

instance TokenProductionRule (FoldReachableIntRule phi r t rr n) t where
  token _ = foldDeadEnd
  anyToken = foldDeadEnd

instance (EqFam phi) =>
         SimpleRecProductionRule (FoldReachableIntRule phi r t rr n) phi r rr where
  ref' = foldRef 

instance (EqFam phi) =>
         SimpleLoopProductionRule (FoldReachableIntRule phi r t rr n) phi r rr where
  manyRef' = foldRef 
  many1Ref' = foldRef 

nothingSeen :: SeenGram phi
nothingSeen = MkSG $ \_ -> False

-- | Fold a given function over all non-terminals that are reachable 
-- from a given non-terminal. This function is limited to proper
-- reachable rules (see 'isReachableProper' for what that means).
foldReachableProper :: forall phi r t rr ix n. (Domain phi) => 
                       GAnyExtendedContextFreeGrammar phi t r rr ->
                       phi ix ->
                       (forall ix'. phi ix' -> n -> n) -> n -> n
foldReachableProper grammar idx =
  foldIdxs $ evalState (foldRule (unfoldDepthFirstProper grammar idx)) nothingSeen

-- | Fold a given function over all non-terminals that are reachable 
-- from a given non-terminal. This function will at least fold over the
-- given non-terminal itself.
foldReachable :: forall phi r rr t ix n. (Domain phi) => 
                 GAnyExtendedContextFreeGrammar phi t r rr ->
                 phi ix ->
                 (forall ix'. phi ix' -> n -> n) -> n -> n
foldReachable grammar idx =
  foldIdxs $ evalState (foldRule (unfoldDepthFirst grammar idx)) nothingSeen

isReachable' :: forall phi r t rr ix ix'. (Domain phi) => 
               (forall n. 
                GAnyExtendedContextFreeGrammar phi t r rr -> phi ix ->
                (forall ix''. phi ix'' -> n -> n) -> n -> n) ->
               GAnyExtendedContextFreeGrammar phi t r rr ->
               phi ix -> phi ix' -> Bool
isReachable' fold' g start end =
  fold' g start ((||) . eqIdx end) False

-- | Check if a given non-terminal is reachable from a given other non-terminal
-- in a given extended context-free grammar. This function assumes
-- that all grammars are reachable from themselves.
isReachable :: forall phi r t rr ix ix'. (Domain phi) => 
               GAnyExtendedContextFreeGrammar phi t r rr ->
               phi ix -> phi ix' -> Bool
isReachable = isReachable' foldReachable

-- | Check if a given non-terminal is reachable from a given other non-terminal
-- in a given extended context-free grammar. For this function, a non- 
-- terminal is not automatically considered reachable from itself, but
-- only if it has some production in which a submatch of itself is
-- present.
isReachableProper :: forall phi r t rr ix ix'. (Domain phi) => 
                     GAnyExtendedContextFreeGrammar phi t r rr ->
                     phi ix -> phi ix' -> Bool
isReachableProper = isReachable' foldReachableProper