{-# OPTIONS_GHC -O2 -fglasgow-exts -funbox-strict-fields #-}
module Text.Parser.PArrow.Prim (runParser, Res(..), PErr) where

import Text.Parser.PArrow.CharSet
import Text.Parser.PArrow.MD
import Data.ByteString.Base (ByteString(..))
import Data.Seq ((|>))
import qualified Data.Seq as Seq
import qualified Data.ByteString.Char8 as Str
import Data.IntMap (IntMap, singleton, empty, unionWith)
import Data.Generics

newtype ParseState = MkParseState { psInput :: ByteString }
    deriving (Show, Eq, Ord, Typeable, Data)

data Res r
    = POk !ParseState r
    | PErr !PErr
    deriving (Show)
type PSF r = ParseState -> Res r
type PErr = IntMap Label

optM :: MD i o -> PSF o
optM = matcher

err :: ParseState -> MD i o -> Res o'
err i p = PErr (singleton (psIndex i) (label p))

psIndex :: ParseState -> Int
psIndex MkParseState{ psInput = (PS _ s _) } = s

psEmptyMatch :: ParseState -> ByteString
psEmptyMatch MkParseState{ psInput = (PS p s _) } = PS p s 0

matcher :: forall i o. MD i o -> PSF o
matcher p@(MNot x) i =
    case optM x i of
        POk _ _  -> err i p
        PErr{}   -> POk i undefined
matcher (MChoice l) i =
    let mm acc []     = PErr acc
        mm acc (c:cs) = case optM c i of
            POk s t -> POk s t
            PErr err -> mm (unionWith mappend acc err) cs
    in mm empty l
matcher p@(MEqual x)     i@MkParseState{psInput = s} = if Str.isPrefixOf x s
    then let (pre, post) = Str.splitAt (Str.length x) s in POk i{psInput = post} pre
    else err i p
matcher p@(MDyn _ f)     i@MkParseState{psInput = s} = case f s of
    Just (ok, post) -> let pre = Str.take (Str.length s - Str.length post) s in
        POk i{psInput = post} (pre, ok)
    _               -> err i p
matcher (MSeq a b)       i = case optM a i of
    POk s t -> case b of
        (MPure _ f) -> POk s (f t)
        _           -> optM b s
    PErr e -> PErr e
matcher (MEmpty)        i = POk i (error "result for empty")
matcher (MPure _ _)     i = POk i (error "result for pure")
matcher p@(MCSet _)   i@MkParseState{psInput = s} | Str.null s = err i p
matcher (MCSet CS_Any) i@MkParseState{psInput = s} = POk i{psInput = Str.tail s} (Str.take 1 s)
matcher p@(MCSet cs)   i@MkParseState{psInput = s} = if cs `containsChar` Str.head s
    then POk i{psInput=Str.tail s} (Str.take 1 s)
    else err i p
matcher (MParWire _ _)  _ = error "matcher on ParWire"
matcher (MJoin a b) i = case optM a i of
    POk s t -> case optM b s of
        POk s' t' -> POk s' (t,t')
        PErr e    -> maybe (PErr e) (\a' -> optM (MJoin a' b) i) (backtrack a i)
    PErr e -> PErr e
matcher (MGreedy min max x) i =
    let p = optM x
        sm st acc len | QuantInt len >= max = POk st (Right acc)
        sm st acc len = case p st of
            POk st' r -> sm st' (acc |> r) (succ len)
            PErr e | len < min -> PErr e
            _ -> POk st (if Seq.null acc
                then (Left (psEmptyMatch i))
                else (Right acc))
        in sm i Seq.empty 0
matcher (MLazy 0 _ _) i = POk i (Left (psEmptyMatch i))
matcher (MLazy min max x) i =
    let p = optM x
        sm st acc len | len >= min = POk st (Right acc)
        sm st acc len | QuantInt len >= max = POk st (Right acc)
        sm st acc len = case p st of
            POk st' r -> sm st' (acc |> r) (succ len)
            PErr e | len < min -> PErr e
            _ -> POk st (if Seq.null acc
                then (Left (psEmptyMatch i))
                else (Right acc))
        in sm i Seq.empty 0

backtrack :: MD i o -> ParseState -> Maybe (MD i o)
backtrack a@(MGreedy min _ x) i =
    let POk _ r = optM a i in
    either (const Nothing) (backup . Seq.length) r
    where
    backup n | n <= min  = Nothing
             | otherwise = Just (MGreedy min (QuantInt (pred n)) x)
backtrack a@(MLazy _ max x) i =
    let POk _ r = optM a i in
    either (const $ backup 0) (backup . Seq.length) r
    where
    backup n | QuantInt n >= max  = Nothing
             | otherwise = Just (MLazy (succ n) max x)
backtrack (MJoin a b) i = do
    b' <- backtrack b i
    return (MJoin a b')
backtrack (MSeq a b@(MPure{})) i = do
    a' <- backtrack a i
    return (MSeq a' b)
backtrack _ _ = Nothing

-- | Run a parser producing either a list of error messages or output.
runParser :: Show o => MD i o -> ByteString -> Res o
runParser md input = optM md (MkParseState{psInput = input})