{-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- -- Copyright 2019, Ideas project team. This file is distributed under the -- terms of the Apache License 2.0. For more information, see the files -- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution. ----------------------------------------------------------------------------- -- | -- Maintainer : bastiaan.heeren@ou.nl -- Stability : provisional -- Portability : portable (depends on ghc) -- -- A collection of general utility functions -- ----------------------------------------------------------------------------- module Ideas.Utils.Prelude ( Some(..), ShowString(..), readInt, readM , subsets, isSubsetOf , cartesian, distinct, allsame , fixpoint , splitAtElem, splitsWithElem , timedSeconds, getDiffTime , fst3, snd3, thd3 , headM, findIndexM , elementAt, changeAt, replaceAt , list , mwhen, munless ) where import Data.Char import Data.List import Data.Time import System.Timeout data Some f = forall a . Some (f a) newtype ShowString = ShowString { fromShowString :: String } deriving (Eq, Ord) instance Show ShowString where show = fromShowString instance Read ShowString where readsPrec n s = [ (ShowString x, y) | (x, y) <- readsPrec n s ] readInt :: String -> Maybe Int readInt xs | null xs = Nothing | any (not . isDigit) xs = Nothing | otherwise = Just (foldl' (\a b -> a*10+ord b-48) 0 xs) -- ' readM :: (Monad m, Read a) => String -> m a readM s = case reads s of [(a, xs)] | all isSpace xs -> return a _ -> fail ("no read: " ++ s) subsets :: [a] -> [[a]] subsets = foldr op [[]] where op a xs = xs ++ map (a:) xs isSubsetOf :: Eq a => [a] -> [a] -> Bool isSubsetOf xs ys = all (`elem` ys) xs cartesian :: [a] -> [b] -> [(a, b)] cartesian as bs = [ (a, b) | a <- as, b <- bs ] distinct :: Eq a => [a] -> Bool distinct [] = True distinct (x:xs) = notElem x xs && distinct xs allsame :: Eq a => [a] -> Bool allsame [] = True allsame (x:xs) = all (==x) xs fixpoint :: Eq a => (a -> a) -> a -> a fixpoint f = rec . iterate f where rec [] = error "Ideas.Common.Utils: empty list" rec (x:xs) | x == head xs = x | otherwise = rec xs splitAtElem :: Eq a => a -> [a] -> Maybe ([a], [a]) splitAtElem c s = case break (==c) s of (xs, _:ys) -> Just (xs, ys) _ -> Nothing splitsWithElem :: Eq a => a -> [a] -> [[a]] splitsWithElem c s = case splitAtElem c s of Just (xs, ys) -> xs : splitsWithElem c ys Nothing -> [s] timedSeconds :: Int -> IO a -> IO a timedSeconds n m = timeout (n * 10^(6 :: Int)) m >>= maybe (fail ("Timeout after " ++ show n ++ " seconds")) return getDiffTime :: IO a -> IO (a, NominalDiffTime) getDiffTime action = do t0 <- getCurrentTime a <- action t1 <- getCurrentTime return (a, diffUTCTime t1 t0) fst3 :: (a, b, c) -> a fst3 (x, _, _) = x snd3 :: (a, b, c) -> b snd3 (_, x, _) = x thd3 :: (a, b, c) -> c thd3 (_, _, x) = x -- generalized list functions (results in monad) headM :: Monad m => [a] -> m a headM (a:_) = return a headM _ = fail "headM" findIndexM :: Monad m => (a -> Bool) -> [a] -> m Int findIndexM p = maybe (fail "findIndexM") return . findIndex p elementAt :: Monad m => Int -> [a] -> m a elementAt i = headM . drop i changeAt :: Monad m => Int -> (a -> a) -> [a] -> m [a] changeAt i f as = case splitAt i as of (xs, y:ys) -> return (xs ++ f y : ys) _ -> fail "changeAt" replaceAt :: Monad m => Int -> a -> [a] -> m [a] replaceAt i = changeAt i . const list :: b -> ([a] -> b) -> [a] -> b list b f xs = if null xs then b else f xs -- Monoids mwhen :: Monoid a => Bool -> a -> a mwhen True a = a mwhen False _ = mempty munless :: Monoid a => Bool -> a -> a munless = mwhen . not