-- |
--   Module      :  Data.Edison.Coll.Defaults
--   Copyright   :  Copyright (c) 1998, 2008 Chris Okasaki
--   License     :  MIT; see COPYRIGHT file for terms and conditions
--
--   Maintainer  :  robdockins AT fastmail DOT fm
--   Stability   :  internal (unstable)
--   Portability :  GHC / Hugs (MPTC and FD)
--
--   This module provides default implementations of many of the collection methods.  The functions
--   in this module are used to fill out collection implementations and are not intended to be
--   used directly by end users.

module Data.Edison.Coll.Defaults where

import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter)
import Control.Monad.Identity

import Data.Edison.Coll
import qualified Data.Edison.Seq as S
import qualified Data.Edison.Seq.ListSeq as L
import Data.Edison.Seq.Defaults (tokenMatch,maybeParens)

insertSeqUsingUnion :: (CollX c a,S.Sequence seq) => seq a -> c -> c
insertSeqUsingUnion xs c = union (fromSeq xs) c

insertSeqUsingFoldr :: (CollX c a,S.Sequence seq) => seq a -> c -> c
insertSeqUsingFoldr xs c = S.foldr insert c xs

memberUsingFold :: Coll c a => c -> a -> Bool
memberUsingFold h x = fold (\y ans -> (x == y) || ans) False h

countUsingMember :: SetX c a => a -> c -> Int
countUsingMember x xs = if member x xs then 1 else 0

lookupAllUsingLookupM :: (Set c a,S.Sequence seq) => a -> c -> seq a
lookupAllUsingLookupM x xs =
  case lookupM x xs of
    Nothing -> S.empty
    Just y  -> S.singleton y

deleteSeqUsingDelete :: (CollX c a,S.Sequence seq) => seq a -> c -> c
deleteSeqUsingDelete xs c = S.foldr delete c xs

unionSeqUsingFoldl :: (CollX c a,S.Sequence seq) => seq c -> c
unionSeqUsingFoldl = S.foldl union empty

unionSeqUsingFoldl' :: (CollX c a,S.Sequence seq) => seq c -> c
unionSeqUsingFoldl' = S.foldl' union empty

unionSeqUsingReduce :: (CollX c a,S.Sequence seq) => seq c -> c
unionSeqUsingReduce = S.reducel union empty

fromSeqUsingFoldr :: (CollX c a,S.Sequence seq) => seq a -> c
fromSeqUsingFoldr = S.foldr insert empty

fromSeqUsingUnionSeq :: (CollX c a,S.Sequence seq) => seq a -> c
fromSeqUsingUnionSeq = unionList . S.foldl singleCons []
  where singleCons xs x = S.lcons (singleton x) xs

toSeqUsingFold :: (Coll c a,S.Sequence seq) => c -> seq a
toSeqUsingFold = fold S.lcons S.empty

unsafeInsertMaxUsingUnsafeAppend :: OrdCollX c a => a -> c -> c
unsafeInsertMaxUsingUnsafeAppend x c = unsafeAppend c (singleton x)

toOrdSeqUsingFoldr :: (OrdColl c a,S.Sequence seq) => c -> seq a
toOrdSeqUsingFoldr = foldr S.lcons S.empty

unsafeFromOrdSeqUsingUnsafeInsertMin ::
    (OrdCollX c a,S.Sequence seq) => seq a -> c
unsafeFromOrdSeqUsingUnsafeInsertMin = S.foldr unsafeInsertMin empty

disjointUsingToOrdList :: OrdColl c a => c -> c -> Bool
disjointUsingToOrdList xs ys = disj (toOrdList xs) (toOrdList ys)
  where disj a@(c:cs) b@(d:ds) =
          case compare c d of
            LT -> disj cs b
            EQ -> False
            GT -> disj a ds
        disj _ _ = True

intersectWitnessUsingToOrdList ::
        (OrdColl c a, Monad m) => c -> c -> m (a,a)
intersectWitnessUsingToOrdList as bs = witness (toOrdList as) (toOrdList bs)
  where witness a@(x:xs) b@(y:ys) =
          case compare x y of
            LT -> witness xs b
            EQ -> return (x, y)
            GT -> witness a ys
        -- XXX
        witness _ _ = fail $ instanceName as ++ ".intersect: failed"

lookupUsingLookupM :: Coll c a => a -> c -> a
lookupUsingLookupM x ys = runIdentity (lookupM x ys)

lookupUsingLookupAll :: Coll c a => a -> c -> a
lookupUsingLookupAll x ys =
  case lookupAll x ys of
    (y:_) -> y
    [] -> error $ instanceName ys ++ ".lookup: lookup failed"

lookupMUsingLookupAll :: (Coll c a, Monad m) => a -> c -> m a
lookupMUsingLookupAll x ys =
  case lookupAll x ys of
    (y:_) -> return y
    []    -> fail $ instanceName ys ++ ".lookupM: lookup failed"

lookupWithDefaultUsingLookupAll :: Coll c a => a -> a -> c -> a
lookupWithDefaultUsingLookupAll dflt x ys =
  case lookupAll x ys of
    (y:_) -> y
    [] -> dflt

lookupWithDefaultUsingLookupM :: Coll c a => a -> a -> c -> a
lookupWithDefaultUsingLookupM dflt x ys =
  case lookupM x ys of
    Just y  -> y
    Nothing -> dflt

