IsReachable.hs

{-  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 }
setSeen :: (EqFam phi) => phi ix -> SeenGram phi -> SeenGram phi
setSeen idx s = MkSG $ overrideIdxK (seenIdx s) idx True
nothingSeen :: SeenGram phi
nothingSeen = MkSG $ \_ -> False

type Folder phi n = forall ix. phi ix -> n -> n

newtype FoldReachableIntRule phi (r :: * -> *) t (rr :: * -> *) n v = MkFRIR {
  foldRule :: Folder phi n -> n -> State (SeenGram phi) n
  }
putSeen :: (EqFam phi) => phi ix -> State (SeenGram phi) ()
putSeen idx = modify $ setSeen idx

foldDeadEnd :: FoldReachableIntRule phi r t rr n v 
foldDeadEnd = MkFRIR $ \_ n -> return 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 $ \f n -> do n' <- foldRule ra f n
                                    foldRule rb f 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 $ \f n -> do sg <- get
                                    if seenIdx sg idx
                                      then return n
                                      else do putSeen idx
                                              let n' = f idx n
                                              foldRule r f n'

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 

-- | 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 f n =
  evalState (foldRule (unfoldDepthFirstProper grammar idx) f n) 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 f n =
  evalState (foldRule (unfoldDepthFirst grammar idx) f n) 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