module UU.Parsing.Derived where

import UU.Parsing.Interface

infixl 2 <?>
infixl 4  <**>, <??>, <+>
infixl 2 `opt`
infixl 5 <..>


-- =======================================================================================
-- ===== CHECKING ========================================================================
-- =======================================================================================
-- | Checks if the parser accepts epsilon.
acceptsepsilon :: (IsParser p s) => p v -> Bool
acceptsepsilon p       = case getzerop p of {Nothing -> False; _ -> True}

mnz :: (IsParser p s) => p v -> t -> String -> t
mnz p v comb
   = if( acceptsepsilon p)
     then   usererror ("The combinator <" ++ comb ++ "> from <Derived.hs>is called with a parser that accepts the empty string.\n"
                    ++
                   "The library cannot handle the resulting left recursive formulation (which is ambiguous too).\n"
                 --  ++
                 --  (case getfirsts p of
                 --   ESeq []  ->  "There are no other alternatives for this parser"
                 --   d        ->  "The other alternatives of this parser may start with:\n"++ show d
                  ) --)
     else v
-- =======================================================================================
-- ===== START OF PRELUDE DEFINITIONS ========== =========================================
-- =======================================================================================

-- | Parses the specified range, see also 'pRange'.
-- 
-- Example:
-- 
-- > pDig = 'a' <..> 'z'
(<..>) :: (IsParser p s) => s -> s -> p s
a <..> b   = pRange a (Range a b)

pExcept :: (IsParser p s, Symbol s, Ord s, Eq (SymbolR s)) => (s, s, s) -> [s] -> p s
pExcept (l,r,err) elems = let ranges = filter (/= EmptyR) (Range l r `except` elems)
                          in if null ranges then pFail
                             else foldr (<|>) pFail (map (pRange err) ranges)



-- | Optionally recognize parser 'p'.
-- 
-- If 'p' can be recognized, the return value of 'p' is used. Otherwise,
-- the value 'v' is used. Note that opt is greedy, if you do not want
-- this use @... <|> pSucceed v@  instead. Furthermore, 'p' should not
-- recognise the empty string.
opt ::  (IsParser p s) => p a -> a -> p a
p `opt` v       = mnz p (p  <|> pLow v)  "opt"  
                                                
                                                

-- =======================================================================================
-- ===== Special sequential compositions =========================================
-- =======================================================================================
asList ::  (IsParser p s) =>  Expecting s -> p v -> p v
asList  exp = setfirsts (ESeq [EStr "(",  exp, EStr  " ...)*"])

asList1 :: (IsParser p s) => Expecting s -> p v -> p v
asList1 exp = setfirsts (ESeq [EStr "(",  exp, EStr  " ...)+"])

asOpt :: (IsParser p s) => Expecting s -> p v -> p v
asOpt   exp = setfirsts (ESeq [EStr "( ", exp, EStr  " ...)?"])

-- | Parses the sequence of 'pa' and 'pb', and combines them as a tuple.
(<+>) :: (IsParser p s) => p a -> p b -> p (a, b)
pa <+> pb       = (,) <$> pa <*> pb

-- | Suppose we have a parser a with two alternatives that both start
-- with recognizing a non-terminal p, then we will typically rewrite:
--
-- > a =     f <$> p <*> q 
-- >     <|> g <$> p <*> r 
--
-- into: 
--
-- > a = p <**> (f <$$> q <|> g <$$> r)
(<**>) :: (IsParser p s) => p a -> p (a -> b) -> p b
p <**> q        = (\ x f -> f x) <$> p <*> q

(<$$>) :: (IsParser p s) => (a -> b -> c) -> p b -> p (a -> c)
f <$$> p        = pSucceed (flip f) <*> p

(<??>) :: (IsParser p s) => p a -> p (a -> a) -> p a
p <??> q        = p <**> (q `opt` id)

