--==============================================================
-- CLASSES
--===============================================================
class Symbol s
instance (Ord s, Text s) => Symbol s

-- Class for parsers, with operations:
--    <?> :
--    <|> : choice
--    <*> : sequence

infixl 2 <?> ; infixl 3 <|> ; infixl 4 <*>

class Parsing p where
  empty  :: Symbol s => a -> p s a
  symbol :: Symbol s => s -> p s s
  (<?>)  :: Symbol s => p s a      -> (a,String) -> p s a
  (<|>)  :: Symbol s => p s a      -> p s a -> p s a
  (<*>)  :: Symbol s => p s (b->a) -> p s b -> p s a

-- <$> : semantic giving function
-- opt : optional input

infixl 4 <$> ; infixl 2 `opt`

(<$>) :: (Parsing p, Symbol s) => (b->a) -> p s b -> p s a
f <$> p = empty f <*> p

opt :: (Parsing p, Symbol s) => p s a -> a -> p s a
p `opt` v = p <|> empty v

-- many   : (p)*
-- chainr : (operand operator)*
-- chainl : (operator operand)*

many :: (Parsing p, Symbol s) => p s a -> p s [a]
many p = (\a as -> a:as) <$> p <*> many p `opt` []

chainr :: (Parsing p, Symbol s) => p s a -> p s (a -> a -> a) -> p s a
chainr x op = (\x f -> f x) <$> x <*> f where
  f = (\op x -> (`op` x)) <$> op <*> chainr x op `opt` id

-- chainl :: (Parsing p, Symbol s) => p s (a -> a -> a) ->  p s a -> p s a
-- chainl op x =

--===============================================================
-- COMPUTING EMPTY PROPERTY
--===============================================================
type Empty s a = Bool in
  eempty, esymbol, eerr, ealt, eseq,
  invokeEmpty,
  dpalt, dpseq,
  combine

instance Parsing Empty where
  empty  = eempty
  symbol = esymbol
  (<?>)  = eerr
  (<|>)  = ealt
  (<*>)  = eseq

eempty  :: a -> Empty s a
eempty  _ = True

esymbol :: s -> Empty s s
esymbol _ = False

eerr :: Empty s a      -> (a,String) -> Empty s a
eerr _ _  = False

ealt :: Empty s a      -> Empty s a  -> Empty s a
ealt      = (||)

eseq :: Empty s (b->a) -> Empty s b  -> Empty s a
eseq      = (&&)

invokeEmpty  :: Empty s a -> Bool
invokeEmpty p = p

--===============================================================
-- UTILS.GS
--===============================================================
combine :: Symbol s => Empty s a -> [s] -> [s] -> [s] 
combine e s1 s2 = s1 `union` (if e then s2 else [])

union :: Eq x => [x] -> [x] -> [x]
xs `union` ys = nub(xs++ys)

--===============================================================
-- COMPUTING FIRST SETS 
--===============================================================
type First s a  = [s]
type EmpFir s a = (Empty s a, First s a) in
  efempty, efsymbol, eferr, efalt, efseq,
  dpalt, dpseq,
  invokeFirst

instance Parsing EmpFir where
  empty  = efempty
  symbol = efsymbol
  (<?>)  = eferr
  (<|>)  = efalt
  (<*>)  = efseq
efempty  :: Symbol s => a -> EmpFir s a
efempty  v = (eempty  v, fempty  v)
fempty _   = []

efsymbol :: Symbol s => s -> EmpFir s s
efsymbol s = (esymbol s, fsymbol s)
fsymbol s  = [s]

eferr :: Symbol s => EmpFir s a  -> (a,String) -> EmpFir s a
(e,  f)  `eferr`  x        = (e  `eerr` x,  f  `ferr` x)
ss       `ferr` _          = ss

efalt :: Symbol s => EmpFir s a  -> EmpFir s a -> EmpFir s a
(e1, f1) `efalt`  (e2, f2) = (e1 `ealt` e2, f1 `falt` f2)
ss `falt` ss'              = ss `union` ss'


efseq :: Symbol s => EmpFir s (b->a)-> EmpFir s b -> EmpFir s a
(e1, f1) `efseq` ~(e2, f2) = (e1 `eseq` e2, f1 `fseq` f2)
                               where fseq = combine e1


invokeFirst  :: Symbol s => EmpFir s a -> First s a
invokeFirst (_,f) = f
--===============================================================
-- DETERMINISTIC PARSERS
--===============================================================
type Input s = [s]
type Follow s = [s]
type DetParFun s a = Input s -> Follow s -> (a,Input s)

