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