----------------------------------------------------------------------
-- |
-- Module      : ParseGFC
-- Maintainer  : PL
-- Stability   : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:22:50 $ 
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.2 $
--
-- The main parsing module, parsing GFC grammars
-- by translating to simpler formats, such as PMCFG and CFG
----------------------------------------------------------------------

module GF.OldParsing.ParseGFC (newParser) where

import GF.System.Tracing 
import GF.Printing.PrintParser
import qualified GF.Grammar.PrGrammar as PrGrammar

-- Haskell modules
import Control.Monad
-- import Ratio ((%))
-- GF modules
import qualified GF.Grammar.Grammar as GF
import GF.Grammar.Values
import qualified GF.Grammar.Macros as Macros
import qualified GF.Infra.Modules as Mods
import qualified GF.Canon.AbsGFC as AbsGFC
import qualified GF.Infra.Ident as Ident
import qualified GF.Compile.ShellState as SS
import GF.Data.Operations
import GF.Data.SortedList 
-- Conversion and parser modules
import GF.Data.Assoc
import GF.OldParsing.Utilities
-- import ConvertGrammar
import GF.OldParsing.GrammarTypes
import qualified GF.OldParsing.MCFGrammar as M
import qualified GF.OldParsing.CFGrammar as C
import qualified GF.OldParsing.ParseMCFG as PM
import qualified GF.OldParsing.ParseCFG as PC
--import MCFRange

newParser :: String -> SS.StateGrammar -> GF.Cat -> String -> Err [GF.Term]

-- parsing via MCFG
newParser (m:strategy) gr (_, startCat) inString 
    | m=='m' || m=='M' = trace2 "Parser" "MCFG" $ Ok terms
    where terms    = map (ptree2term abstract) trees
	  trees    = --tracePrt "trees" (prtBefore "\n") $
		     tracePrt "#trees" (prt . length) $
		     concatMap forest2trees forests
	  forests  = --tracePrt "forests" (prtBefore "\n") $
		     tracePrt "#forests" (prt . length) $
		     concatMap (chart2forests chart isMeta) finalEdges
	  isMeta = null . snd
	  finalEdges = tracePrt "finalEdges" (prtBefore "\n") $
		       filter isFinalEdge $ aElems chart
-- 		       nubsort [ (cat, [(lbl, E.makeRange [(i,j)])]) | 
-- 				 let (i, j) = inputBounds inTokens,
-- 				 E.Rule cat _ [E.Lin lbl _] _ <- pInf,
-- 				 isStartCat cat ]
	  isFinalEdge (cat, rows) 
	      = isStartCat cat && 
		inputBounds inTokens `elem` concat [ rho | (_, M.Rng rho) <- rows ]
	  chart    = --tracePrt "chart" (prtBefore "\n" . aAssocs) $
		     tracePrt "#chart" (prt . map (length.snd) . aAssocs) $
		     PM.parse strategy pInf starters inTokens
	  inTokens = input $ map AbsGFC.KS $ words inString
	  pInf     = -- tracePrt "avg rec" (\gr -> show (sum [ length rec | E.Rule _ _ rec _ <- gr ] % length gr)) $
		     mcfPInfo $ SS.statePInfoOld gr
	  starters = tracePrt "startCats" prt $
		     filter isStartCat $ nubsort [ cat | M.Rule cat _ _ _ <- pInf ]
	  isStartCat (MCFCat cat _) = cat == startCat
	  abstract = tracePrt "abstract module" PrGrammar.prt $
		     SS.absId gr

