{-  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.ToGraph (
  ruleToGraph,
  graphToGraphviz,
  fullGrammarToGraph,
  reachableGrammarToGraph,
  showGraph
  ) where

import Text.GrammarCombinators.Base

import Text.GrammarCombinators.Utils.IsReachable

import Data.Graph.Inductive.Graph

import Control.Monad.State
import Control.Monad.Writer

import Data.Graph.Inductive.PatriciaTree
import Data.GraphViz

newNode :: (MonadState (Int, Int) m) => m Int
newNode = do (d, n) <- get
             put (d, n + 1)
             return n
tell1 :: (MonadWriter [w] m) => w -> m ()
tell1 w = tell [w]

newtype GraphConstructor (phi :: * -> *) (r :: * -> *) t v =
  MkGC {
    constructContexts ::
       Adj String -> Bool -> 
       WriterT [Context String String] (State (Int, Int)) (Adj String)
  }

leafNode :: String -> Bool -> GraphConstructor phi r t v
leafNode label eps = MkGC $ \parentEdge printeps ->
     if not eps || printeps
       then do ln <- newNode
               tell1 (parentEdge, ln, label, [])
               return [("",ln)]
       else return parentEdge

constructContextsSub :: GraphConstructor phi r t v -> Adj String ->
                        Bool ->
                        WriterT [Context String String] (State (Int, Int)) (Adj String)
constructContextsSub r pe printeps = 
  do (d, n) <- get
     if d > 0
       then put (d-1,n) >>
            constructContexts r pe printeps
       else do n' <- newNode
               tell1 (pe, n', "(...)", [])
               return []

instance ProductionRule (GraphConstructor phi r t) where
  ra >>> rb = MkGC $ \parentEdge printeps ->
    do (d,_) <- get
       pe <- constructContextsSub ra parentEdge False
       if null pe
         then return []
         else do modify $ \(_,n) -> (d,n) -- do not ignore right branches if left ones are infinite...
                 constructContextsSub rb pe printeps 
  ra ||| rb = MkGC $ \parentEdge _ ->
    do (d,_) <- get 
       pea <- constructContextsSub ra parentEdge True
       modify $ \(_,n) -> (d,n)
       peb <- constructContextsSub rb parentEdge True
       return $ pea ++ peb
  endOfInput = leafNode "endOfInput" False
  die = leafNode "die" False

instance EpsProductionRule (GraphConstructor phi r t) where
  epsilon _ = leafNode "epsilon" True

instance LiftableProductionRule (GraphConstructor phi r t) where
  epsilonL _ _ = leafNode "epsilon" True

instance (Token t) => 
         TokenProductionRule (GraphConstructor phi r t) t where
  token tt = leafNode (show tt) False
  anyToken = leafNode "anyToken" False
  
instance (Domain phi) => RecProductionRule (GraphConstructor phi r t) phi r where
  ref idx = leafNode ("<" ++ showIdx idx ++ ">") False

instance (Domain phi) => LoopProductionRule (GraphConstructor phi r t) phi r where
  manyRef idx = leafNode ("<" ++ showIdx idx ++ ">*") False

ruleToGraph :: forall phi t r rr gr ix. (Token t, Domain phi, DynGraph gr) => 
           Int -> GExtendedContextFreeGrammar phi t r rr ->
           phi ix -> gr String String
ruleToGraph depth gram idx = buildGr $ snd $ ruleToContexts depth gram idx 0

ruleToContexts :: forall phi t r rr ix. (Token t, Domain phi) => 
           Int -> GExtendedContextFreeGrammar phi t r rr ->
           phi ix -> Int -> (Int, [Context String String])
ruleToContexts depth gram idx sn =
  let 
    processNTDef :: phi ix ->
                    WriterT [Context String String] (State (Int, Int)) (Adj String)
    processNTDef idx' =
      do ntNode <- newNode
         tell1 ([], ntNode, showIdx idx', [])
         let stAdj = [("", ntNode)]
         constructContexts (gram idx') stAdj True
    (contexts, (_,nsn)) = flip runState (depth, sn) $ execWriterT $ processNTDef idx
  in (nsn, reverse contexts)

graphvizParams :: GraphvizParams String String () String
graphvizParams = Params {
  isDirected = True, 
  globalAttributes = [], 
  clusterBy = N, 
  clusterID = const Nothing,
  fmtCluster = const [],
  fmtNode = \(_,n) -> [Label $ StrLabel n],
  fmtEdge = \(_,_,_) -> [] 
  }

graphToGraphviz :: Gr String String -> DotGraph Node
graphToGraphviz gr = setID (Str "Grammar") $ graphToDot graphvizParams (gr :: Gr String String)

grammarToContexts :: forall phi t r rr . (Token t, Domain phi) =>
                     (forall b. (forall ix. phi ix -> b -> b) -> b -> b) ->
                     Int -> GExtendedContextFreeGrammar phi t r rr ->
                     [Context String String]
grammarToContexts fold' depth gram =
  let
      processRule idx (nsn, cs) = (nsn', cs ++ cs')
        where (nsn', cs') = ruleToContexts depth gram idx nsn 
  in snd $ fold' processRule (0,[])

grammarToGraph :: forall phi t r rr gr . (Token t, Domain phi, DynGraph gr) => 
                  (forall b. (forall ix. phi ix -> b -> b) -> b -> b) ->
                  Int -> GExtendedContextFreeGrammar phi t r rr ->
                  gr String String
grammarToGraph fold' depth gram = buildGr $ grammarToContexts fold' depth gram

fullGrammarToGraph :: forall phi t r rr gr . (Token t, Domain phi, DynGraph gr) => 
                      Int -> GExtendedContextFreeGrammar phi t r rr ->
                      gr String String
fullGrammarToGraph = grammarToGraph foldFam
reachableGrammarToGraph :: forall phi t r rr gr ix . (Token t, Domain phi, DynGraph gr) => 
                  Int -> GExtendedContextFreeGrammar phi t r rr -> phi ix ->
                  gr String String
reachableGrammarToGraph depth gram idx = grammarToGraph (foldReachable gram idx) depth gram

void :: (Monad m) => m a -> m ()
void m = m >> return ()

showGraph :: (DotRepr dg n) => dg n -> IO ()
showGraph gr = void $ runGraphvizCanvas' gr Xlib