{-# LANGUAGE ScopedTypeVariables #-}

module UU.Parsing.Perms(Perms(), pPerms, pPermsSep, succeedPerms, (~*~), (~$~)) where

import UU.Parsing
import Data.Maybe

-- =======================================================================================
-- ===== PERMUTATIONS ================================================================
-- =======================================================================================

newtype Perms p a = Perms (Maybe (p a), [Br p a])
data Br p a = forall b. Br (Perms p (b -> a)) (p b)

instance IsParser p s => Functor (Perms p) where
  fmap f (Perms (mb, bs)) = Perms (fmap (f<$>) mb, map (fmap f) bs)

instance IsParser p s => Functor (Br p) where
  fmap f (Br perm p) = Br (fmap (f.) perm) p

(~*~) :: IsParser p s => Perms p (a -> b) -> p a -> Perms p b
perms ~*~ p = perms `add` (getzerop p, getonep p)

(~$~) :: IsParser p s => (a -> b) -> p a -> Perms p b
f     ~$~ p = succeedPerms f ~*~ p

succeedPerms :: IsParser p s => a -> Perms p a
succeedPerms x = Perms (Just (pLow x), [])

add :: IsParser p s => Perms p (a -> b) -> (Maybe (p a),Maybe (p a)) -> Perms p b
add b2a@(Perms (eb2a, nb2a)) bp@(eb, nb)
 =  let changing :: IsParser p s => (a -> b) -> Perms p a -> Perms p b
        f `changing` Perms (ep, np) = Perms (fmap (f <$>) ep, [Br ((f.) `changing` pp) p | Br pp p <- np])
    in Perms
      ( do { f <- eb2a
           ; x <- eb
           ; return (f <*>  x)
           }
      ,  (case nb of
          Nothing     -> id
          Just pb     -> (Br b2a  pb:)
        )[ Br ((flip `changing` c) `add`  bp) d |  Br c d <- nb2a]
      )

pPerms :: IsParser p s => Perms p a -> p a
pPerms (Perms (empty,nonempty))
 = foldl (<|>) (fromMaybe pFail empty) [ (flip ($)) <$> p <*> pPerms pp
                                       | Br pp  p <- nonempty
                                       ]

pPermsSep :: IsParser p s => p x -> Perms p a -> p a
pPermsSep (sep :: p z) perm = p2p (pSucceed ()) perm
 where  p2p ::  p () -> Perms p a -> p a
        p2p fsep (Perms (mbempty, nonempties)) =
                let empty          = fromMaybe  pFail mbempty
                    pars (Br t p)  = flip ($) <$ fsep <*> p <*> p2p_sep t
                in foldr (<|>) empty (map pars nonempties)
        p2p_sep =  p2p (()<$ sep)