-- parsing via CFG
newParser (c:strategy) gr (_, startCat) inString 
    | c=='c' || c=='C' = trace2 "Parser" "CFG" $ Ok terms
    where terms    = -- tracePrt "terms" (unlines . map PrGrammar.prt) $
		     map (ptree2term abstract) trees
	  trees    = tracePrt "#trees" (prt . length) $
		     --tracePrt "trees" (prtSep "\n") $
		     concatMap forest2trees forests
	  forests  = tracePrt "$cfForests" (prt) $ -- . length) $
		     tracePrt "forests" (unlines . map prt) $
		     concatMap convertFromCFForest cfForests
	  cfForests= tracePrt "cfForests" (unlines . map prt) $
		     concatMap (chart2forests chart (const False)) finalEdges
	  finalEdges = tracePrt "finalChartEdges" prt $
		       map (uncurry Edge (inputBounds inTokens)) starters
	  chart    = --tracePrt "finalChartEdges" (prt . (? finalEdge)) $
		     tracePrt "#chart" (prt . map (length.snd) . aAssocs) $
		     C.edges2chart inTokens edges
	  edges    = --tracePrt "finalEdges" 
		     --(prt . filter (\(Edge i j _) -> (i,j)==inputBounds inTokens)) $
		     tracePrt "#edges" (prt . length) $
		     PC.parse strategy pInf starters inTokens
	  inTokens = input $ map AbsGFC.KS $ words inString
	  pInf     = cfPInfo $ SS.statePInfoOld gr
	  starters = tracePrt "startCats" prt $
		     filter isStartCat $ map fst $ aAssocs $ C.topdownRules pInf
	  isStartCat (CFCat (MCFCat cat _) _) = cat == startCat
	  abstract = tracePrt "abstract module" PrGrammar.prt $
		     SS.absId gr
		     --ifNull (Ident.identC "ABS") last $ 
		     --[i | (i, Mods.ModMod m) <- Mods.modules (SS.grammar gr), Mods.isModAbs m]

newParser "" gr start inString = newParser "c" gr start inString

newParser opt gr (_,cat) _ = 
  Bad ("new-parser '" ++ opt ++ "' not defined yet")

ptree2term :: Ident.Ident -> ParseTree Name -> GF.Term
ptree2term a (TNode f ts) = Macros.mkApp (Macros.qq (a,f)) (map (ptree2term a) ts)
ptree2term a (TMeta)      = GF.Meta (GF.MetaSymb 0)

----------------------------------------------------------------------
-- conversion and unification of forests

convertFromCFForest :: ParseForest CFName -> [ParseForest Name]
convertFromCFForest (FNode (CFName name profile) children) 
    | isCoercion name = concat chForests
    | otherwise       = [ FNode name chForests | not (null chForests) ]
    where chForests   = concat [ mapM (checkProfile forests) profile |
				 forests0 <- children,
				 forests <- mapM convertFromCFForest forests0 ]
	  checkProfile forests = unifyManyForests . map (forests !!)
				 -- foldM unifyForests FMeta . map (forests !!)

isCoercion Ident.IW = True
isCoercion _        = False

unifyManyForests :: Eq n => [ParseForest n] -> [ParseForest n]
unifyManyForests [] = [FMeta]
unifyManyForests [f] = [f]
unifyManyForests (f:g:fs) = do h <- unifyForests f g
			       unifyManyForests (h:fs)

unifyForests :: Eq n => ParseForest n -> ParseForest n -> [ParseForest n]
unifyForests FMeta  forest = [forest]
unifyForests forest FMeta  = [forest]
unifyForests (FNode name1 children1) (FNode name2 children2)
    = [ FNode name1 children | name1 == name2, not (null children) ]
    where children = [ forests | forests1 <- children1, forests2 <- children2,
		       forests <- zipWithM unifyForests forests1 forests2 ]



{-
----------------------------------------------------------------------
-- conversion and unification for parse trees instead of forests

convertFromCFTree :: ParseTree CFName -> [ParseTree Name]
convertFromCFTree (TNode (CFName name profile) children0) 
    = [ TNode name children |
	children1 <- mapM convertFromCFTree children0,
	children <- mapM (checkProfile children1) profile ]
    where checkProfile trees = unifyManyTrees . map (trees !!)

unifyManyTrees :: Eq n => [ParseTree n] -> [ParseTree n]
unifyManyTrees [] = [TMeta]
unifyManyTrees [f] = [f]
unifyManyTrees (f:g:fs) = do h <- unifyTrees f g
			     unifyManyTrees (h:fs)

unifyTrees TMeta tree = [tree]
unifyTrees tree TMeta = [tree]
unifyTrees (TNode name1 children1) (TNode name2 children2)
    = [ TNode name1 children | name1 == name2, 
	children <- zipWithM unifyTrees children1 children2 ]

-}