(<?>) :: (IsParser p s) => p v -> String -> p v
p <?>  str      = setfirsts  (EStr str) p

-- | This can be used to parse 'x' surrounded by 'l' and 'r'.
-- 
-- Example:
--
-- > pParens = pPacked pOParen pCParen
pPacked :: (IsParser p s) => p a -> p b1 -> p b -> p b
pPacked l r x   =   l *>  x <*   r

-- =======================================================================================
-- ===== Iterating ps ===============================================================
-- =======================================================================================
pFoldr_ng :: (IsParser p s) => (a -> a1 -> a1, a1) -> p a -> p a1
pFoldr_ng      alg@(op,e)     p = mnz p (asList (getfirsts p) pfm) "pFoldr_ng"
                                  where pfm = (op <$> p <*> pfm)  <|> pSucceed e
pFoldr_gr :: (IsParser p s) => (a -> b -> b, b) -> p a -> p b
pFoldr_gr      alg@(op,e)     p = mnz p (asList (getfirsts p) pfm) "pFoldr_gr"
                                  where pfm = (op <$> p <*> pfm) `opt` e
pFoldr :: (IsParser p s) =>(a -> b -> b, b) -> p a -> p b
pFoldr         alg            p = pFoldr_gr alg p

pFoldr1_gr :: (IsParser p s) => (v -> b -> b, b) -> p v -> p b
pFoldr1_gr     alg@(op,e)     p = asList1 (getfirsts p) (op <$> p <*> pFoldr_gr  alg p)
pFoldr1_ng ::  (IsParser p s) => (v -> b -> b, b) -> p v -> p b
pFoldr1_ng     alg@(op,e)     p = asList1 (getfirsts p) (op <$> p <*> pFoldr_ng  alg p)
pFoldr1 :: (IsParser p s) => (v -> b -> b, b) -> p v -> p b
pFoldr1        alg            p = pFoldr1_gr alg  p

pFoldrSep_gr :: (IsParser p s) => (v -> b -> b, b) -> p a -> p v -> p b
pFoldrSep_gr   alg@(op,e) sep p = mnz sepp (asList (getfirsts p)((op <$> p <*> pFoldr_gr alg sepp) `opt` e )) "pFoldrSep_gr (both args)"
                                  where sepp = sep *> p
pFoldrSep_ng :: (IsParser p s) => (v -> b -> b, b) -> p a -> p v -> p b
pFoldrSep_ng   alg@(op,e) sep p = mnz sepp (asList (getfirsts p)((op <$> p <*> pFoldr_ng alg sepp)  <|>  pSucceed e)) "pFoldrSep_ng (both args)"
                                  where sepp = sep *> p
pFoldrSep ::  (IsParser p s) => (v -> b -> b, b) -> p a -> p v -> p b
pFoldrSep      alg        sep p = pFoldrSep_gr alg sep p

pFoldr1Sep_gr :: (IsParser p s) => (a -> b -> b, b) -> p a1 -> p a -> p b
pFoldr1Sep_gr  alg@(op,e) sep p = if acceptsepsilon sep then mnz p pfm "pFoldr1Sep_gr (both arguments)" else pfm
                                  where pfm = op <$> p <*> pFoldr_gr alg (sep *> p)
pFoldr1Sep_ng :: (IsParser p s) => (a -> b -> b, b) -> p a1 -> p a -> p b
pFoldr1Sep_ng  alg@(op,e) sep p = if acceptsepsilon sep  then mnz p pfm "pFoldr1Sep_ng (both arguments)" else pfm
                                  where pfm = op <$> p <*> pFoldr_ng alg (sep *> p)
pFoldr1Sep :: (IsParser p s) => (a -> b -> b, b) -> p a1 -> p a -> p b
pFoldr1Sep     alg        sep p = pFoldr1Sep_gr alg sep p

list_alg :: (a -> [a] -> [a], [a1])
list_alg = ((:), [])

