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)