never executed always true always false
1 {-# OPTIONS_GHC -fno-warn-orphans #-}
2 {-# LANGUAGE TypeFamilies #-}
3 {-# LANGUAGE PolyKinds #-}
4 {-# LANGUAGE Rank2Types #-}
5 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
6 {-# LANGUAGE UndecidableInstances #-}
7
8
9 module Conjure.Prelude
10 ( module X
11 , stringToDoc
12 , textToDoc
13 , padRight, padLeft, padCenter
14 , pairWithContents
15 , withRest, withAfter, withBefore
16 , T.Text, stringToText, textToString
17 , sameLength
18 , concatMapM, concatForM
19 , timedIO, timedPutStrLn
20 , tick
21 , isLeft, isRight
22 , tracing
23 , allCombinations
24 , sortOn, sortNub
25 , maybeRead
26 , padShowInt
27 , decodeFromFile
28 , RandomM(..)
29 , fst3, snd3, thd3
30 , fst4, snd4, thd4, fourth4
31 , (|>)
32 , allNats
33 , jsonOptions
34 , Proxy(..)
35 , MonadFailDoc(..), na
36 , MonadFail (..)
37 , allContexts, ascendants
38 , dropExtension, dropDirs
39 , splitOn1
40 , MonadLog(..), LogLevel(..), runLoggerPipeIO, ignoreLogs
41 , logInfo, logWarn, logDebug, logDebugVerbose
42 , histogram
43 , ExceptT(..)
44 , sh
45 , scope
46 , getAllDirs, getAllFiles, getAllFilesWithSuffix
47 , removeFileIfExists, readFileIfExists, removeDirectoryIfExists
48 , setRandomSeed, randomRIO
49 , nchoosek
50 , JSONValue
51 , isTopMostZ
52 , getDirectoryContents
53 , RunStateAsWriter, runStateAsWriterT, sawTell
54 , stripPostfix
55 , Doc
56 ) where
57
58 import GHC.Err as X ( error )
59 import GHC.Stack as X ( HasCallStack )
60
61 -- basic data types
62 import Data.Bool as X ( Bool(..), (||), (&&), not, otherwise )
63 import Data.Int as X ( Int )
64 import GHC.Integer as X ( Integer )
65 import GHC.Float as X ( sqrt, (**) )
66 import GHC.Exts as X ( Double )
67 import GHC.Real as X ( Fractional(..), Integral(..), fromIntegral, (^), Real(..), round, odd, even )
68 import GHC.Enum as X ( Enum(..), Bounded(..) )
69 import Data.Char as X ( Char, toLower, isSpace )
70 import Data.String as X ( String, IsString(..) )
71
72 -- basic type classes
73 import Data.Eq as X ( Eq(..) )
74 import Data.Ord as X ( Ord(..), Ordering(..), comparing )
75 import Text.Show as X ( Show(..), showString, showParen )
76 import Text.Read as X ( Read(..), reads )
77 import GHC.Num as X ( Num(..) )
78
79 -- some more type classes
80 import GHC.Generics as X ( Generic )
81 import Data.Functor as X ( Functor(..) )
82 import Control.Applicative as X ( Applicative(..), (<$>), (<*), (*>), (<|>), many, some, optional )
83 import qualified Control.Monad ( fail )
84 import Control.Monad.Fail
85
86 import Control.Monad as X ( Monad(return, (>>), (>>=))
87 , (<=<), (>=>), (=<<), ap, join
88 , guard, void, when, unless
89 , zipWithM, zipWithM_, foldM, filterM, replicateM
90 , MonadPlus(..), mzero, msum)
91 import Control.Monad.Trans.Class as X ( MonadTrans(lift) )
92 import Control.Monad.Identity as X ( Identity, runIdentity )
93 import Control.Monad.IO.Class as X ( MonadIO, liftIO )
94 import Control.Monad.State.Strict as X ( MonadState, StateT(..), get, gets, modify
95 , evalStateT, runStateT, evalState, runState )
96 import Control.Monad.State.Strict ( put ) -- only for defining instances
97 import Control.Monad.Trans.Identity as X ( IdentityT(..) )
98 import Control.Monad.Trans.Maybe as X ( MaybeT(..), runMaybeT )
99 import Control.Monad.Writer.Strict as X ( MonadWriter(listen, tell), WriterT(runWriterT), execWriterT, runWriter )
100 import Control.Monad.Reader as X ( MonadReader(ask), ReaderT(..), runReaderT, asks )
101
102
103 import Control.Arrow as X ( first, second, (***), (&&&) )
104 import Control.Category as X ( (<<<), (>>>) )
105
106
107 import Data.Data as X ( Data, Typeable )
108 import Data.Default as X ( Default, def )
109 import Data.Either as X ( Either(..), either, lefts, rights, partitionEithers, fromRight, fromLeft )
110 import Data.Function as X ( id, const, flip, on, ($), (.) )
111 import Data.List as X ( (\\), intercalate, intersperse, minimumBy, nub, nubBy
112 , group, groupBy, sort, sortBy
113 , genericLength, genericIndex, genericTake
114 , isSuffixOf, isPrefixOf, isInfixOf
115 , stripPrefix
116 , subsequences, transpose, elemIndex
117 , replicate, length
118 , (++), map, null, reverse, lookup, elem, unlines, words
119 , zipWith, concatMap, lines, notElem, foldr
120 , sum, product, unzip, zip, zip3, foldr1, foldl
121 , unzip3, repeat, unwords, intersect
122 , take, drop
123 , uncons
124 , takeWhile, dropWhile, span
125 , init, last
126 , inits, tails
127 , findIndex
128 , filter, partition
129 , cycle
130 )
131 import Data.List.Split as X ( splitOn, chunksOf )
132 import Data.Maybe as X ( Maybe(..), catMaybes, listToMaybe, fromMaybe, maybe, maybeToList, mapMaybe
133 , isNothing, isJust )
134 import Data.Semigroup as X ( Semigroup )
135 import Data.Monoid as X ( Monoid(mempty, mappend), mconcat, Any(..) )
136 import Data.Tuple as X ( fst, snd, swap, curry, uncurry )
137
138 import Data.Foldable as X ( Foldable, mapM_, forM_, sequence_, fold, foldMap, toList, maximum, minimum
139 , and, or, all, any
140 , concat
141 )
142 import Data.Traversable as X ( Traversable, mapM, forM, sequence )
143
144 import System.IO as X ( FilePath, IO, putStr, putStrLn, print, writeFile, appendFile, getLine )
145 import System.IO.Error ( isDoesNotExistError, ioeGetErrorType )
146 import Control.Exception as X ( catch, throwIO, SomeException )
147
148 import Data.Proxy as X ( Proxy(..) )
149
150 import Data.Type.Equality ( type (~) )
151
152 -- template-haskell
153 import qualified Language.Haskell.TH as TH ( Q )
154
155 -- safe
156 import Safe as X ( at, atNote, atMay, readMay, readNote, headNote, fromJustNote )
157
158 -- hashable
159 import Data.Hashable as X ( Hashable(..), hash )
160
161 -- cereal
162 import Data.Serialize as X ( Serialize, encode, decode )
163 import qualified Data.Serialize
164
165 -- aeson
166 import Data.Aeson as X ( ToJSON(..), FromJSON(..), genericToJSON, genericParseJSON )
167 import qualified Data.Aeson.Types as JSON
168
169 -- QuickCheck
170 import Test.QuickCheck ( Gen )
171
172
173 -- uniplate
174 import Data.Generics.Uniplate.Data as X
175 ( transform, transformBi
176 , transformM, transformBiM
177 , descend, descendM
178 , descendBi, descendBiM
179 , rewriteBi
180 , universe, universeBi
181 , children, childrenBi
182 , uniplate
183 )
184 import Data.Generics.Uniplate.Zipper as Zipper ( Zipper, down, right, up, hole )
185
186 -- pipes
187 import qualified Pipes
188
189 -- shelly
190 import Shelly ( Sh, shelly, print_stdout, print_stderr )
191
192 -- ansi-terminal
193 import System.Console.ANSI ( clearScreen, setCursorPosition )
194
195 import System.Random ( StdGen, mkStdGen, setStdGen, randomRIO )
196
197 import qualified Data.ByteString as ByteString
198 import qualified Data.Text as T
199 import qualified Data.Text.IO as T
200 import qualified Text.PrettyPrint.Annotated.HughesPJ as Pr
201
202 -- containers
203 import qualified Data.Set as S
204
205 -- strict
206 import System.IO.Strict ( readFile )
207
208 import System.Directory as X
209 ( doesDirectoryExist, doesFileExist
210 , createDirectoryIfMissing
211 )
212 import System.Directory ( removeDirectoryRecursive, removeFile )
213 import qualified System.Directory ( getDirectoryContents )
214 import System.Environment as X ( getArgs )
215 import System.FilePath as X ( (</>) )
216 import System.CPUTime ( getCPUTime )
217
218 -- time
219 import Data.Time.Clock ( getCurrentTime )
220
221 -- timeit
222 import System.TimeIt as X ( timeIt, timeItNamed )
223
224 import Debug.Trace as X ( trace, traceM )
225 import GHC.IO.Exception (IOErrorType(InvalidArgument))
226 import Text.PrettyPrint.Annotated.HughesPJ ((<+>))
227 -- import Prettyprinter (PageWidth(AvailablePerLine))
228 -- import Prettyprinter.Render.String (renderString)
229
230
231
232 type EssenceDocAnnotation = ()
233
234 type Doc = Pr.Doc EssenceDocAnnotation
235
236 -- instance Eq Doc where
237 -- a == b = show a == show b
238 --compats
239 -- hang :: Doc -> Int ->Doc -> Doc
240 -- hang a n b = a <+> Pr.hang n b
241
242 -- hcat :: [Doc] -> Doc
243 -- hcat = Pr.hcat
244
245 -- fsep :: [Doc] -> Doc
246 -- fsep = Pr.fillSep
247
248 -- cat :: [Doc] -> Doc
249 -- cat = Pr.cat
250
251 -- nest :: Int -> Doc -> Doc
252 -- nest = Pr.nest
253
254
255 tracing :: Show a => String -> a -> a
256 tracing s a = trace ("tracing " ++ s ++ ": " ++ show a) a
257
258 stringToText :: String -> T.Text
259 stringToText = T.pack
260
261 textToString :: T.Text -> String
262 textToString = T.unpack
263
264 stringToDoc :: String -> Doc
265 stringToDoc = Pr.text
266
267 textToDoc :: T.Text -> Doc
268 textToDoc = stringToDoc . textToString
269
270 padRight :: Int -> Char -> String -> String
271 padRight n ch s = s ++ replicate (n - length s) ch
272
273 padLeft :: Int -> Char -> String -> String
274 padLeft n ch s = replicate (n - length s) ch ++ s
275
276 padCenter :: Int -> Char -> String -> String
277 padCenter n ch s = replicate (div diff 2) ch ++ s ++ replicate (diff - div diff 2) ch
278 where
279 diff = n - length s
280
281 pairWithContents :: FilePath -> IO (FilePath, T.Text)
282 pairWithContents fp = do
283 con <- T.readFile fp
284 return (fp,con)
285
286 -- the fst component: generate a list yielding the elements of the input list in order
287 -- the snd component: is all those elements except the fst.
288 withRest :: [a] -> [(a,[a])]
289 withRest [] = []
290 withRest (x:xs) = (x,xs) : map (second (x:)) (withRest xs)
291
292 -- generate a list yielding the elements of the input list in order in the fst component.
293 -- the snd component is all those elements to the right of fst.
294 withAfter :: [a] -> [(a,[a])]
295 withAfter [] = []
296 withAfter (x:xs) = (x,xs) : withAfter xs
297
298 -- generate a list yielding the elements of the input list in order in the fst component.
299 -- the snd component is all those elements to the left of fst.
300 withBefore :: [a] -> [(a,[a])]
301 withBefore = reverse . withAfter . reverse
302
303
304 sameLength :: [a] -> [b] -> Bool
305 sameLength [] [] = True
306 sameLength (_:xs) (_:ys) = sameLength xs ys
307 sameLength _ _ = False
308
309 concatMapM :: (Functor m, Monad m) => (a -> m [b]) -> [a] -> m [b]
310 concatMapM f xs = concat <$> mapM f xs
311
312 concatForM :: (Functor m, Monad m) => [a] -> (a -> m [b]) -> m [b]
313 concatForM f xs = concatMapM xs f
314
315 timedIO :: IO a -> IO (a, Double)
316 timedIO io = do
317 start <- getCPUTime
318 a <- io
319 end <- getCPUTime
320 let diff = fromIntegral (end - start) / ((10 :: Double) ^ (12 :: Int))
321 return (a, diff)
322
323 tick :: MonadIO m => Doc -> m ()
324 tick msg = do
325 time <- liftIO getCPUTime
326 let seconds = fromIntegral time / ((10 :: Double) ^ (12 :: Int))
327 traceM $ show seconds ++ "\t" ++ show msg
328
329 timedPutStrLn :: String -> IO ()
330 timedPutStrLn str = do
331 t <- getCurrentTime
332 putStrLn (unwords [show t, str])
333
334 isLeft :: Either a b -> Bool
335 isLeft Left{} = True
336 isLeft _ = False
337
338 isRight :: Either a b -> Bool
339 isRight Right{} = True
340 isRight _ = False
341
342 allCombinations :: [(a,[b])] -> [[(a,b)]]
343 allCombinations [] = [[]]
344 allCombinations ((x,ys):qs) = concat [ [ (x,y) : ws | y <- ys ] | ws <- allCombinations qs ]
345
346 sortOn :: Ord b => (a -> b) -> [a] -> [a]
347 sortOn f = sortBy (comparing f)
348
349 sortNub :: Ord a => [a] -> [a]
350 sortNub = S.toList . S.fromList
351
352
353 instance Serialize T.Text where
354 put = Data.Serialize.put . T.unpack
355 get = T.pack <$> Data.Serialize.get
356
357 maybeRead :: Read a => String -> Maybe a
358 maybeRead = fmap fst . listToMaybe . reads
359
360 padShowInt :: Show a => Int -> a -> String
361 padShowInt n i = let s = show i in replicate (n - length s) '0' ++ s
362
363 decodeFromFile :: (Serialize a, MonadFail IO) => FilePath -> IO a
364 decodeFromFile path = do
365 con <- ByteString.readFile path
366 either (fail) return (decode con)
367
368 class Monad m => RandomM m where
369 get_stdgen :: m StdGen
370 set_stdgen :: StdGen -> m ()
371
372
373 fst3 :: (a,b,c) -> a
374 fst3 (a,_,_) = a
375
376 snd3 :: (a,b,c) -> b
377 snd3 (_,b,_) = b
378
379 thd3 :: (a,b,c) -> c
380 thd3 (_,_,c) = c
381
382 fst4 :: (a,b,c,d) -> a
383 fst4 (a,_,_,_) = a
384
385 snd4 :: (a,b,c,d) -> b
386 snd4 (_,b,_,_) = b
387
388 thd4 :: (a,b,c,d) -> c
389 thd4 (_,_,c,_) = c
390
391 fourth4 :: (a,b,c,d) -> d
392 fourth4 (_,_,_,d) = d
393
394 (|>) :: a -> (a -> b) -> b
395 (|>) = flip ($)
396
397 allNats :: [Integer]
398 allNats = [1..]
399
400
401 jsonOptions :: JSON.Options
402 jsonOptions = JSON.defaultOptions
403 { JSON.allNullaryToStringTag = True
404 , JSON.omitNothingFields = True
405 , JSON.sumEncoding = JSON.ObjectWithSingleField
406 }
407
408
409 class (Functor m, Applicative m, Monad m,MonadFail m) => MonadFailDoc m where
410 failDoc :: Doc -> m a
411
412 na :: MonadFailDoc m => Doc -> m a
413 na message = failDoc ("N/A:" <+> message)
414
415 instance MonadFail Identity where
416 fail = error
417 instance MonadFailDoc Identity where
418 failDoc = Control.Monad.fail . show
419
420 instance MonadFailDoc Maybe where
421 failDoc = const Nothing
422
423 instance (a ~ Doc) => MonadFailDoc (Either a) where
424 failDoc = Left
425
426 instance MonadFail (Either Doc) where
427 fail = failDoc . stringToDoc
428
429 instance MonadFailDoc m => MonadFailDoc (IdentityT m) where
430 failDoc = lift . failDoc
431
432 instance (Functor m, Monad m) => MonadFailDoc (MaybeT m) where
433 failDoc = const $ MaybeT $ return Nothing
434
435 instance (MonadFailDoc m) => MonadFailDoc (ExceptT m) where
436 failDoc = ExceptT . return . Left
437
438 instance (MonadFailDoc m) => MonadFailDoc (StateT st m) where
439 failDoc = lift . failDoc
440
441 instance (MonadFailDoc m, Monoid w) => MonadFailDoc (WriterT w m) where
442 failDoc = lift . failDoc
443
444 instance MonadFailDoc m => MonadFailDoc (ReaderT r m) where
445 failDoc = lift . failDoc
446
447 instance MonadFail Gen where
448 fail = error
449 instance MonadFailDoc Gen where
450 failDoc = Control.Monad.fail . show
451
452
453 instance MonadFailDoc m => MonadFailDoc (Pipes.Proxy a b c d m) where
454 failDoc = lift . failDoc
455
456 instance MonadFailDoc TH.Q where
457 failDoc = Control.Monad.fail . show
458
459
460 newtype ExceptT m a = ExceptT { runExceptT :: m (Either Doc a) }
461
462 instance (Functor m) => Functor (ExceptT m) where
463 fmap f = ExceptT . fmap (fmap f) . runExceptT
464
465 instance (Functor m, Monad m) => Applicative (ExceptT m) where
466 pure = ExceptT . return . Right
467 (<*>) = ap
468
469 instance (Monad m) => Monad (ExceptT m) where
470 return = pure
471 m >>= k = ExceptT $ do
472 a <- runExceptT m
473 case a of
474 Left e -> return (Left e)
475 Right x -> runExceptT (k x)
476 -- fail = ExceptT . return . Left . stringToDoc
477
478
479 instance (MonadFailDoc m) => MonadFail (ExceptT m) where
480 fail = ExceptT . return . Left . stringToDoc
481
482 instance MonadIO m => MonadIO (ExceptT m) where
483 liftIO comp = ExceptT $ do
484 res <- liftIO comp
485 return (Right res)
486
487 instance MonadTrans ExceptT where
488 lift comp = ExceptT $ do
489 res <- comp
490 return (Right res)
491
492 instance MonadState s m => MonadState s (ExceptT m) where
493 get = lift get
494 put = lift . put
495
496
497
498 allContexts :: Data b => Zipper a b -> [Zipper a b]
499 allContexts z0 = concatMap subtreeOf (allSiblings z0)
500 where
501 -- the input has to be the left most
502 allSiblings :: Zipper a b -> [Zipper a b]
503 allSiblings z = z : maybe [] allSiblings (right z)
504
505 subtreeOf :: Data b => Zipper a b -> [Zipper a b]
506 subtreeOf z = z : maybe [] allContexts (down z)
507
508 ascendants :: Zipper a b -> [b]
509 ascendants z = hole z : maybe [] ascendants (Zipper.up z)
510
511
512 -- | splits from the "."s, drops the last component, glues back together what's left
513 dropExtension :: FilePath -> FilePath
514 dropExtension = intercalate "." . init . splitOn "."
515
516 -- | splits from the "/"s, drops all but last component, returns what's left
517 dropDirs :: FilePath -> FilePath
518 dropDirs = last . splitOn "/"
519
520 -- | Same as head . splitOn
521 splitOn1 :: String -> String -> String
522 splitOn1 sep inp =
523 case splitOn sep inp of
524 [] -> inp
525 (outp:_) -> outp
526
527 class (Functor m, Applicative m, Monad m) => MonadLog m where
528 log :: LogLevel -> Doc -> m ()
529
530 data LogLevel
531 = LogNone
532 | LogInfo
533 | LogFollow
534 | LogWarn
535 | LogDebug
536 | LogDebugVerbose
537 deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)
538
539 instance Serialize LogLevel
540 instance Hashable LogLevel
541 instance ToJSON LogLevel where toJSON = genericToJSON jsonOptions
542 instance FromJSON LogLevel where parseJSON = genericParseJSON jsonOptions
543
544 instance Default LogLevel where def = LogInfo
545
546 logInfo :: MonadLog m => Doc -> m ()
547 logInfo = log LogInfo
548
549 logWarn :: MonadLog m => Doc -> m ()
550 logWarn = log LogWarn
551
552 logDebug :: MonadLog m => Doc -> m ()
553 logDebug = log LogDebug
554
555 logDebugVerbose :: MonadLog m => Doc -> m ()
556 logDebugVerbose = log LogDebugVerbose
557
558 instance MonadLog m => MonadLog (ReaderT r m) where
559 log l m = lift (log l m)
560
561 instance (MonadLog m, Monoid w) => MonadLog (WriterT w m) where
562 log l m = lift (log l m)
563
564 instance MonadLog m => MonadLog (StateT st m) where
565 log l m = lift (log l m)
566
567 instance MonadLog m => MonadLog (ExceptT m) where
568 log l m = log l m >> ExceptT (return (Right ()))
569
570 instance (Applicative m, Monad m) => MonadLog (IdentityT m) where
571 log _ _ = return ()
572
573 instance Monad m => MonadLog (Pipes.Proxy a b () (Either (LogLevel, Doc) d) m) where
574 log l m = Pipes.yield (Left (l,m))
575
576 ignoreLogs :: Monad m => IdentityT m a -> m a
577 ignoreLogs = runIdentityT
578
579 runLoggerPipeIO :: MonadIO m => LogLevel -> Pipes.Producer (Either (LogLevel, Doc) a) m r -> m r
580 runLoggerPipeIO l logger = Pipes.runEffect $ Pipes.for logger each
581 where
582 each (Left (lvl, msg)) =
583 when (lvl <= l) $ do
584 let txt = Pr.renderStyle (Pr.style { Pr.lineLength = 200 }) msg
585 -- let txt = renderString $ (Pr.layoutPretty $ Pr.LayoutOptions (AvailablePerLine 200 1.0)) msg
586 when ("[" `isPrefixOf` txt) $ do
587 liftIO clearScreen
588 liftIO (setCursorPosition 0 0)
589 liftIO $ putStrLn txt
590 each _ = return ()
591
592 histogram :: Ord a => [a] -> [(a, Integer)]
593 histogram xs = catMaybes
594 [ case grp of
595 [] -> Nothing
596 (x:_) -> Just (x, genericLength grp)
597 | grp <- xs |> sort |> group
598 ]
599
600 sh :: Sh a -> IO a
601 sh = shelly . print_stdout False . print_stderr False
602
603 scope :: MonadState st m => m a -> m a
604 scope ma = do
605 st <- gets id
606 a <- ma
607 modify (const st)
608 return a
609
610 getDirectoryContents :: FilePath -> IO [FilePath]
611 getDirectoryContents x = System.Directory.getDirectoryContents x `catch` (\ (_ :: SomeException) -> return [] )
612
613 getAllDirs :: FilePath -> IO [FilePath]
614 getAllDirs x = do
615 let dots i = not ( i == "." || i == ".." )
616 isDir <- doesDirectoryExist x
617 ys' <- getDirectoryContents x
618 let ys = filter dots ys'
619 ([x | isDir] ++) <$> concatMapM getAllDirs (map (x </>) ys)
620
621 getAllFiles :: FilePath -> IO [FilePath]
622 getAllFiles x = do
623 let dots i = not ( i == "." || i == ".." )
624 ys' <- getDirectoryContents x
625 let ys = filter dots ys'
626 (x :) <$> concatMapM getAllFiles (map (x </>) ys)
627
628 getAllFilesWithSuffix :: String -> FilePath -> IO [FilePath]
629 getAllFilesWithSuffix suffix fp = filter (suffix `isSuffixOf`) <$> getAllFiles fp
630
631 -- from http://stackoverflow.com/questions/8502201/remove-file-if-it-exists
632 removeFileIfExists :: FilePath -> IO ()
633 removeFileIfExists f = removeFile f `catch` handleExists
634 where
635 handleExists e
636 | isDoesNotExistError e = return ()
637 | otherwise = throwIO e
638
639 readFileIfExists :: FilePath -> IO (Maybe String)
640 readFileIfExists f = (Just <$> readFile f) `catch` handleExists
641 where
642 handleExists e
643 | ioeGetErrorType e == InvalidArgument = return Nothing -- handle non-text files gracefully
644 | isDoesNotExistError e = return Nothing
645 | otherwise = trace (show e) $ throwIO e
646
647 removeDirectoryIfExists :: FilePath -> IO ()
648 removeDirectoryIfExists f = removeDirectoryRecursive f `catch` handleExists
649 where
650 handleExists e
651 | isDoesNotExistError e = return ()
652 | otherwise = throwIO e
653
654
655 setRandomSeed :: Int -> IO ()
656 setRandomSeed = setStdGen . mkStdGen
657
658 nchoosek :: Integral a => (a -> a) -> a -> a -> a
659 nchoosek f n k = f n `div` (f k * f (n-k))
660
661 type JSONValue = JSON.Value
662
663 -- | return true if this is a top-most zipper.
664 -- i.e. we cannot go any more up.
665 isTopMostZ :: Zipper a b -> Bool
666 isTopMostZ = isNothing . up
667
668
669 class RunStateAsWriter s where
670 -- | We don't have Writer monads around here, they leak space.
671 runStateAsWriterT :: (Monad m, Default s) => StateT s m a -> m (a, s)
672
673 instance RunStateAsWriter [s] where
674 runStateAsWriterT m = do
675 (a, out) <- runStateT m def
676 return (a, reverse out)
677
678 instance RunStateAsWriter ([a],[b]) where
679 runStateAsWriterT m = do
680 (x, (a,b)) <- runStateT m def
681 return (x, (reverse a, reverse b))
682
683 sawTell :: (MonadState s m, Monoid s) => s -> m ()
684 sawTell xs = modify (xs `mappend`)
685
686
687 stripPostfix :: Eq a => [a] -> [a] -> Maybe [a]
688 stripPostfix postfix list =
689 case stripPrefix (reverse postfix) (reverse list) of
690 Nothing -> Nothing
691 Just rest -> Just (reverse rest)
692