module Data.List.Match.Private where

import Data.Maybe    (fromJust, isNothing, )
import Data.Maybe.HT (toMaybe, )
import Data.Tuple.HT (mapFst, forcePair, )
import Data.Bool.HT  (if', )

import qualified Data.List as List

import Control.Functor.HT (void, )

import Prelude hiding (take, drop, splitAt, replicate, )


-- $setup
-- >>> import qualified Data.List.Match.Private as Match
-- >>> import qualified Data.List as List
-- >>>
-- >>> import qualified Test.QuickCheck as QC
-- >>>
-- >>> newtype List = List [Integer] deriving (Show)
-- >>> instance QC.Arbitrary List where
-- >>>    arbitrary = fmap List QC.arbitrary
-- >>>    shrink (List xs) = map List $ QC.shrink xs
-- >>>
-- >>> newtype Shape = Shape [Ordering] deriving (Show)
-- >>> instance QC.Arbitrary Shape where
-- >>>    arbitrary = fmap Shape QC.arbitrary
-- >>>    shrink (Shape xs) = map Shape $ QC.shrink xs


{- | Make a list as long as another one

prop> \(Shape xs) (List ys) -> Match.take xs ys == List.take (length xs) ys
-}
{-
@flip (zipWith const)@ is not as lazy,
e.g. would be @take [] undefined = undefined@,
but it should be @take [] undefined = []@.
-}
take :: [b] -> [a] -> [a]
take :: [b] -> [a] -> [a]
take = (b -> a -> a) -> [b] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((a -> b -> a) -> b -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> b -> a
forall a b. a -> b -> a
const)

{- | Drop as many elements as the first list is long

prop> \(Shape xs) (List ys) -> Match.drop xs ys == List.drop (length xs) ys
prop> \(Shape xs) (List ys) -> Match.take xs ys ++ Match.drop xs ys == ys
-}
drop :: [b] -> [a] -> [a]
drop :: [b] -> [a] -> [a]
drop [b]
xs [a]
ys0 =
   ([a] -> b -> [a]) -> [a] -> [b] -> [a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\[a]
ys b
_ -> [a] -> [a]
forall a. [a] -> [a]
laxTail [a]
ys) [a]
ys0 [b]
xs


-- | prop> \(Shape xs) (List ys) -> Match.drop xs ys == dropRec xs ys
{-
Shares suffix with input,
that is it is more efficient than the implementations below.
-}
dropRec :: [b] -> [a] -> [a]
dropRec :: [b] -> [a] -> [a]
dropRec (b
_:[b]
xs) (a
_:[a]
ys) = [b] -> [a] -> [a]
forall b a. [b] -> [a] -> [a]
dropRec [b]
xs [a]
ys
dropRec [b]
_ [a]
ys = [a]
ys

-- | prop> \(Shape xs) (List ys) -> Match.drop xs ys == drop0 xs ys
drop0 :: [b] -> [a] -> [a]
drop0 :: [b] -> [a] -> [a]
drop0 [b]
xs [a]
ys =
   -- catMaybes (
   (Maybe a -> a) -> [Maybe a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust ((Maybe a -> Bool) -> [Maybe a] -> [Maybe a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing
      (([b] -> a -> Maybe a) -> [[b]] -> [a] -> [Maybe a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Bool -> a -> Maybe a
forall a. Bool -> a -> Maybe a
toMaybe (Bool -> a -> Maybe a) -> ([b] -> Bool) -> [b] -> a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [b] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (([b] -> [b]) -> [b] -> [[b]]
forall a. (a -> a) -> a -> [a]
iterate [b] -> [b]
forall a. [a] -> [a]
laxTail [b]
xs) [a]
ys))

-- | prop> \(Shape xs) (List ys) -> Match.drop xs ys == drop1 xs ys
drop1 :: [b] -> [a] -> [a]
drop1 :: [b] -> [a] -> [a]
drop1 [b]
xs [a]
ys =
   (([b], a) -> a) -> [([b], a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map ([b], a) -> a
forall a b. (a, b) -> b
snd ((([b], a) -> Bool) -> [([b], a)] -> [([b], a)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (([b], a) -> Bool) -> ([b], a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [b] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([b] -> Bool) -> (([b], a) -> [b]) -> ([b], a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([b], a) -> [b]
forall a b. (a, b) -> a
fst) ([[b]] -> [a] -> [([b], a)]
forall a b. [a] -> [b] -> [(a, b)]
zip (([b] -> [b]) -> [b] -> [[b]]
forall a. (a -> a) -> a -> [a]
iterate [b] -> [b]
forall a. [a] -> [a]
laxTail [b]
xs) [a]
ys))

-- | prop> \(Shape xs) (List ys) -> Match.drop xs ys == drop2 xs ys
drop2 :: [b] -> [a] -> [a]
drop2 :: [b] -> [a] -> [a]
drop2 [b]
xs [a]
ys =
   ([b], [a]) -> [a]
forall a b. (a, b) -> b
snd (([b], [a]) -> [a]) -> ([b], [a]) -> [a]
forall a b. (a -> b) -> a -> b
$ [([b], [a])] -> ([b], [a])
forall a. [a] -> a
head ([([b], [a])] -> ([b], [a])) -> [([b], [a])] -> ([b], [a])
forall a b. (a -> b) -> a -> b
$
   (([b], [a]) -> Bool) -> [([b], [a])] -> [([b], [a])]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (([b], [a]) -> Bool) -> ([b], [a]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [b] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([b] -> Bool) -> (([b], [a]) -> [b]) -> ([b], [a]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([b], [a]) -> [b]
forall a b. (a, b) -> a
fst) ([([b], [a])] -> [([b], [a])]) -> [([b], [a])] -> [([b], [a])]
forall a b. (a -> b) -> a -> b
$
   [[b]] -> [[a]] -> [([b], [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip (([b] -> [b]) -> [b] -> [[b]]
forall a. (a -> a) -> a -> [a]
iterate [b] -> [b]
forall a. [a] -> [a]
laxTail [b]
xs) (([a] -> [a]) -> [a] -> [[a]]
forall a. (a -> a) -> a -> [a]
iterate [a] -> [a]
forall a. [a] -> [a]
laxTail [a]
ys)


{- |
>>> laxTail ""
""
>>> laxTail "a"
""
>>> laxTail "ab"
"b"
-}
laxTail :: [a] -> [a]
laxTail :: [a] -> [a]
laxTail [a]
xt = case [a]
xt of [] -> []; a
_:[a]
xs -> [a]
xs

-- | prop> \(List xs) -> Match.laxTail xs == Match.laxTail0 xs
laxTail0 :: [a] -> [a]
laxTail0 :: [a] -> [a]
laxTail0 = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
List.drop Int
1

{- |
prop> \(Shape xs) (List ys) -> Match.splitAt xs ys == (Match.take xs ys, Match.drop xs ys)
prop> \(Shape xs) (List ys) -> Match.splitAt xs ys == List.splitAt (length xs) ys
-}
splitAt :: [b] -> [a] -> ([a],[a])
splitAt :: [b] -> [a] -> ([a], [a])
splitAt [b]
nt [a]
xt =
   ([a], [a]) -> ([a], [a])
forall a b. (a, b) -> (a, b)
forcePair (([a], [a]) -> ([a], [a])) -> ([a], [a]) -> ([a], [a])
forall a b. (a -> b) -> a -> b
$
   case ([b]
nt,[a]
xt) of
      (b
_:[b]
ns, a
x:[a]
xs) -> ([a] -> [a]) -> ([a], [a]) -> ([a], [a])
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) (([a], [a]) -> ([a], [a])) -> ([a], [a]) -> ([a], [a])
forall a b. (a -> b) -> a -> b
$ [b] -> [a] -> ([a], [a])
forall b a. [b] -> [a] -> ([a], [a])
splitAt [b]
ns [a]
xs
      ([b]
_, [a]
xs) -> ([],[a]
xs)


-- | prop> \(Shape xs) (List ys) -> Match.takeRev xs ys == reverse (Match.take xs (reverse ys))
takeRev :: [b] -> [a] -> [a]
takeRev :: [b] -> [a] -> [a]
takeRev [b]
ys [a]
xs = [a] -> [a] -> [a]
forall b a. [b] -> [a] -> [a]
drop ([b] -> [a] -> [a]
forall b a. [b] -> [a] -> [a]
drop [b]
ys [a]
xs) [a]
xs

-- | prop> \(Shape xs) (List ys) -> Match.dropRev xs ys == reverse (Match.drop xs (reverse ys))
dropRev :: [b] -> [a] -> [a]
dropRev :: [b] -> [a] -> [a]
dropRev [b]
ys [a]
xs = [a] -> [a] -> [a]
forall b a. [b] -> [a] -> [a]
take ([b] -> [a] -> [a]
forall b a. [b] -> [a] -> [a]
drop [b]
ys [a]
xs) [a]
xs

{- |
Check whether two lists with different element types have equal length.
It holds

prop> \(Shape xs) (List ys) -> equalLength xs ys == (length xs == length ys)

but 'equalLength' is more efficient.
-}
equalLength :: [a] -> [b] -> Bool
equalLength :: [a] -> [b] -> Bool
equalLength [a]
xs [b]
ys =
   [a] -> [()]
forall (f :: * -> *) a. Functor f => f a -> f ()
void [a]
xs [()] -> [()] -> Bool
forall a. Eq a => a -> a -> Bool
== [b] -> [()]
forall (f :: * -> *) a. Functor f => f a -> f ()
void [b]
ys

{- |
Compare the length of two lists over different types.
It holds

prop> \(Shape xs) (List ys) -> compareLength xs ys == compare (length xs) (length ys)

but 'compareLength' is more efficient.
-}
compareLength :: [a] -> [b] -> Ordering
compareLength :: [a] -> [b] -> Ordering
compareLength [a]
xs [b]
ys =
   [()] -> [()] -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([a] -> [()]
forall (f :: * -> *) a. Functor f => f a -> f ()
void [a]
xs) ([b] -> [()]
forall (f :: * -> *) a. Functor f => f a -> f ()
void [b]
ys)

{- | this one uses explicit recursion

prop> \(Shape xs) (List ys) -> Match.compareLength xs ys == Match.compareLength0 xs ys
-}
compareLength0 :: [a] -> [b] -> Ordering
compareLength0 :: [a] -> [b] -> Ordering
compareLength0 =
   let recourse :: [a] -> [a] -> Ordering
recourse (a
_:[a]
xs) (a
_:[a]
ys) = [a] -> [a] -> Ordering
recourse [a]
xs [a]
ys
       recourse []     []     = Ordering
EQ
       recourse (a
_:[a]
_)  []     = Ordering
GT
       recourse []     (a
_:[a]
_)  = Ordering
LT
   in  [a] -> [b] -> Ordering
forall a a. [a] -> [a] -> Ordering
recourse

{- | strict comparison

prop> \(Shape xs) (List ys) -> Match.compareLength xs ys == Match.compareLength1 xs ys
-}
compareLength1 :: [a] -> [b] -> Ordering
compareLength1 :: [a] -> [b] -> Ordering
compareLength1 [a]
xs [b]
ys =
   Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) ([b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
ys)

{- |
@lessOrEqualLength x y@ is almost the same as @compareLength x y <= EQ@,
but

>>> lessOrEqualLength "" undefined
True

whereas @compareLength [] undefined <= EQ  =  undefined@.
-}
lessOrEqualLength :: [a] -> [b] -> Bool
lessOrEqualLength :: [a] -> [b] -> Bool
lessOrEqualLength [] [b]
_ = Bool
True
lessOrEqualLength [a]
_ [] = Bool
False
lessOrEqualLength (a
_:[a]
xs) (b
_:[b]
ys) = [a] -> [b] -> Bool
forall a b. [a] -> [b] -> Bool
lessOrEqualLength [a]
xs [b]
ys

{- |
Returns the shorter one of two lists.
It works also for infinite lists as much as possible.
E.g.

>>> shorterList (shorterList (repeat 'a') (repeat 'b')) "abc"
"abc"

The trick is, that the skeleton of the resulting list
is constructed using 'zipWith' without touching the elements.
The contents is then computed (only) if requested.
-}
shorterList :: [a] -> [a] -> [a]
shorterList :: [a] -> [a] -> [a]
shorterList [a]
xs [a]
ys =
   let useX :: Bool
useX = [a] -> [a] -> Bool
forall a b. [a] -> [b] -> Bool
lessOrEqualLength [a]
xs [a]
ys
   in  (a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Bool -> a -> a -> a
forall a. Bool -> a -> a -> a
if' Bool
useX) [a]
xs [a]
ys

{- |
This is lazier than 'shorterList' in a different aspect:
It returns a common prefix
even if it is undefined, which list is the shorter one.
However, it requires a proper 'Eq' instance
and if elements are undefined, it may fail even earlier.

>>> List.take 3 $ shorterListEq ("abc" ++ repeat 'a') ("abcdef" ++ repeat 'b')
"abc"
-}
shorterListEq :: (Eq a) => [a] -> [a] -> [a]
shorterListEq :: [a] -> [a] -> [a]
shorterListEq [a]
xs [a]
ys =
   let useX :: Bool
useX = [a] -> [a] -> Bool
forall a b. [a] -> [b] -> Bool
lessOrEqualLength [a]
xs [a]
ys
   in  (a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\a
x a
y -> Bool -> a -> a -> a
forall a. Bool -> a -> a -> a
if' (a
xa -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
y Bool -> Bool -> Bool
|| Bool
useX) a
x a
y) [a]
xs [a]
ys


{- |
Specialisation of 'Data.Functor.$>'.
-}
replicate :: [a] -> b -> [b]
replicate :: [a] -> b -> [b]
replicate [a]
xs b
y =
   [a] -> [b] -> [b]
forall b a. [b] -> [a] -> [a]
take [a]
xs (b -> [b]
forall a. a -> [a]
repeat b
y)