1module Data.List.Match.Private where
2
3import Data.Maybe    (fromJust, isNothing, )
4import Data.Maybe.HT (toMaybe, )
5import Data.Tuple.HT (mapFst, forcePair, )
6import Data.Bool.HT  (if', )
7
8import qualified Data.List as List
9
10import Control.Functor.HT (void, )
11
12import Prelude hiding (take, drop, splitAt, replicate, )
13
14
15{- | Make a list as long as another one -}
16{-
17@flip (zipWith const)@ is not as lazy,
18e.g. would be @take [] undefined = undefined@,
19but it should be @take [] undefined = []@.
20-}
21take :: [b] -> [a] -> [a]
22take = zipWith (flip const)
23
24{- | Drop as many elements as the first list is long -}
25drop :: [b] -> [a] -> [a]
26drop xs ys0 =
27   foldl (\ys _ -> laxTail ys) ys0 xs
28
29{-
30Shares suffix with input,
31that is it is more efficient than the implementations below.
32-}
33dropRec :: [b] -> [a] -> [a]
34dropRec (_:xs) (_:ys) = dropRec xs ys
35dropRec _ ys = ys
36
37drop0 :: [b] -> [a] -> [a]
38drop0 xs ys =
39   -- catMaybes (
40   map fromJust (dropWhile isNothing
41      (zipWith (toMaybe . null) (iterate laxTail xs) ys))
42
43drop1 :: [b] -> [a] -> [a]
44drop1 xs ys =
45   map snd (dropWhile (not . null . fst) (zip (iterate laxTail xs) ys))
46
47drop2 :: [b] -> [a] -> [a]
48drop2 xs ys =
49   snd $ head $
50   dropWhile (not . null . fst) $
51   zip (iterate laxTail xs) (iterate laxTail ys)
52
53
54{- |
55@laxTail [] = []@
56-}
57laxTail :: [a] -> [a]
58laxTail xt = case xt of [] -> []; _:xs -> xs
59
60laxTail0 :: [a] -> [a]
61laxTail0 = List.drop 1
62
63splitAt :: [b] -> [a] -> ([a],[a])
64splitAt nt xt =
65   forcePair $
66   case (nt,xt) of
67      (_:ns, x:xs) -> mapFst (x:) $ splitAt ns xs
68      (_, xs) -> ([],xs)
69
70
71takeRev :: [b] -> [a] -> [a]
72takeRev ys xs = drop (drop ys xs) xs
73
74dropRev :: [b] -> [a] -> [a]
75dropRev ys xs = take (drop ys xs) xs
76
77{- |
78Check whether two lists with different element types have equal length.
79It is equivalent to @length xs == length ys@ but more efficient.
80-}
81equalLength :: [a] -> [b] -> Bool
82equalLength xs ys =
83   void xs == void ys
84
85{- |
86Compare the length of two lists over different types.
87It is equivalent to @(compare (length xs) (length ys))@
88but more efficient.
89-}
90compareLength :: [a] -> [b] -> Ordering
91compareLength xs ys =
92   compare (void xs) (void ys)
93
94{- | this one uses explicit recursion -}
95compareLength0 :: [a] -> [b] -> Ordering
96compareLength0 =
97   let recourse (_:xs) (_:ys) = recourse xs ys
98       recourse []     []     = EQ
99       recourse (_:_)  []     = GT
100       recourse []     (_:_)  = LT
101   in  recourse
102
103{- | strict comparison -}
104compareLength1 :: [a] -> [b] -> Ordering
105compareLength1 xs ys =
106   compare (length xs) (length ys)
107
108{- |
109@lessOrEqualLength x y@ is almost the same as @compareLength x y <= EQ@,
110but @lessOrEqualLength [] undefined  =  True@,
111whereas @compareLength [] undefined <= EQ  =  undefined@.
112-}
113lessOrEqualLength :: [a] -> [b] -> Bool
114lessOrEqualLength [] _ = True
115lessOrEqualLength _ [] = False
116lessOrEqualLength (_:xs) (_:ys) = lessOrEqualLength xs ys
117
118{- |
119Returns the shorter one of two lists.
120It works also for infinite lists as much as possible.
121E.g. @shorterList (shorterList (repeat 1) (repeat 2)) [1,2,3]@
122can be computed.
123The trick is, that the skeleton of the resulting list
124is constructed using 'zipWith' without touching the elements.
125The contents is then computed (only) if requested.
126-}
127shorterList :: [a] -> [a] -> [a]
128shorterList xs ys =
129   let useX = lessOrEqualLength xs ys
130   in  zipWith (if' useX) xs ys
131
132{- |
133This is lazier than 'shorterList' in a different aspect:
134It returns a common prefix
135even if it is undefined, which list is the shorter one.
136However, it requires a proper 'Eq' instance
137and if elements are undefined, it may fail even earlier.
138-}
139shorterListEq :: (Eq a) => [a] -> [a] -> [a]
140shorterListEq xs ys =
141   let useX = lessOrEqualLength xs ys
142   in  zipWith (\x y -> if' (x==y || useX) x y) xs ys
143
144
145{- |
146Specialisation of 'Data.Functor.$>'.
147-}
148replicate :: [a] -> b -> [b]
149replicate xs y =
150   take xs (repeat y)
151