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