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 -- template-haskell
149 import qualified Language.Haskell.TH as TH ( Q )
150
151 -- safe
152 import Safe as X ( at, atNote, atMay, readMay, readNote, headNote, fromJustNote )
153
154 -- hashable
155 import Data.Hashable as X ( Hashable(..), hash )
156
157 -- cereal
158 import Data.Serialize as X ( Serialize, encode, decode )
159 import qualified Data.Serialize
160
161 -- aeson
162 import Data.Aeson as X ( ToJSON(..), FromJSON(..), genericToJSON, genericParseJSON )
163 import qualified Data.Aeson.Types as JSON
164
165 -- QuickCheck
166 import Test.QuickCheck ( Gen )
167
168
169 -- uniplate
170 import Data.Generics.Uniplate.Data as X
171 ( transform, transformBi
172 , transformM, transformBiM
173 , descend, descendM
174 , descendBi, descendBiM
175 , universe, universeBi
176 , children, childrenBi
177 , uniplate
178 )
179 import Data.Generics.Uniplate.Zipper as Zipper ( Zipper, down, right, up, hole )
180
181 -- pipes
182 import qualified Pipes
183
184 -- shelly
185 import Shelly ( Sh, shelly, print_stdout, print_stderr )
186
187 -- ansi-terminal
188 import System.Console.ANSI ( clearScreen, setCursorPosition )
189
190 import System.Random ( StdGen, mkStdGen, setStdGen, randomRIO )
191
192 import qualified Data.ByteString as ByteString
193 import qualified Data.Text as T
194 import qualified Data.Text.IO as T
195 import qualified Text.PrettyPrint.Annotated.HughesPJ as Pr
196
197 -- containers
198 import qualified Data.Set as S
199
200 -- strict
201 import System.IO.Strict ( readFile )
202
203 import System.Directory as X
204 ( doesDirectoryExist, doesFileExist
205 , createDirectoryIfMissing
206 )
207 import System.Directory ( removeDirectoryRecursive, removeFile )
208 import qualified System.Directory ( getDirectoryContents )
209 import System.Environment as X ( getArgs )
210 import System.FilePath as X ( (</>) )
211 import System.CPUTime ( getCPUTime )
212
213 -- time
214 import Data.Time.Clock ( getCurrentTime )
215
216 -- timeit
217 import System.TimeIt as X ( timeIt, timeItNamed )
218
219 import Debug.Trace as X ( trace, traceM )
220 import GHC.IO.Exception (IOErrorType(InvalidArgument))
221 import Text.PrettyPrint.Annotated.HughesPJ ((<+>))
222 -- import Prettyprinter (PageWidth(AvailablePerLine))
223 -- import Prettyprinter.Render.String (renderString)
224
225
226
227 type EssenceDocAnnotation = ()
228
229 type Doc = Pr.Doc EssenceDocAnnotation
230
231 -- instance Eq Doc where
232 -- a == b = show a == show b
233 --compats
234 -- hang :: Doc -> Int ->Doc -> Doc
235 -- hang a n b = a <+> Pr.hang n b
236
237 -- hcat :: [Doc] -> Doc
238 -- hcat = Pr.hcat
239
240 -- fsep :: [Doc] -> Doc
241 -- fsep = Pr.fillSep
242
243 -- cat :: [Doc] -> Doc
244 -- cat = Pr.cat
245
246 -- nest :: Int -> Doc -> Doc
247 -- nest = Pr.nest
248
249
250 tracing :: Show a => String -> a -> a
251 tracing s a = trace ("tracing " ++ s ++ ": " ++ show a) a
252
253 stringToText :: String -> T.Text
254 stringToText = T.pack
255
256 textToString :: T.Text -> String
257 textToString = T.unpack
258
259 stringToDoc :: String -> Doc
260 stringToDoc = Pr.text
261
262 padRight :: Int -> Char -> String -> String
263 padRight n ch s = s ++ replicate (n - length s) ch
264
265 padLeft :: Int -> Char -> String -> String
266 padLeft n ch s = replicate (n - length s) ch ++ s
267
268 padCenter :: Int -> Char -> String -> String
269 padCenter n ch s = replicate (div diff 2) ch ++ s ++ replicate (diff - div diff 2) ch
270 where
271 diff = n - length s
272
273 pairWithContents :: FilePath -> IO (FilePath, T.Text)
274 pairWithContents fp = do
275 con <- T.readFile fp
276 return (fp,con)
277
278 -- the fst component: generate a list yielding the elements of the input list in order
279 -- the snd component: is all those elements except the fst.
280 withRest :: [a] -> [(a,[a])]
281 withRest [] = []
282 withRest (x:xs) = (x,xs) : map (second (x:)) (withRest xs)
283
284 -- generate a list yielding the elements of the input list in order in the fst component.
285 -- the snd component is all those elements to the right of fst.
286 withAfter :: [a] -> [(a,[a])]
287 withAfter [] = []
288 withAfter (x:xs) = (x,xs) : withAfter xs
289
290 -- generate a list yielding the elements of the input list in order in the fst component.
291 -- the snd component is all those elements to the left of fst.
292 withBefore :: [a] -> [(a,[a])]
293 withBefore = reverse . withAfter . reverse
294
295
296 sameLength :: [a] -> [b] -> Bool
297 sameLength [] [] = True
298 sameLength (_:xs) (_:ys) = sameLength xs ys
299 sameLength _ _ = False
300
301 concatMapM :: (Functor m, Monad m) => (a -> m [b]) -> [a] -> m [b]
302 concatMapM f xs = concat <$> mapM f xs
303
304 concatForM :: (Functor m, Monad m) => [a] -> (a -> m [b]) -> m [b]
305 concatForM f xs = concatMapM xs f
306
307 timedIO :: IO a -> IO (a, Double)
308 timedIO io = do
309 start <- getCPUTime
310 a <- io
311 end <- getCPUTime
312 let diff = fromIntegral (end - start) / ((10 :: Double) ^ (12 :: Int))
313 return (a, diff)
314
315 tick :: MonadIO m => Doc -> m ()
316 tick msg = do
317 time <- liftIO getCPUTime
318 let seconds = fromIntegral time / ((10 :: Double) ^ (12 :: Int))
319 traceM $ show seconds ++ "\t" ++ show msg
320
321 timedPutStrLn :: String -> IO ()
322 timedPutStrLn str = do
323 t <- getCurrentTime
324 putStrLn (unwords [show t, str])
325
326 isLeft :: Either a b -> Bool
327 isLeft Left{} = True
328 isLeft _ = False
329
330 isRight :: Either a b -> Bool
331 isRight Right{} = True
332 isRight _ = False
333
334 allCombinations :: [(a,[b])] -> [[(a,b)]]
335 allCombinations [] = [[]]
336 allCombinations ((x,ys):qs) = concat [ [ (x,y) : ws | y <- ys ] | ws <- allCombinations qs ]
337
338 sortOn :: Ord b => (a -> b) -> [a] -> [a]
339 sortOn f = sortBy (comparing f)
340
341 sortNub :: Ord a => [a] -> [a]
342 sortNub = S.toList . S.fromList
343
344
345 instance Serialize T.Text where
346 put = Data.Serialize.put . T.unpack
347 get = T.pack <$> Data.Serialize.get
348
349 maybeRead :: Read a => String -> Maybe a
350 maybeRead = fmap fst . listToMaybe . reads
351
352 padShowInt :: Show a => Int -> a -> String
353 padShowInt n i = let s = show i in replicate (n - length s) '0' ++ s
354
355 decodeFromFile :: (Serialize a, MonadFail IO) => FilePath -> IO a
356 decodeFromFile path = do
357 con <- ByteString.readFile path
358 either (fail) return (decode con)
359
360 class Monad m => RandomM m where
361 get_stdgen :: m StdGen
362 set_stdgen :: StdGen -> m ()
363
364
365 fst3 :: (a,b,c) -> a
366 fst3 (a,_,_) = a
367
368 snd3 :: (a,b,c) -> b
369 snd3 (_,b,_) = b
370
371 thd3 :: (a,b,c) -> c
372 thd3 (_,_,c) = c
373
374 fst4 :: (a,b,c,d) -> a
375 fst4 (a,_,_,_) = a
376
377 snd4 :: (a,b,c,d) -> b
378 snd4 (_,b,_,_) = b
379
380 thd4 :: (a,b,c,d) -> c
381 thd4 (_,_,c,_) = c
382
383 fourth4 :: (a,b,c,d) -> d
384 fourth4 (_,_,_,d) = d
385
386 (|>) :: a -> (a -> b) -> b
387 (|>) = flip ($)
388
389 allNats :: [Integer]
390 allNats = [1..]
391
392
393 jsonOptions :: JSON.Options
394 jsonOptions = JSON.defaultOptions
395 { JSON.allNullaryToStringTag = True
396 , JSON.omitNothingFields = True
397 , JSON.sumEncoding = JSON.ObjectWithSingleField
398 }
399
400
401 class (Functor m, Applicative m, Monad m,MonadFail m) => MonadFailDoc m where
402 failDoc :: Doc -> m a
403
404 na :: MonadFailDoc m => Doc -> m a
405 na message = failDoc ("N/A:" <+> message)
406
407 instance MonadFail Identity where
408 fail = error
409 instance MonadFailDoc Identity where
410 failDoc = Control.Monad.fail . show
411
412 instance MonadFailDoc Maybe where
413 failDoc = const Nothing
414
415 instance (a ~ Doc) => MonadFailDoc (Either a) where
416 failDoc = Left
417
418 instance MonadFail (Either Doc) where
419 fail = failDoc . stringToDoc
420
421 instance MonadFailDoc m => MonadFailDoc (IdentityT m) where
422 failDoc = lift . failDoc
423
424 instance (Functor m, Monad m) => MonadFailDoc (MaybeT m) where
425 failDoc = const $ MaybeT $ return Nothing
426
427 instance (MonadFailDoc m) => MonadFailDoc (ExceptT m) where
428 failDoc = ExceptT . return . Left
429
430 instance (MonadFailDoc m) => MonadFailDoc (StateT st m) where
431 failDoc = lift . failDoc
432
433 instance (MonadFailDoc m, Monoid w) => MonadFailDoc (WriterT w m) where
434 failDoc = lift . failDoc
435
436 instance MonadFailDoc m => MonadFailDoc (ReaderT r m) where
437 failDoc = lift . failDoc
438
439 instance MonadFail Gen where
440 fail = error
441 instance MonadFailDoc Gen where
442 failDoc = Control.Monad.fail . show
443
444
445 instance MonadFailDoc m => MonadFailDoc (Pipes.Proxy a b c d m) where
446 failDoc = lift . failDoc
447
448 instance MonadFailDoc TH.Q where
449 failDoc = Control.Monad.fail . show
450
451
452 newtype ExceptT m a = ExceptT { runExceptT :: m (Either Doc a) }
453
454 instance (Functor m) => Functor (ExceptT m) where
455 fmap f = ExceptT . fmap (fmap f) . runExceptT
456
457 instance (Functor m, Monad m) => Applicative (ExceptT m) where
458 pure = ExceptT . return . Right
459 (<*>) = ap
460
461 instance (Monad m) => Monad (ExceptT m) where
462 return = pure
463 m >>= k = ExceptT $ do
464 a <- runExceptT m
465 case a of
466 Left e -> return (Left e)
467 Right x -> runExceptT (k x)
468 -- fail = ExceptT . return . Left . stringToDoc
469
470
471 instance (MonadFailDoc m) => MonadFail (ExceptT m) where
472 fail = ExceptT . return . Left . stringToDoc
473
474 instance MonadIO m => MonadIO (ExceptT m) where
475 liftIO comp = ExceptT $ do
476 res <- liftIO comp
477 return (Right res)
478
479 instance MonadTrans ExceptT where
480 lift comp = ExceptT $ do
481 res <- comp
482 return (Right res)
483
484 instance MonadState s m => MonadState s (ExceptT m) where
485 get = lift get
486 put = lift . put
487
488
489
490 allContexts :: Data b => Zipper a b -> [Zipper a b]
491 allContexts z0 = concatMap subtreeOf (allSiblings z0)
492 where
493 -- the input has to be the left most
494 allSiblings :: Zipper a b -> [Zipper a b]
495 allSiblings z = z : maybe [] allSiblings (right z)
496
497 subtreeOf :: Data b => Zipper a b -> [Zipper a b]
498 subtreeOf z = z : maybe [] allContexts (down z)
499
500 ascendants :: Zipper a b -> [b]
501 ascendants z = hole z : maybe [] ascendants (Zipper.up z)
502
503
504 -- | splits from the "."s, drops the last component, glues back together what's left
505 dropExtension :: FilePath -> FilePath
506 dropExtension = intercalate "." . init . splitOn "."
507
508 -- | splits from the "/"s, drops all but last component, returns what's left
509 dropDirs :: FilePath -> FilePath
510 dropDirs = last . splitOn "/"
511
512 -- | Same as head . splitOn
513 splitOn1 :: String -> String -> String
514 splitOn1 sep inp =
515 case splitOn sep inp of
516 [] -> inp
517 (outp:_) -> outp
518
519 class (Functor m, Applicative m, Monad m) => MonadLog m where
520 log :: LogLevel -> Doc -> m ()
521
522 data LogLevel
523 = LogNone
524 | LogInfo
525 | LogFollow
526 | LogWarn
527 | LogDebug
528 | LogDebugVerbose
529 deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)
530
531 instance Serialize LogLevel
532 instance Hashable LogLevel
533 instance ToJSON LogLevel where toJSON = genericToJSON jsonOptions
534 instance FromJSON LogLevel where parseJSON = genericParseJSON jsonOptions
535
536 instance Default LogLevel where def = LogInfo
537
538 logInfo :: MonadLog m => Doc -> m ()
539 logInfo = log LogInfo
540
541 logWarn :: MonadLog m => Doc -> m ()
542 logWarn = log LogWarn
543
544 logDebug :: MonadLog m => Doc -> m ()
545 logDebug = log LogDebug
546
547 logDebugVerbose :: MonadLog m => Doc -> m ()
548 logDebugVerbose = log LogDebugVerbose
549
550 instance MonadLog m => MonadLog (ReaderT r m) where
551 log l m = lift (log l m)
552
553 instance (MonadLog m, Monoid w) => MonadLog (WriterT w m) where
554 log l m = lift (log l m)
555
556 instance MonadLog m => MonadLog (StateT st m) where
557 log l m = lift (log l m)
558
559 instance MonadLog m => MonadLog (ExceptT m) where
560 log l m = log l m >> ExceptT (return (Right ()))
561
562 instance (Applicative m, Monad m) => MonadLog (IdentityT m) where
563 log _ _ = return ()
564
565 instance Monad m => MonadLog (Pipes.Proxy a b () (Either (LogLevel, Doc) d) m) where
566 log l m = Pipes.yield (Left (l,m))
567
568 ignoreLogs :: Monad m => IdentityT m a -> m a
569 ignoreLogs = runIdentityT
570
571 runLoggerPipeIO :: MonadIO m => LogLevel -> Pipes.Producer (Either (LogLevel, Doc) a) m r -> m r
572 runLoggerPipeIO l logger = Pipes.runEffect $ Pipes.for logger each
573 where
574 each (Left (lvl, msg)) =
575 when (lvl <= l) $ do
576 let txt = Pr.renderStyle (Pr.style { Pr.lineLength = 200 }) msg
577 -- let txt = renderString $ (Pr.layoutPretty $ Pr.LayoutOptions (AvailablePerLine 200 1.0)) msg
578 when ("[" `isPrefixOf` txt) $ do
579 liftIO clearScreen
580 liftIO (setCursorPosition 0 0)
581 liftIO $ putStrLn txt
582 each _ = return ()
583
584 histogram :: Ord a => [a] -> [(a, Integer)]
585 histogram xs = catMaybes
586 [ case grp of
587 [] -> Nothing
588 (x:_) -> Just (x, genericLength grp)
589 | grp <- xs |> sort |> group
590 ]
591
592 sh :: Sh a -> IO a
593 sh = shelly . print_stdout False . print_stderr False
594
595 scope :: MonadState st m => m a -> m a
596 scope ma = do
597 st <- gets id
598 a <- ma
599 modify (const st)
600 return a
601
602 getDirectoryContents :: FilePath -> IO [FilePath]
603 getDirectoryContents x = System.Directory.getDirectoryContents x `catch` (\ (_ :: SomeException) -> return [] )
604
605 getAllDirs :: FilePath -> IO [FilePath]
606 getAllDirs x = do
607 let dots i = not ( i == "." || i == ".." )
608 isDir <- doesDirectoryExist x
609 ys' <- getDirectoryContents x
610 let ys = filter dots ys'
611 ([x | isDir] ++) <$> concatMapM getAllDirs (map (x </>) ys)
612
613 getAllFiles :: FilePath -> IO [FilePath]
614 getAllFiles x = do
615 let dots i = not ( i == "." || i == ".." )
616 ys' <- getDirectoryContents x
617 let ys = filter dots ys'
618 (x :) <$> concatMapM getAllFiles (map (x </>) ys)
619
620 getAllFilesWithSuffix :: String -> FilePath -> IO [FilePath]
621 getAllFilesWithSuffix suffix fp = filter (suffix `isSuffixOf`) <$> getAllFiles fp
622
623 -- from http://stackoverflow.com/questions/8502201/remove-file-if-it-exists
624 removeFileIfExists :: FilePath -> IO ()
625 removeFileIfExists f = removeFile f `catch` handleExists
626 where
627 handleExists e
628 | isDoesNotExistError e = return ()
629 | otherwise = throwIO e
630
631 readFileIfExists :: FilePath -> IO (Maybe String)
632 readFileIfExists f = (Just <$> readFile f) `catch` handleExists
633 where
634 handleExists e
635 | ioeGetErrorType e == InvalidArgument = return Nothing -- handle non-text files gracefully
636 | isDoesNotExistError e = return Nothing
637 | otherwise = trace (show e) $ throwIO e
638
639 removeDirectoryIfExists :: FilePath -> IO ()
640 removeDirectoryIfExists f = removeDirectoryRecursive f `catch` handleExists
641 where
642 handleExists e
643 | isDoesNotExistError e = return ()
644 | otherwise = throwIO e
645
646
647 setRandomSeed :: Int -> IO ()
648 setRandomSeed = setStdGen . mkStdGen
649
650 nchoosek :: Integral a => (a -> a) -> a -> a -> a
651 nchoosek f n k = f n `div` (f k * f (n-k))
652
653 type JSONValue = JSON.Value
654
655 -- | return true if this is a top-most zipper.
656 -- i.e. we cannot go any more up.
657 isTopMostZ :: Zipper a b -> Bool
658 isTopMostZ = isNothing . up
659
660
661 class RunStateAsWriter s where
662 -- | We don't have Writer monads around here, they leak space.
663 runStateAsWriterT :: (Monad m, Default s) => StateT s m a -> m (a, s)
664
665 instance RunStateAsWriter [s] where
666 runStateAsWriterT m = do
667 (a, out) <- runStateT m def
668 return (a, reverse out)
669
670 instance RunStateAsWriter ([a],[b]) where
671 runStateAsWriterT m = do
672 (x, (a,b)) <- runStateT m def
673 return (x, (reverse a, reverse b))
674
675 sawTell :: (MonadState s m, Monoid s) => s -> m ()
676 sawTell xs = modify (xs `mappend`)
677
678
679 stripPostfix :: Eq a => [a] -> [a] -> Maybe [a]
680 stripPostfix postfix list =
681 case stripPrefix (reverse postfix) (reverse list) of
682 Nothing -> Nothing
683 Just rest -> Just (reverse rest)
684