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
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)
]