pList_gr ::  (IsParser p s) => p a -> p [a]
pList_gr        p = pFoldr_gr     list_alg   p
pList_ng :: (IsParser p s) =>  p a -> p [a]
pList_ng        p = pFoldr_ng     list_alg   p
pList ::  (IsParser p s) => p a -> p [a]
pList           p = pList_gr p

pList1_gr ::  (IsParser p s) => p a -> p [a]
pList1_gr       p = pFoldr1_gr    list_alg   p
pList1_ng :: (IsParser p s) => p a -> p [a]
pList1_ng       p = pFoldr1_ng    list_alg   p
pList1 :: (IsParser p s) =>  p a -> p [a]
pList1          p = pList1_gr                p

pListSep_gr :: (IsParser p s) => p a1 -> p a -> p [a]
pListSep_gr   s p = pFoldrSep_gr  list_alg s p
pListSep_ng :: (IsParser p s) => p a1 -> p a -> p [a]
pListSep_ng   s p = pFoldrSep_ng  list_alg s p
pListSep :: (IsParser p s) => p a -> p a1 -> p [a1]
pListSep      s p = pListSep_gr            s p

pList1Sep_gr :: (IsParser p s) => p a1 -> p a -> p [a]
pList1Sep_gr  s p = pFoldr1Sep_gr list_alg s p
pList1Sep_ng :: (IsParser p s) =>  p a1 -> p a -> p [a]
pList1Sep_ng  s p = pFoldr1Sep_ng list_alg s p
pList1Sep :: (IsParser p s) =>p a -> p a1 -> p [a1]
pList1Sep     s p = pList1Sep_gr          s p

pChainr_gr :: (IsParser p s) => p (c -> c -> c) -> p c -> p c
pChainr_gr op x    =  if acceptsepsilon op then mnz x r "pChainr_gr (both arguments)" else r
                   where r = x <??> (flip <$> op <*> r)
pChainr_ng :: (IsParser p s) => p (a -> a -> a) -> p a -> p a
pChainr_ng op x    =  if acceptsepsilon op then mnz x r "pChainr_ng (both arguments)" else r
                   where r = x <**> ((flip <$> op <*> r)  <|> pSucceed id)
pChainr :: (IsParser p s) => p (c -> c -> c) -> p c -> p c
pChainr    op x    = pChainr_gr op x

pChainl_gr :: (IsParser p s) => p (c -> c -> c) -> p c -> p c
pChainl_gr op x    =  if acceptsepsilon op then mnz x r "pChainl_gr (both arguments)" else r
                      where
                       r      = (f <$> x <*> pList_gr (flip <$> op <*> x) )
                       f x [] = x
                       f x (func:rest) = f (func x) rest

pChainl_ng :: (IsParser p s) => p (c -> c -> c) -> p c -> p c
pChainl_ng op x    =  if acceptsepsilon op then mnz x r "pChainl_ng (both arguments)" else r
                   where
                    r      = (f <$> x <*> pList_ng (flip <$> op <*> x) )
                    f x [] = x
                    f x (func:rest) = f (func x) rest
pChainl :: (IsParser p s) => p (c -> c -> c) -> p c -> p c
pChainl    op x    = pChainl_gr op x

-- | Parses using any of the parsers in the list 'l'.
--
-- Warning: 'l' may not be an empty list.
pAny :: (IsParser p s) =>(a -> p a1) -> [a] -> p a1
pAny  f l = if null l then usererror "pAny: argument may not be empty list" else foldr1 (<|>) (map f l)

-- | Parses any of the symbols in 'l'.
pAnySym :: (IsParser p s) =>[s] -> p s
pAnySym l = pAny pSym l -- used to be called pAnySym

pToks :: (IsParser p s) => [s] -> p [s]
pToks []     = pSucceed []
pToks (a:as) = (:) <$> pSym a <*> pToks as

pLocate :: (IsParser p s) => [[s]] -> p [s]
pLocate list = pAny pToks list