Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 739 lines (509 sloc) 23.686 kb
5fb09d3 Max Bolingbroke Initial commit
authored
1 {-# LANGUAGE TupleSections, PatternGuards, ExistentialQuantification, DeriveFunctor, DeriveFoldable, DeriveTraversable, GeneralizedNewtypeDeriving,
2 TypeSynonymInstances, FlexibleInstances, IncoherentInstances, OverlappingInstances, TypeOperators, CPP #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 module Utilities (
5 module UniqueSupply,
6 module Utilities,
7
8 module Control.Arrow,
9 module Control.Monad,
10
11 module Data.Function,
12 module Data.Maybe,
13 module Data.List,
14
15 module Debug.Trace,
16
17 module Text.PrettyPrint.HughesPJClass
18 ) where
19
20 import UniqueSupply
21
22 import Control.Arrow (first, second, (***), (&&&))
23 import Control.Monad hiding (join)
24
25 import Data.Function (on)
26 import Data.Maybe
27 import Data.Monoid
28 import Data.List
29 import qualified Data.IntMap as IM
30 import qualified Data.IntSet as IS
31 import qualified Data.Map as M
32 import qualified Data.Set as S
33 import Data.Tree
34 import qualified Data.Foldable as Foldable
35 import qualified Data.Traversable as Traversable
36
37 import Debug.Trace
38
39 import Text.PrettyPrint.HughesPJClass hiding (render, int, float, char)
40 import qualified Text.PrettyPrint.HughesPJClass as Pretty
41
42 import System.IO
43 import System.IO.Unsafe (unsafePerformIO)
44
45
46 -- | Copointed functors. The defining property is:
47 --
48 -- extract (fmap f a) == f (extract a)
49 class Functor f => Copointed f where
50 extract :: f a -> a
51
52 instance Copointed ((,) a) where
53 extract = snd
54
55
56 class Functor z => Zippable z where
57 -- Naturality:
58 -- fmap (first f) (zip_ as bs) == zip_ (fmap f as) bs
59 -- fmap (second f) (zip_ as bs) == zip_ as (fmap f bs)
60 --
61 -- Information preservation:
62 -- fmap fst (zip_ as bs) == as
63 -- fmap snd (zip_ as bs) == bs
64
65 zip_ :: z a -> z b -> z (a, b)
66 zip_ = zipWith_ (,)
67
68 zipWith_ :: (a -> b -> c) -> z a -> z b -> z c
69 zipWith_ f as bs = fmap (uncurry f) (zip_ as bs)
70
71
72 #ifdef MIN_VERSION_base
73 #if !(MIN_VERSION_base(4, 3, 0))
74
75 -- These instances are in base-4.3
76
77 instance Monad (Either a) where
78 return = Right
79
80 Left l >>= _ = Left l
81 Right x >>= fxmy = fxmy x
82
83 #endif
84 #endif
85
86
87 class Show1 f where
88 showsPrec1 :: Show a => Int -> f a -> ShowS
89
90 instance (Show1 f, Show a) => Show (f a) where
91 showsPrec = showsPrec1
92
93
94 class Eq1 f where
95 eq1 :: Eq a => f a -> f a -> Bool
96
97 instance (Eq1 f, Eq a) => Eq (f a) where
98 (==) = eq1
99
100
101 class Eq1 f => Ord1 f where
102 compare1 :: Ord a => f a -> f a -> Ordering
103
104 instance (Ord1 f, Ord a) => Ord (f a) where
105 compare = compare1
106
107
108 class Pretty1 f where
109 pPrintPrec1 :: Pretty a => PrettyLevel -> Rational -> f a -> Doc
110
111 instance (Pretty1 f, Pretty a) => Pretty (f a) where
112 pPrintPrec = pPrintPrec1
113
114
115 newtype (f :.: g) a = Comp { unComp :: f (g a) }
116
117 infixr 9 :.:
118
119 instance (Copointed f, Copointed g) => Copointed (f :.: g) where
120 extract = extract . extract . unComp
121
122 instance (Show1 f, Show1 g) => Show1 (f :.: g) where
123 showsPrec1 prec (Comp x) = showParen (prec >= appPrec) (showString "Comp" . showsPrec appPrec x)
124
125 instance (Eq1 f, Eq1 g) => Eq1 (f :.: g) where
126 eq1 (Comp x1) (Comp x2) = x1 == x2
127
128 instance (Ord1 f, Ord1 g) => Ord1 (f :.: g) where
129 compare1 (Comp x1) (Comp x2) = x1 `compare` x2
130
131 instance (Pretty1 f, Pretty1 g) => Pretty1 (f :.: g) where
132 pPrintPrec1 level prec (Comp x) = pPrintPrec level prec x
133
134 instance (Functor f, Functor g) => Functor (f :.: g) where
135 fmap f (Comp x) = Comp (fmap (fmap f) x)
136
137 instance (Foldable.Foldable f, Foldable.Foldable g) => Foldable.Foldable (f :.: g) where
138 foldMap f = Foldable.foldMap (Foldable.foldMap f) . unComp
139
140 instance (Traversable.Traversable f, Traversable.Traversable g) => Traversable.Traversable (f :.: g) where
141 traverse f = fmap Comp . Traversable.traverse (Traversable.traverse f) . unComp
142
143
144 newtype Down a = Down { unDown :: a } deriving (Eq)
145
146 instance Ord a => Ord (Down a) where
147 Down a `compare` Down b = b `compare` a
148
149
150 -- | Natural numbers on the cheap (for efficiency reasons)
151 type Nat = Int
152
153
154 newtype Fin = Fin { unFin :: Int } deriving (Eq, Ord, Show, Pretty)
155 type FinSet = IS.IntSet
156 type FinMap = IM.IntMap
157
158
159 data Tag = TG { tagFin :: Fin, tagOccurrences :: Nat } deriving (Eq, Ord, Show)
160
161 instance Pretty Tag where
162 pPrint (TG i occs) = pPrint i <> brackets (pPrint occs)
163
164 mkTag :: Int -> Tag
165 mkTag i = TG (Fin i) 1
166
167 injectTag :: Int -> Tag -> Tag
168 injectTag cls (TG (Fin i) occs) = TG (Fin (cls * i)) occs
169
170 tagInt :: Tag -> Int
171 tagInt = unFin . tagFin
172
173 data Tagged a = Tagged { tag :: !Tag, tagee :: !a }
174 deriving (Functor, Foldable.Foldable, Traversable.Traversable)
175
176 instance Copointed Tagged where
177 extract = tagee
178
179 instance Show1 Tagged where
180 showsPrec1 prec (Tagged tg x) = showParen (prec >= appPrec) (showString "Tagged" . showsPrec appPrec tg . showsPrec appPrec x)
181
182 instance Eq1 Tagged where
183 eq1 (Tagged tg1 x1) (Tagged tg2 x2) = tg1 == tg2 && x1 == x2
184
185 instance Ord1 Tagged where
186 compare1 (Tagged tg1 x1) (Tagged tg2 x2) = (tg1, x1) `compare` (tg2, x2)
187
188 instance Pretty1 Tagged where
189 pPrintPrec1 level prec (Tagged tg x) = braces (pPrint tg) <+> pPrintPrec level prec x
190
191
192 type Size = Int
193
194 data Sized a = Sized { size :: !Size, sizee :: !a }
195 deriving (Functor, Foldable.Foldable, Traversable.Traversable)
196
197 instance Copointed Sized where
198 extract = sizee
199
200 instance Show1 Sized where
201 showsPrec1 prec (Sized sz x) = showParen (prec >= appPrec) (showString "Sized" . showsPrec appPrec sz . showsPrec appPrec x)
202
203 instance Eq1 Sized where
204 eq1 (Sized sz1 x1) (Sized sz2 x2) = sz1 == sz2 && x1 == x2
205
206 instance Ord1 Sized where
207 compare1 (Sized sz1 x1) (Sized sz2 x2) = (sz1, x1) `compare` (sz2, x2)
208
209 instance Pretty1 Sized where
210 pPrintPrec1 level prec (Sized sz x) = bananas (text (show sz)) <> pPrintPrec level prec x
211
212
213 instance Show UniqueSupply where
214 show = show . uniqueFromSupply
215
216
217 instance Pretty Doc where
218 pPrint = id
219
220 instance Pretty Rational where
221 pPrint = rational
222
223 instance Pretty Unique where
224 pPrint = text . show
225
226 instance Pretty IS.IntSet where
227 pPrint xs = braces $ hsep (punctuate comma (map pPrint $ IS.toList xs))
228
229 instance Pretty v => Pretty (IM.IntMap v) where
230 pPrint m = brackets $ fsep (punctuate comma [pPrint k <+> text "|->" <+> pPrint v | (k, v) <- IM.toList m])
231
232 instance Pretty a => Pretty (S.Set a) where
233 pPrint xs = braces $ hsep (punctuate comma (map pPrint $ S.toList xs))
234
235 instance (Pretty k, Pretty v) => Pretty (M.Map k v) where
236 pPrint m = brackets $ fsep (punctuate comma [pPrint k <+> text "|->" <+> pPrint v | (k, v) <- M.toList m])
237
238 instance Pretty a => Pretty (Tree a) where
239 pPrint = text . drawTree . fmap (show . pPrint)
240
241 deleteList :: Ord a => [a] -> S.Set a -> S.Set a
242 deleteList = flip $ foldr S.delete
243
244 deleteListMap :: Ord k => [k] -> M.Map k v -> M.Map k v
245 deleteListMap = flip $ foldr M.delete
246
247 fmapSet :: (Ord a, Ord b) => (a -> b) -> S.Set a -> S.Set b
248 fmapSet f = S.fromList . map f . S.toList
249
250 fmapMap :: (Ord a, Ord b) => (a -> b) -> M.Map a v -> M.Map b v
251 fmapMap f = M.fromList . map (first f) . M.toList
252
253 restrict :: Ord k => M.Map k v -> S.Set k -> M.Map k v
254 -- restrict m s
255 -- | M.size m < S.size s = M.filterWithKey (\k _ -> k `S.member` s) m -- O(m * log s)
256 -- | otherwise = S.fold (\k out -> case M.lookup k m of Nothing -> out; Just v -> M.insert k v out) M.empty s -- O(s * log m)
257 restrict m s = M.fromDistinctAscList $ merge (M.toAscList m) (S.toAscList s)
258 where
259 -- Theoretically O(m + s), so should outperform previous algorithm...
260 merge _ [] = []
261 merge [] _ = []
262 merge ((k_m, v):kvs) (k_s:ks) = case compare k_m k_s of
263 LT -> merge kvs (k_s:ks)
264 EQ -> (k_m, v):merge kvs ks
265 GT -> merge ((k_m, v):kvs) ks
266
267 exclude :: Ord k => M.Map k v -> S.Set k -> M.Map k v
268 --exclude m s = M.filterWithKey (\k _ -> k `S.notMember` s) m -- O(m * log s)
269 exclude m s = M.fromDistinctAscList $ merge (M.toAscList m) (S.toAscList s)
270 where
271 -- Theoretically O(m + s), so should outperform previous algorithm...
272 merge kvs [] = kvs
273 merge [] _ = []
274 merge ((k_m, v):kvs) (k_s:ks) = case compare k_m k_s of
275 LT -> (k_m, v):merge kvs (k_s:ks)
276 EQ -> merge kvs ks
277 GT -> merge ((k_m, v):kvs) ks
278
279 mapMaybeSet :: (Ord a, Ord b) => (a -> Maybe b) -> S.Set a -> S.Set b
280 mapMaybeSet f = S.fromList . mapMaybe f . S.toList
281
282 listToMap :: Ord k => v -> [k] -> M.Map k v
283 listToMap v = M.fromList . map (,v)
284
285 setToMap :: Ord k => v -> S.Set k -> M.Map k v
286 setToMap v = M.fromDistinctAscList . map (,v) . S.toAscList
287
288 -- Essentially XOR on sets. See <http://en.wikipedia.org/wiki/Symmetric_difference>
289 symmetricDifference :: Ord a => S.Set a -> S.Set a -> S.Set a
290 symmetricDifference a b = (a S.\\ b) `S.union` (b S.\\ a)
291
292
293 data Combining a b = LeftOnly a | Both a b | RightOnly b
294
295 {-# INLINE finishCombining #-}
296 finishCombining :: (a -> c) -> (b -> c) -> (a -> b -> c) -> Combining a b -> c
297 finishCombining l r both combining = case combining of
298 LeftOnly x -> l x
299 Both x y -> both x y
300 RightOnly y -> r y
301
302 {-# INLINE combineMaps #-}
303 combineMaps :: Ord k
304 => (a -> c) -> (b -> c) -> (a -> b -> c)
305 -> M.Map k a -> M.Map k b -> M.Map k c
306 combineMaps l r both m1 m2 = M.map (finishCombining l r both) $ M.unionWith (\(LeftOnly x) (RightOnly y) -> Both x y) (M.map LeftOnly m1) (M.map RightOnly m2)
307
308 {-# INLINE combineIntMaps #-}
309 combineIntMaps :: (a -> c) -> (b -> c) -> (a -> b -> c)
310 -> IM.IntMap a -> IM.IntMap b -> IM.IntMap c
311 combineIntMaps l r both im1 im2 = IM.map (finishCombining l r both) $ IM.unionWith (\(LeftOnly x) (RightOnly y) -> Both x y) (IM.map LeftOnly im1) (IM.map RightOnly im2)
312
313
314 {-# NOINLINE parseUniqueSupply #-}
315 parseUniqueSupply :: UniqueSupply
316 parseUniqueSupply = unsafePerformIO $ initUniqueSupply 'a'
317
318 {-# NOINLINE expandUniqueSupply #-}
319 expandUniqueSupply :: UniqueSupply
320 expandUniqueSupply = unsafePerformIO $ initUniqueSupply 'e'
321
322 {-# NOINLINE reduceUniqueSupply #-}
323 reduceUniqueSupply :: UniqueSupply
324 reduceUniqueSupply = unsafePerformIO $ initUniqueSupply 'u'
325
326 {-# NOINLINE tagUniqueSupply #-}
327 tagUniqueSupply :: UniqueSupply
328 tagUniqueSupply = unsafePerformIO $ initUniqueSupply 't'
329
330 {-# NOINLINE prettyUniqueSupply #-}
331 prettyUniqueSupply :: UniqueSupply
332 prettyUniqueSupply = unsafePerformIO $ initUniqueSupply 'p'
333
334 {-# NOINLINE prettifyUniqueSupply #-}
335 prettifyUniqueSupply :: UniqueSupply
336 prettifyUniqueSupply = unsafePerformIO $ initUniqueSupply 'r'
337
338 {-# NOINLINE matchUniqueSupply #-}
339 matchUniqueSupply :: UniqueSupply
340 matchUniqueSupply = unsafePerformIO $ initUniqueSupply 'm'
341
342 stepUniqueSupply :: UniqueSupply -> (UniqueSupply, Unique)
343 stepUniqueSupply = second uniqueFromSupply . splitUniqueSupply
344
345
3d9dc32 Max Bolingbroke Do enough stuff that we can turn an example term into CPS-core
authored
346 type UniqueMap a = M.Map Unique a
347
348 class Uniqueable k where
349 getUnique :: k -> Unique
350
351 instance Uniqueable Unique where
352 getUnique = id
353
354 emptyUniqueMap :: UniqueMap a
355 emptyUniqueMap = M.empty
356
357 insertUniqueMap :: Uniqueable k => k -> a -> UniqueMap a -> UniqueMap a
358 insertUniqueMap k v = M.insert (getUnique k) v
359
360 lookupUniqueMap :: Uniqueable k => k -> UniqueMap a -> Maybe a
361 lookupUniqueMap k = M.lookup (getUnique k)
362
363 findUniqueWithDefault :: Uniqueable k => a -> k -> UniqueMap a -> a
364 findUniqueWithDefault def k = M.findWithDefault def (getUnique k)
365
366
5fb09d3 Max Bolingbroke Initial commit
authored
367 data Train a b = Wagon a (Train a b)
368 | Caboose b
369
370
371 appPrec, opPrec, noPrec :: Num a => a
372 appPrec = 2 -- Argument of a function application
373 opPrec = 1 -- Argument of an infix operator
374 noPrec = 0 -- Others
375
376 normalLevel, haskellLevel :: PrettyLevel
377 normalLevel = PrettyLevel 0
378 haskellLevel = PrettyLevel 1
379
380
381 pPrintPrecApp :: (Pretty a, Pretty b) => PrettyLevel -> Rational -> a -> b -> Doc
382 pPrintPrecApp level prec e1 e2 = prettyParen (prec >= appPrec) $ pPrintPrec level opPrec e1 <+> pPrintPrec level appPrec e2
383
384 pPrintPrecApps :: (Pretty a, Pretty b) => PrettyLevel -> Rational -> a -> [b] -> Doc
385 pPrintPrecApps level prec e1 es2 = prettyParen (not (null es2) && prec >= appPrec) $ pPrintPrec level opPrec e1 <+> hsep (map (pPrintPrec level appPrec) es2)
386
5e4b60d Max Bolingbroke Add pretty-printer and fix the minor bugs that were preventing the examp...
authored
387 pPrintPrecLetRec :: (Pretty a, Pretty b, Pretty c) => PrettyLevel -> Rational -> [(a, b)] -> c -> Doc
388 pPrintPrecLetRec level prec xes e_body
389 | [] <- xes = pPrintPrec level prec e_body
390 | otherwise = prettyParen (prec > noPrec) $ hang (if level == haskellLevel then text "let" else text "letrec") 2 (vcat [pPrintPrec level noPrec x <+> text "=" <+> pPrintPrec level noPrec e | (x, e) <- xes]) $$ text "in" <+> pPrintPrec level noPrec e_body
391
5fb09d3 Max Bolingbroke Initial commit
authored
392
393 angles, coangles, bananas :: Doc -> Doc
394 angles d = Pretty.char '<' <> d <> Pretty.char '>'
395 coangles d = Pretty.char '>' <> d <> Pretty.char '<'
396 bananas d = text "(|" <> d <> text "|)"
397
398
399 pPrintPrec' :: Pretty a => a -> PrettyLevel -> Rational -> Doc
400 pPrintPrec' x level prec = pPrintPrec level prec x
401
402 -- NB: this render function is exported instead of the one from the library
403 render :: Doc -> String
404 render = renderStyle (style { lineLength = 120 })
405
406 pPrintRender :: Pretty a => a -> String
407 pPrintRender = render . pPrint
408
409 panic :: String -> Doc -> a
410 panic s d = error $ "PANIC!\n" ++ s ++ ": " ++ render d
411
412
413 traceRender :: Pretty a => a -> b -> b
414 traceRender x = trace (pPrintRender x)
415
416 traceRenderM :: (Pretty a, Monad m) => a -> m ()
417 traceRenderM x = traceRender x (return ())
418
419 assertRender :: Pretty a => a -> Bool -> b -> b
420 --assertRender _ _ x | not aSSERTIONS = x
421 assertRender _ True x = x
422 assertRender a False _ = error (render $ text "ASSERT FAILED!" $$ pPrint a)
423
424 assertRenderM :: (Pretty a, Monad m) => a -> Bool -> m ()
425 assertRenderM a b = assertRender a b (return ())
426
427
428 removeOnes :: [a] -> [[a]]
429 removeOnes [] = []
430 removeOnes (x:xs) = xs : map (x:) (removeOnes xs)
431
432 listContexts :: [a] -> [([a], a, [a])]
433 listContexts xs = zipWith (\is (t:ts) -> (is, t, ts)) (inits xs) (init (tails xs))
434
435 bagContexts :: [a] -> [(a, [a])]
436 bagContexts xs = [(x, is ++ ts) | (is, x, ts) <- listContexts xs]
437
438 seperate :: Eq a => a -> [a] -> [[a]]
439 seperate c = go []
440 where
441 go sofar [] = [reverse sofar]
442 go sofar (x:xs)
443 | x == c = reverse sofar : go [] xs
444 | otherwise = go (x:sofar) xs
445
0432fc8 Max Bolingbroke CPS core linter, explicit support for existential datacons in GHC core (...
authored
446 allDistinct :: Ord a => [a] -> Bool
447 allDistinct xs = S.size (S.fromList xs) == length xs
448
5fb09d3 Max Bolingbroke Initial commit
authored
449
450 accumL :: (acc -> (acc, a)) -> acc -> Int -> (acc, [a])
451 accumL f = go
452 where
453 go acc n | n <= 0 = (acc, [])
454 | (acc, x) <- f acc = second (x:) (go acc (n - 1))
455
456
457 instance (Pretty a, Pretty b, Pretty c, Pretty d,
458 Pretty e, Pretty f, Pretty g, Pretty h,
459 Pretty i) => Pretty (a, b, c, d, e, f, g, h, i) where
460 pPrint (a, b, c, d, e, f, g, h, i)
461 = pPrintTuple [pPrint a, pPrint b, pPrint c, pPrint d,
462 pPrint e, pPrint f, pPrint g, pPrint h,
463 pPrint i]
464
465 instance (Pretty a, Pretty b, Pretty c, Pretty d,
466 Pretty e, Pretty f, Pretty g, Pretty h,
467 Pretty i, Pretty j) => Pretty (a, b, c, d, e, f, g, h, i, j) where
468 pPrint (a, b, c, d, e, f, g, h, i, j)
469 = pPrintTuple [pPrint a, pPrint b, pPrint c, pPrint d,
470 pPrint e, pPrint f, pPrint g, pPrint h,
471 pPrint i, pPrint j]
472
473 instance (Pretty a, Pretty b, Pretty c, Pretty d,
474 Pretty e, Pretty f, Pretty g, Pretty h,
475 Pretty i, Pretty j, Pretty k) => Pretty (a, b, c, d, e, f, g, h, i, j, k) where
476 pPrint (a, b, c, d, e, f, g, h, i, j, k)
477 = pPrintTuple [pPrint a, pPrint b, pPrint c, pPrint d,
478 pPrint e, pPrint f, pPrint g, pPrint h,
479 pPrint i, pPrint j, pPrint k]
480
481 instance (Pretty a, Pretty b, Pretty c, Pretty d,
482 Pretty e, Pretty f, Pretty g, Pretty h,
483 Pretty i, Pretty j, Pretty k, Pretty l) => Pretty (a, b, c, d, e, f, g, h, i, j, k, l) where
484 pPrint (a, b, c, d, e, f, g, h, i, j, k, l)
485 = pPrintTuple [pPrint a, pPrint b, pPrint c, pPrint d,
486 pPrint e, pPrint f, pPrint g, pPrint h,
487 pPrint i, pPrint j, pPrint k, pPrint l]
488
489 instance (Pretty a, Pretty b, Pretty c, Pretty d,
490 Pretty e, Pretty f, Pretty g, Pretty h,
491 Pretty i, Pretty j, Pretty k, Pretty l,
492 Pretty m, Pretty n, Pretty o) => Pretty (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where
493 pPrint (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)
494 = pPrintTuple [pPrint a, pPrint b, pPrint c, pPrint d,
495 pPrint e, pPrint f, pPrint g, pPrint h,
496 pPrint i, pPrint j, pPrint k, pPrint l,
497 pPrint m, pPrint n, pPrint o]
498
499 pPrintTuple :: [Doc] -> Doc
500 pPrintTuple ds = parens $ fsep $ punctuate comma ds
501
502
503 data SomePretty = forall a. Pretty a => SomePretty a
504
505 instance Pretty SomePretty where
506 pPrintPrec level prec (SomePretty x) = pPrintPrec level prec x
507
508
509 newtype PrettyFunction = PrettyFunction (PrettyLevel -> Rational -> Doc)
510
511 instance Pretty PrettyFunction where
512 pPrintPrec level prec (PrettyFunction f) = f level prec
513
514 asPrettyFunction :: Pretty a => a -> PrettyFunction
515 asPrettyFunction = PrettyFunction . pPrintPrec'
516
517
518 fst3 :: (a, b, c) -> a
519 fst3 (a, _, _) = a
520
521 snd3 :: (a, b, c) -> b
522 snd3 (_, b, _) = b
523
524 thd3 :: (a, b, c) -> c
525 thd3 (_, _, c) = c
526
527 first3 :: (a -> d) -> (a, b, c) -> (d, b, c)
528 first3 f (a, b, c) = (f a, b, c)
529
530 second3 :: (b -> d) -> (a, b, c) -> (a, d, c)
531 second3 f (a, b, c) = (a, f b, c)
532
533 third3 :: (c -> d) -> (a, b, c) -> (a, b, d)
534 third3 f (a, b, c) = (a, b, f c)
535
536 second4 :: (b -> e) -> (a, b, c, d) -> (a, e, c, d)
537 second4 f (a, b, c, d) = (a, f b, c, d)
538
539 third4 :: (c -> e) -> (a, b, c, d) -> (a, b, e, d)
540 third4 f (a, b, c, d) = (a, b, f c, d)
541
542 fourth4 :: (d -> e) -> (a, b, c, d) -> (a, b, c, e)
543 fourth4 f (a, b, c, d) = (a, b, c, f d)
544
545 secondM :: Monad m => (b -> m c) -> (a, b) -> m (a, c)
546 secondM f (a, b) = liftM (a,) $ f b
547
548
549 uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
550 uncurry3 f (a, b, c) = f a b c
551
552
553 splitBy :: [b] -> [a] -> ([a], [a])
554 splitBy [] xs = ([], xs)
555 splitBy (_:ys) (x:xs) = first (x:) $ splitBy ys xs
556
557 splitByReverse :: [b] -> [a] -> ([a], [a])
558 splitByReverse ys xs = case splitBy ys (reverse xs) of (xs1, xs2) -> (reverse xs2, reverse xs1)
559
560 splitManyBy :: [[b]] -> [a] -> [[a]]
561 splitManyBy [] xs = [xs]
562 splitManyBy (ys:yss) xs = case splitBy ys xs of (xs1, xs2) -> xs1 : splitManyBy yss xs2
563
564 dropBy :: [b] -> [a] -> [a]
565 dropBy bs = snd . splitBy bs
566
567
568 dropLastWhile :: (a -> Bool) -> [a] -> [a]
569 dropLastWhile p = reverse . dropWhile p . reverse
570
571
572 orElse :: Maybe a -> a -> a
573 orElse = flip fromMaybe
574
575
7e49aae Max Bolingbroke Better pretty printer, example with ADT and unboxed tuples, changes to C...
authored
576 nTimes :: Int -> (a -> a) -> a -> a
577 nTimes n f = foldr (.) id (replicate n f)
578
579
5fb09d3 Max Bolingbroke Initial commit
authored
580 takeFirst :: (a -> Bool) -> [a] -> (Maybe a, [a])
581 takeFirst p = takeFirstJust (\x -> guard (p x) >> return x)
582
583 takeFirstJust :: (a -> Maybe b) -> [a] -> (Maybe b, [a])
584 takeFirstJust p = go
585 where
586 go [] = (Nothing, [])
587 go (x:xs)
588 | Just y <- p x = (Just y, xs)
589 | otherwise = second (x:) $ go xs
590
591 extractJusts :: (a -> Maybe b) -> [a] -> ([b], [a])
592 extractJusts p = foldr step ([], [])
593 where step x rest | Just y <- p x = first (y:) rest
594 | otherwise = second (x:) rest
595
596 expectJust :: String -> Maybe a -> a
597 expectJust _ (Just x) = x
598 expectJust s Nothing = error $ "expectJust: " ++ s
599
600 safeFromLeft :: Either a b -> Maybe a
601 safeFromLeft (Left x) = Just x
602 safeFromLeft _ = Nothing
603
604 fmapEither :: (a -> b) -> (c -> d) -> Either a c -> Either b d
605 fmapEither f g = either (Left . f) (Right . g)
606
607 safeHead :: [a] -> Maybe a
608 safeHead [] = Nothing
609 safeHead (x:_) = Just x
610
611 expectHead :: String -> [a] -> a
612 expectHead s = expectJust s . safeHead
613
614 uncons :: [a] -> Maybe (a, [a])
615 uncons [] = Nothing
616 uncons (x:xs) = Just (x, xs)
617
dec1fa6 Max Bolingbroke New, untyped, CPS core
authored
618 at :: [a] -> Int -> Maybe a
619 at _ n | n < 0 = error "at: negative argument"
620 at [] _ = Nothing
621 at (x:_) 0 = Just x
622 at (_:xs) n = at xs (n - 1)
623
5fb09d3 Max Bolingbroke Initial commit
authored
624 listSelectors :: [[a] -> a]
625 listSelectors = iterate (\f xs -> f (tail xs)) head
626
627 fixpoint :: Eq a => (a -> a) -> a -> a
628 fixpoint f x
629 | x' == x = x
630 | otherwise = fixpoint f x'
631 where x' = f x
632
633 zipWithEqualM :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c]
634 zipWithEqualM _ [] [] = return []
635 zipWithEqualM f (x:xs) (y:ys) = liftM2 (:) (f x y) (zipWithEqualM f xs ys)
636 zipWithEqualM _ _ _ = fail "zipWithEqualM"
637
638 zipWithEqualM_ :: Monad m => (a -> b -> m ()) -> [a] -> [b] -> m ()
639 zipWithEqualM_ _ [] [] = return ()
640 zipWithEqualM_ f (x:xs) (y:ys) = f x y >> zipWithEqualM_ f xs ys
641 zipWithEqualM_ _ _ _ = fail "zipWithEqualM_"
642
643 zipEqual :: [a] -> [b] -> Maybe [(a, b)]
644 zipEqual = zipWithEqual (,)
645
646 zipWithEqual :: (a -> b -> c) -> [a] -> [b] -> Maybe [c]
647 zipWithEqual _ [] [] = Just []
648 zipWithEqual f (x:xs) (y:ys) = fmap (f x y :) $ zipWithEqual f xs ys
649 zipWithEqual _ _ _ = fail "zipWithEqual"
650
651 implies :: Bool -> Bool -> Bool
652 implies cond consq = not cond || consq
653
654
655 mapAccumM :: (Traversable.Traversable t, Monoid m) => (a -> (m, b)) -> t a -> (m, t b)
656 mapAccumM f ta = Traversable.mapAccumL (\m a -> case f a of (m', b) -> (m `mappend` m', b)) mempty ta
657
658
659 newtype Identity a = I { unI :: a }
660 deriving (Functor, Foldable.Foldable, Traversable.Traversable)
661
662 instance Show1 Identity where
663 showsPrec1 prec (I x) = showParen (prec >= appPrec) (showString "Identity" . showsPrec appPrec x)
664
665 instance Eq1 Identity where
666 eq1 (I x1) (I x2) = x1 == x2
667
668 instance Ord1 Identity where
669 compare1 (I x1) (I x2) = x1 `compare` x2
670
671 instance Pretty1 Identity where
672 pPrintPrec1 level prec (I x) = pPrintPrec level prec x
673
674 instance Copointed Identity where
675 extract = unI
676
677 instance Monad Identity where
678 return = I
679 mx >>= fxmy = fxmy (unI mx)
680
681
682 sumMap :: (Foldable.Foldable f, Num b) => (a -> b) -> f a -> b
683 sumMap f = Foldable.foldr (\x n -> f x + n) 0
684
685
686 class (Functor t, Foldable.Foldable t) => Accumulatable t where
687 mapAccumT :: (acc -> x -> (acc, y)) -> acc -> t x -> (acc, t y)
688 mapAccumTM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
689
690 mapAccumT f acc x = unI (mapAccumTM (\acc' x' -> I (f acc' x')) acc x)
691
692 fmapDefault :: (Accumulatable t) => (a -> b) -> t a -> t b
693 fmapDefault f = snd . mapAccumT (\() x -> ((), f x)) ()
694
695 foldMapDefault :: (Accumulatable t, Monoid m) => (a -> m) -> t a -> m
696 foldMapDefault f = fst . mapAccumT (\acc x -> (f x `mappend` acc, ())) mempty
697
698 instance Accumulatable [] where
699 mapAccumT = mapAccumL
700 mapAccumTM = mapAccumLM
701
702 mapAccumLM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
703 mapAccumLM f = go []
704 where
705 go ys acc [] = return (acc, reverse ys)
706 go ys acc (x:xs) = do
707 (acc, y) <- f acc x
708 go (y:ys) acc xs
709
710 concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
711 concatMapM f = go
712 where
713 go [] = return []
714 go (x:xs) = do
715 ys <- f x
716 liftM (ys ++) $ go xs
717
718 instance Ord k => Accumulatable (M.Map k) where
719 mapAccumTM f acc = liftM (second M.fromList) . mapAccumTM (\acc (k, x) -> liftM (second (k,)) (f acc x)) acc . M.toList
720
721
722 type Bytes = Integer
723
724 fileSize :: FilePath -> IO Bytes
725 fileSize file = withFile file ReadMode hFileSize
27593d8 Max Bolingbroke A rather complete translator from GHC core to untyped CPS core
authored
726
727
728 data ListPoint a = ListPoint [a] a [a]
729
730 instance Functor ListPoint where
731 fmap f (ListPoint xs y zs) = ListPoint (map f xs) (f y) (map f zs)
732
733 locateListPoint :: (a -> Bool) -> [a] -> ListPoint a
734 locateListPoint p = go []
3d9dc32 Max Bolingbroke Do enough stuff that we can turn an example term into CPS-core
authored
735 where go _ [] = error "locateListPoint: no match"
27593d8 Max Bolingbroke A rather complete translator from GHC core to untyped CPS core
authored
736 go left (here:right)
737 | p here = ListPoint (reverse left) here right
738 | otherwise = go (here:left) right
Something went wrong with that request. Please try again.