type DetPar s a = (EmpFir s a, DetParFun s a) in
  dpempty, dpsymbol, dperr, dpalt, dpseq,
  invokeDet

instance Parsing DetPar where
  empty  = dpempty
  symbol = dpsymbol
  (<?>)  = dperr
  (<|>)  = dpalt
  (<*>)  = dpseq

dpempty  :: Symbol s => a -> DetPar s a
dpempty  v = (efempty  v, pempty  v)
pempty   v = \inp  _ -> (v,inp)

dpsymbol :: Symbol s => s -> DetPar s s
dpsymbol s = (efsymbol s, psymbol s)
psymbol s  = \(_:inp) _ -> (s,inp)


dperr :: Symbol s => DetPar s a -> (a,String) -> DetPar s a
dp `dperr` (v,_) = dp `dpalt` (efempty v, pempty v)

dpalt :: Symbol s => 
         DetPar s a     -> DetPar s a -> DetPar s a
(ef1@(e1, f1), p1) `dpalt` (ef2@(e2, f2), p2)
  = (ef1 `efalt` ef2, p1 `palt` p2) where
 p1 `palt` p2 = p where
  p [] follow =
    if      e1 then p1 [] follow
    else if e2 then p2 [] follow
    else error "Unexpected Eof"
  p inp@(s:_) follow =
    let applicable e first = s `elem` (combine e first follow)          
    in (if      applicable e1 f1 then p1 
        else if applicable e2 f2 then p2
        else error ("Illegal input symbol: " ++ show s)
       ) inp follow


dpseq :: Symbol s => 
         DetPar s (b->a)-> DetPar s b -> DetPar s a
(ef1, p1) `dpseq` ~(ef2@(e2, f2), p2)
  = (ef1 `efseq` ef2, p1 `pseq` p2) where
 p1 `pseq` p2
  = \inp follow ->
      let (v1, inp1) = p1 inp (combine e2 f2 follow)
          (v2, inp2) = p2 inp1 follow
      in  (v1 v2, inp2)

invokeDet :: Symbol s => DetPar s a -> Input s -> a
invokeDet (_,p) inp = case p inp [] of (a,_) -> a
data SearchTree a = Node (SearchTree a) a (SearchTree a)
                  | Leaf a
                  | Nil

--===============================================================
-- SEARCH TREES
--===============================================================
type ParserTree s a = SearchTree (Look s (ErrParFun s a))

find i Nil notfound = notfound
find i (Leaf (Look s p)) notfound = 
                     if i == s then p else notfound
find i (Node left (Look s p) right) notfound
      | i == s = p
      | i <  s = find i left  notfound
      | i >  s = find i right notfound
tab2tree :: Symbol s => ParserTab s a -> ParserTree s a
tab2tree tab = tree
  where
    (tree,[]) = sl2bst (length tab) (qsort tab)
    qsort []  = []
    qsort (look@(Look s _):tab)
     = qsort  [look | look@(Look t _) <- tab, t <= s ]
          ++ [look] ++
       qsort [look | look@(Look t _) <- tab, t > s]
    sl2bst 0 list     = (Nil   , list)
    sl2bst 1 (v:rest) = (Leaf v, rest)
    sl2bst n list
     = let
         ll = (n - 1) `div` 2 ; rl = n - 1 - ll
         (lt,a:list1) = sl2bst ll list
         (rt,  list2) = sl2bst rl list1
       in (Node lt a rt, list2)
--===============================================================
-- ERROR CORRECTING PARSERS
--===============================================================
type ErrCorrPar s a = (EmptyDescr s a, First s a, 
                       ParserTab s a) in
  ecpempty, ecpsymbol, ecperr, ecpalt, ecpseq, invokeErr

data EmptyDescr s a = IsEmpty a
                    | Insert a String

data Look      s a  = Look s a
type ParserTab s a  = [Look s (ErrParFun s a)]

mapParser tab f     = [Look s (f p) | Look s p <- tab]

type ErrParFun s a  = State s -> Noskip s -> (a, State s)
type State s  = ([s],String)
type Noskip s = [[s]]
instance Parsing ErrCorrPar where
  empty  = ecpempty
  symbol = ecpsymbol
  (<?>)  = ecperr
  (<*>)  = ecpseq
  (<|>)  = ecpalt

edempty  v = IsEmpty v
edsymbol s = Insert s (inserted s)
inserted s = show s ++ " inserted\n"

ederr (v,msg) = Insert v (inserted msg)

ed1 `edalt` ed2 =
  case ed1 of
    IsEmpty _  -> ed1
    Insert _ _ -> ed2