deleteMaxUsingMaxView :: OrdColl c a => c -> c
deleteMaxUsingMaxView c =
  case maxView c of
    Just (_,c') -> c'
    Nothing     -> c

fromSeqWithUsingInsertWith :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq a -> c
fromSeqWithUsingInsertWith c = S.foldr (insertWith c) empty

insertUsingInsertWith :: Set c a => a -> c -> c
insertUsingInsertWith = insertWith (\x _ -> x)

unionUsingUnionWith :: Set c a => c -> c -> c
unionUsingUnionWith = unionWith (\x _ -> x)

filterUsingOrdLists :: OrdColl c a => (a -> Bool) -> c -> c
filterUsingOrdLists p = unsafeFromOrdList . L.filter p . toOrdList

partitionUsingOrdLists :: OrdColl c a => (a -> Bool) -> c -> (c,c)
partitionUsingOrdLists p xs = (unsafeFromOrdList ys,unsafeFromOrdList zs)
  where (ys,zs) = L.partition p (toOrdList xs)

intersectionUsingIntersectionWith :: Set c a => c -> c -> c
intersectionUsingIntersectionWith = intersectionWith (\x _ -> x)

differenceUsingOrdLists :: OrdSet c a => c -> c -> c
differenceUsingOrdLists as bs = unsafeFromOrdList $ diff (toOrdList as) (toOrdList bs)
  where diff a@(x:xs) b@(y:ys) =
          case compare x y of
            LT -> x : diff xs b
            EQ -> diff xs ys
            GT -> diff a ys
        diff a _ = a

symmetricDifferenceUsingDifference :: SetX c a => c -> c -> c
symmetricDifferenceUsingDifference xs ys = union (difference xs ys) (difference ys xs)

properSubsetUsingOrdLists :: OrdSet c a => c -> c -> Bool
properSubsetUsingOrdLists xs ys = properSubsetOnOrdLists (toOrdList xs) (toOrdList ys)

subsetUsingOrdLists :: OrdSet c a => c -> c -> Bool
subsetUsingOrdLists xs ys = subsetOnOrdLists (toOrdList xs) (toOrdList ys)

properSubsetOnOrdLists :: (Ord t) => [t] -> [t] -> Bool
properSubsetOnOrdLists [] [] = False
properSubsetOnOrdLists [] (_:_) = True
properSubsetOnOrdLists (_:_) [] = False
properSubsetOnOrdLists a@(x:xs) (y:ys) =
  case compare x y of
    LT -> False
    EQ -> properSubsetOnOrdLists xs ys
    GT -> subsetOnOrdLists a ys

subsetOnOrdLists :: (Ord t) => [t] -> [t] -> Bool
subsetOnOrdLists [] _ = True
subsetOnOrdLists (_:_) [] = False
subsetOnOrdLists a@(x:xs) (y:ys) =
  case compare x y of
    LT -> False
    EQ -> subsetOnOrdLists xs ys
    GT -> subsetOnOrdLists a ys

insertSeqWithUsingInsertWith :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq a -> c -> c
insertSeqWithUsingInsertWith c xs s = S.foldr (insertWith c) s xs

unionlUsingUnionWith :: Set c a => c -> c -> c
unionlUsingUnionWith xs ys = unionWith (\x _ -> x) xs ys

unionrUsingUnionWith :: Set c a => c -> c -> c
unionrUsingUnionWith xs ys = unionWith (\_ y -> y) xs ys

unionWithUsingOrdLists :: OrdSet c a => (a -> a -> a) -> c -> c -> c
unionWithUsingOrdLists c as bs = unsafeFromOrdList $ merge (toOrdList as) (toOrdList bs)
  where merge a@(x:xs) b@(y:ys) =
          case compare x y of
            LT -> x : merge xs b
            EQ -> c x y : merge xs ys
            GT -> y : merge a ys
        merge a [] = a
        merge [] b = b

unionSeqWithUsingReducer :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq c -> c
unionSeqWithUsingReducer c = S.reducer (unionWith c) empty

intersectionWithUsingOrdLists :: OrdSet c a => (a -> a -> a) -> c -> c -> c
intersectionWithUsingOrdLists c as bs = unsafeFromOrdList $ inter (toOrdList as) (toOrdList bs)
  where inter a@(x:xs) b@(y:ys) =
          case compare x y of
            LT -> inter xs b
            EQ -> c x y : inter xs ys
            GT -> inter a ys
        inter _ _ = []


unsafeMapMonotonicUsingFoldr :: (OrdColl cin a, OrdCollX cout b) => (a -> b) -> (cin -> cout)
unsafeMapMonotonicUsingFoldr f xs = foldr (unsafeInsertMin . f) empty xs

showsPrecUsingToList :: (Coll c a,Show a) => Int -> c -> ShowS
showsPrecUsingToList i xs rest
  | i == 0    = concat [    instanceName xs,".fromSeq ",showsPrec 10 (toList xs) rest]
  | otherwise = concat ["(",instanceName xs,".fromSeq ",showsPrec 10 (toList xs) (')':rest)]

readsPrecUsingFromList :: (Coll c a, Read a) => Int -> ReadS c
readsPrecUsingFromList _ xs =
    let result = maybeParens p xs
        p ys = tokenMatch ((instanceName x) ++ ".fromSeq") ys
                 >>= readsPrec 10
                 >>= \(l,rest) -> return (fromList l,rest)

        -- play games with the typechecker so we don't have to use
        -- extensions for scoped type variables
        ~[(x,_)] = result

    in result

compareUsingToOrdList :: OrdColl c a => c -> c -> Ordering
compareUsingToOrdList as bs = cmp (toOrdList as) (toOrdList bs)
 where
  cmp [] [] = EQ
  cmp [] _  = LT
  cmp _  [] = GT
  cmp (x:xs) (y:ys) =
      case compare x y of
         EQ -> cmp xs ys
         c -> c