{-# LANGUAGE CPP #-}

module UHC.Light.Compiler.Base.RLList
( RLList (..)
, rllConcat, rllSingleton, rllEmpty, rllToList, rllFromList
, rllLength, rllNull
, rllIsPrefixOf
, rllInits, rllInit, rllInitLast
, rllHeadTail )
where
import Data.Maybe
import Data.List
import Control.Monad
import UHC.Util.Utils
import UHC.Util.Binary
import UHC.Util.Serialize



{-# LINE 34 "src/ehc/Base/RLList.chs" #-}
newtype RLList a
  = RLList [(a,Int)]
  deriving (Eq)

instance Ord a => Ord (RLList a) where
  (RLList [])           `compare` (RLList [])           = EQ
  (RLList [])           `compare` (RLList _ )           = LT
  (RLList _ )           `compare` (RLList [])           = GT
  (RLList ((x1,c1):l1)) `compare` (RLList ((x2,c2):l2)) | x1 == x2 = if c1 == c2
                                                                     then RLList l1 `compare` RLList l2
                                                                     else c1 `compare` c2
                                                        | x1 <  x2 = LT
                                                        | x1 >  x2 = GT

{-# LINE 50 "src/ehc/Base/RLList.chs" #-}
rllConcat :: Eq a => RLList a -> RLList a -> RLList a
rllConcat (RLList []) rll2  = rll2
rllConcat rll1 (RLList [])  = rll1
rllConcat (RLList l1) (RLList l2@(h2@(x2,c2):t2))
                            | x1 == x2  = RLList (h1 ++ [(x1,c1+c2)] ++ t2)
                            | otherwise = RLList (l1 ++ l2)
                            where (h1,t1@(x1,c1)) = fromJust (initlast l1)

rllEmpty :: RLList a
rllEmpty = RLList []

rllSingleton :: a -> RLList a
rllSingleton x = RLList [(x,1)]

rllToList :: RLList a -> [a]
rllToList (RLList l) = concatMap (\(x,c) -> replicate c x) l

rllFromList :: Eq a => [a] -> RLList a
rllFromList l = RLList [ (x,length g) | g@(x:_) <- group l ]

{-# LINE 72 "src/ehc/Base/RLList.chs" #-}
rllLength :: RLList a -> Int
rllLength (RLList l) = sum $ map snd l

rllNull :: RLList a -> Bool
rllNull (RLList []) = True
rllNull (RLList _ ) = False

{-# LINE 81 "src/ehc/Base/RLList.chs" #-}
rllIsPrefixOf :: Eq a => RLList a -> RLList a -> Bool
rllIsPrefixOf (RLList []) _ = True
rllIsPrefixOf _ (RLList []) = False
rllIsPrefixOf (RLList ((x1,c1):l1)) (RLList ((x2,c2):l2))
                            | x1 == x2  = if c1 < c2
                                          then True
                                          else if c1 > c2
                                          then False
                                          else rllIsPrefixOf (RLList l1) (RLList l2)
                            | otherwise = False

{-# LINE 94 "src/ehc/Base/RLList.chs" #-}
rllInitLast :: Eq a => RLList a -> Maybe (RLList a,a)
rllInitLast (RLList l ) = il [] l
                        where il acc [(x,1)]    = Just (RLList (reverse acc),x)
                              il acc [(x,c)]    = Just (RLList (reverse ((x,c-1):acc)),x)
                              il acc (a:as)     = il (a:acc) as
                              il _   _          = Nothing

rllInit :: Eq a => RLList a -> RLList a
rllInit = fst . fromJust . rllInitLast

rllInits :: Eq a => RLList a -> [RLList a]
rllInits = map rllFromList . inits . rllToList

{-# LINE 109 "src/ehc/Base/RLList.chs" #-}
rllHeadTail :: RLList a -> Maybe (a,RLList a)
rllHeadTail (RLList [])        = Nothing
rllHeadTail (RLList ((x,1):t)) = Just (x,RLList t)
rllHeadTail (RLList ((x,c):t)) = Just (x,RLList ((x,c-1):t))

{-# LINE 116 "src/ehc/Base/RLList.chs" #-}
instance Show a => Show (RLList a) where
  show = show . rllToList

{-# LINE 125 "src/ehc/Base/RLList.chs" #-}
#if __GLASGOW_HASKELL__ >= 708
deriving instance Typeable  RLList
#else
deriving instance Typeable1 RLList
#endif
deriving instance Data x => Data (RLList x)


{-# LINE 139 "src/ehc/Base/RLList.chs" #-}
instance Binary a => Binary (RLList a) where
  put (RLList a) = put a
  get = liftM RLList get