ed1 `edseq` ed2 =
  case ed1 of
    IsEmpty v1
      -> case ed2 of
           IsEmpty v2    -> IsEmpty (v1 v2)
           Insert  v2 s2 -> Insert  (v1 v2) s2
    Insert v1 s1 ->
      Insert (case ed2 of
                IsEmpty v2   -> v1 v2
                Insert  v2 _ -> v1 v2
             )
             (case ed2 of
                IsEmpty _    -> s1
                Insert  _ s2 -> s1++s2
             )

-- This is  the "most lazy formulation"!
ecpempty  :: Symbol s => a -> ErrCorrPar s a
ecpempty  v = (edempty  v, fempty  v, tempty  v)
tempty  _   = []

ecpsymbol :: Symbol s => s -> ErrCorrPar s s
ecpsymbol s = (edsymbol s, fsymbol s, tsymbol s)
tsymbol   s = [Look s (\((t:inp), str) _ -> (t, (inp, str)))]

ecperr :: Symbol s => 
          ErrCorrPar s a    -> (a,String) -> ErrCorrPar s a
ep `ecperr` x  = ep `ecpalt` (ederr x, fempty x, tempty x)

ecpalt :: Symbol s => 
          ErrCorrPar s a    -> ErrCorrPar s a -> ErrCorrPar s a
(ed1, f1, t1) `ecpalt` (ed2, f2, t2)
  = (ed1 `edalt` ed2, f1 `falt` f2, t1 `talt` t2)

talt :: ParserTab s a -> ParserTab s a -> ParserTab s a
talt = (++)

choose (edp,_) state@([],_) noskip = insorempty edp state
choose x@(edp, ptree) state@((s:inp), errors) noskip
  = find s ptree
     (\_ _
        -> if any (s `elem`) noskip then insorempty edp state
           else choose x (inp, errors ++ deleted s) noskip
     ) state noskip
choose _ _ _ = error "no good alternative"

deleted  s = show s ++ " deleted\n"
insorempty edp state@(input,errors)
  = case edp of
      IsEmpty pv      -> (pv, state)
      Insert pv error -> (pv, (input, errors ++ error))

ecpseq :: Symbol s => 
          ErrCorrPar s (b->a)-> ErrCorrPar s b ->ErrCorrPar s a
(ed1, f1, t1) `ecpseq` ~(ed2, f2, t2)
  = (ed1 `edseq` ed2, f1 `fseq` f2, t1 `tseq` t2)
    where 
 f1 `fseq` f2 = f1 `union` case ed1 of IsEmpty _  -> f2 
                                       Insert _ _ -> []
 t1 `tseq` t2
      = mapParser t1
        (\p ss noskip ->
          let  (v1,rs)  = p ss (f2:noskip)
               (v2,rrs) = choose (ed2, tab2tree t2) rs noskip
          in (v1 v2, rrs)
        )
       ++ case ed1 of IsEmpty v1 -> mapParser t2
                                   (\q ss noskip ->
                                     let (v2, rs) = q ss noskip
                                     in  (v1 v2, rs)
                                   )
                      Insert _ _ -> []

    


invokeErr :: Symbol s => 
             ErrCorrPar s a -> Input s -> (a, String)
invokeErr (edp, _, look_table) input =
  let (a, (_, errors)) = 
         choose (edp, tab2tree look_table) (input, []) []
  in (a, errors)

display (a, errors) = show a ++ "\n" ++ errors

--===============================================================
-- EXAMPLE: STATEMENTS
--===============================================================

sym  :: (Parsing p, Symbol s) => s -> p s [s]
sym s = (\x -> [x]) <$> symbol s

stat :: Parsing p => p Char String
stat =     if_stat
       <|> while_stat
       <|> assignment
       <?> ("<s>", "<stat>")

stats :: Parsing p => p Char String
stats  = chainr stat ((\s x y ->x++s++y) <$> sym ';')

if_stat :: Parsing p => p Char String
if_stat = (\i c tp ep f -> i++c++tp++ep++f) 
          <$> sym 'I' <*> cond 
          <*> then_part 
          <*> else_part 
          <*> sym 'F'

then_part :: Parsing p => p Char String
then_part  = (\t ss -> t++ss) <$> sym 'T' <*> stats

else_part :: Parsing p => p Char String
else_part  = (\e ss -> e++ss) <$> sym 'E' <*> stats `opt` []

while_stat :: Parsing p => p Char String
while_stat = (\w c d ss o -> w++c++d++ss++o) 
             <$> sym 'W' <*> cond 
             <*> sym 'D' 
             <*> stats 
             <*> sym 'O'

assignment :: Parsing p => p Char String
assignment  = sym 'a'

cond :: Parsing p => p Char String
cond  = sym 'c'