module GLL.Combinators.Visit.FUNGLL where

import GLL.Types.Grammar
import GLL.Types.BSR
import GLL.Types.DataSets

import qualified Data.IntMap as IM
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.IntSet as IS
import qualified Data.Array as A

type Command t  = State t (ContF t) -> State t (ContF t)
data ContF t    = ContF (Descr t -> Command t)

type Parse_Symb t   = (Symbol t, Input t -> Slot t -> Int -> Int -> ContF t -> Command t)
type Parse_Choice t = Input t -> Nt -> Int -> ContF t -> Command t 
type Parse_Seq t    = Input t -> Nt -> [Symbol t] -> Int -> ContF t -> Command t
type Parse_Alt t    = Parse_Seq t

parser_for :: (Parseable t) => Nt -> Parse_Symb t -> Input t -> ParseResult t
parser_for x (Term t,p) inp = error "assert: terminal given to parser_for"
parser_for x (Nt s,p) inp = resultFromState inp (
  p inp (Slot x [Nt s] []) 0 0 cont0 emptyState) (s,0,0)
  where cont0 = ContF cf
          where cf (_,_,r) s | r == snd (A.bounds inp) = s { successes = successes s + 1 } 
                             | otherwise = s

parse_nterm :: (Ord t) => Nt -> [Parse_Seq t] -> Parse_Symb t
parse_nterm n = nterm n . foldl altOp altStart 

parse_term :: Parseable t => t -> Parse_Symb t
parse_term = term

parse_apply :: Ord t => Parse_Symb t -> Parse_Seq t
parse_apply = seqOp seqStart 

parse_seq :: Ord t => Parse_Seq t -> Parse_Symb t -> Parse_Seq t
parse_seq = seqOp

nterm :: (Ord t) => Nt -> Parse_Choice t -> Parse_Symb t
nterm n p = (Nt n, parser)
  where parser inp g l k c s 
          | null rs   = p inp n k cont_for s'
          | otherwise = compAll [ applyCF c (g,l,r) | r <- rs ] s'
          where s' = s { grel = addCont (n,k) (g,l,c) (grel s) } 
                rs = extents (n,k) (prel s) 

        cont_for = ContF cf 
         where cf (_,k,r) s = 
                compAll [ applyCF c (g,l',r) | (g,l',c) <- conts (n,k) (grel s) ] s'
                where s' = s { prel = addExtent (n,k) r (prel s) }

term :: Parseable t => t -> Parse_Symb t
term t = (Term t, parser)
  where parser inp g l k c s
          | lb <= k, k <= ub, matches (inp A.! k) t = applyCF c (g, l, k+1) s
          | otherwise                               = s
         where (lb,ub) = A.bounds inp

seqStart :: Ord t => Parse_Seq t
seqStart inp x beta l c = continue (Slot x [] beta, l, l, l) c

seqOp :: Ord t => Parse_Seq t -> Parse_Symb t -> Parse_Seq t
seqOp p (s,q) inp x beta l c0 = p inp x (s:beta) l c1
  where c1 = ContF c1f
         where c1f ((Slot _ alpha _),l,k) = q inp (Slot x (alpha++[s]) beta) l k c2
                where c2 = ContF c2f
                       where c2f (g,l,r) = continue (g,l,k,r) c0

continue :: (Ord t) => BSR t -> ContF t -> Command t
continue bsr@(g@(Slot x alpha beta),l,k,r) c s 
  | hasDescr descr (uset s) = s'
  | otherwise               = applyCF c descr s''
  where descr = (g,l,r)
        s'  | not (null alpha) || null beta = s { bsrs = addBSR bsr (bsrs s) }
            | otherwise                     = s
        s'' = s'  { uset = addDescr descr (uset s') }

altStart :: Parse_Choice t
altStart inp n l c s = s

altOp :: Parse_Choice t -> Parse_Seq t -> Parse_Choice t
altOp p q inp n l c = p inp n l c . q inp n [] l c

compAll :: [Command t] -> Command t
compAll = foldr (.) id

applyCF (ContF cf) a = cf a

-- | 
-- The "ParseResult" datatype contains some information about a parse:
--
--  * Whether the parse was successful
--  * The number of descriptors that have been processed
--  * The number of BSR elements 
data ParseResult t = ParseResult{ bsrs_result               :: BSRs t
                                , res_success               :: Bool
                                , res_successes             :: Int
                                , nr_descriptors            :: Int
                                , nr_bsrs                   :: Int
                                , error_message             :: String
                                }

resultFromState :: Parseable t => Input t -> State t c -> (Nt, Int, Int) -> ParseResult t
resultFromState inp (State uset _ _ pMap cs) (s, l, m) =
    let usize       = sum  [ S.size s   | (l, r2s) <- IM.assocs uset
                                        , (r,s) <- IM.assocs r2s ]
        p_nodes     = sum [ IS.size ks  | (l, r2j) <- IM.assocs pMap
                                        , (r, j2s) <- IM.assocs r2j
                                        , (j, s2k) <- IM.assocs j2s
                                        , (s, ks)  <- M.assocs s2k ]
    in ParseResult pMap (cs > 0) cs usize p_nodes "no errors to report" 

instance Show (ParseResult t) where
    show res | res_success res = result_string
             | otherwise       = result_string ++ "\n" ++ error_message res
     where result_string = unlines $
                [   "Success             "  ++ show (res_success res)
                ,   "#Success            "  ++ show (res_successes res)
                ,   "Descriptors:        "  ++ show (nr_descriptors res)
                ,   "BSRs:               "  ++ show (nr_bsrs res)
                ]