{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE EmptyDataDecls #-}
-- ----------------------------------------------------------------------------
{- |
General utitlity functions.
-}
-- ----------------------------------------------------------------------------
module Hunt.Utility
(
-- * Function Composition
(.::), (.:::)
-- * Safe / Total Functions
, head'
-- * Strict Functions
, foldM'
-- * Monadic Functions
, foldlWithKeyM, foldrWithKeyM
, whenM
-- * Maybe Helper
, catMaybesSet
-- * Either Helper
, isLeft, isRight
, fromLeft, fromRight
-- * List Helper
, unbox, unboxM, isSingleton
, split
, partitionListByLength, partitionListByCount
, descending
-- * String Helper
, strip, stripl, stripr, stripWith
, escape
-- * Text Helper
, showText
-- * Aeson Helper
, object', (.=?), (.==), (.\.)
-- * Types
, TypeDummy
)
where
import Control.Monad (when)
import Data.Aeson hiding (decode)
import Data.Aeson.Types
import Data.Char
import qualified Data.Foldable as FB
import qualified Data.List as L
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromJust)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Numeric (showHex)
-- ------------------------------------------------------------
-- | A dummy type without constructor.
data TypeDummy
-- ------------------------------------------------------------
showText :: Show a => a -> Text
showText = T.pack . show
-- | The boob operator.
(.::) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(.::) = (.).(.)
-- | The Total Recall operator.
(.:::) :: (d -> e) -> (a -> b -> c -> d) -> a -> b -> c -> e
(.:::) = (.).(.).(.)
-- | Safe 'head'.
head' :: [a] -> Maybe a
head' xs = if null xs then Nothing else Just $ head xs
-- | 'Data.Maybe.catMaybes' on a 'Set' instead of a List.
catMaybesSet :: Ord a => Set (Maybe a) -> [a]
catMaybesSet = S.toList . S.map fromJust . S.delete Nothing
-- | Test if 'Either' is a 'Left' value.
isLeft :: Either a b -> Bool
isLeft = either (const True) (const False)
-- | Test if 'Either' is a 'Right' value.
isRight :: Either a b -> Bool
isRight = not . isLeft
-- | Unwraps a 'Left' value - fails on 'Right'.
fromLeft :: Either a b -> a
fromLeft = either id (error "Hunt.Utility.fromLeft: Right")
-- | Unwraps a 'Right' value - fails on 'Left'.
fromRight :: Either a b -> b
fromRight = either (error "Hunt.Utility.fromRight: Left") id
-- | Unbox a singleton.
--
-- /Note/: This fails if the list is not a singleton.
unbox :: [a] -> a
unbox [e] = e
unbox _ = error "unbox: []"
-- | Unbox a singleton in a safe way with 'Maybe'.
unboxM :: [a] -> Maybe a
unboxM [e] = Just e
unboxM _ = Nothing
-- | Test if the list contains a single element.
isSingleton :: [a] -> Bool
isSingleton [_] = True
isSingleton _ = False
-- | Split a string into seperate strings at a specific character sequence.
split :: Eq a => [a] -> [a] -> [[a]]
split _ [] = [[]]
split at w@(x:xs) = maybe ((x:r):rs) ((:) [] . split at) (L.stripPrefix at w)
where (r:rs) = split at xs
-- | Removes leading and trailing whitespace from a string.
strip :: String -> String
strip = stripWith isSpace
-- | Removes leading whitespace from a string.
stripl :: String -> String
stripl = dropWhile isSpace
-- | Removes trailing whitespace from a string.
stripr :: String -> String
stripr = reverse . dropWhile isSpace . reverse
-- | Strip leading and trailing elements matching a predicate.
stripWith :: (a -> Bool) -> [a] -> [a]
stripWith f = reverse . dropWhile f . reverse . dropWhile f
-- | partition the list of input data into a list of input data lists of
-- approximately the same specified length
partitionListByLength :: Int -> [a] -> [[a]]
partitionListByLength _ [] = []
partitionListByLength count l = take count l : partitionListByLength count (drop count l)
-- | partition the list of input data into a list of a specified number of input data lists with
-- approximately the same length
partitionListByCount :: Int -> [a] -> [[a]]
partitionListByCount = partition
where
partition 0 _ = []
partition sublists l
= let next = (length l `div` sublists)
in if next == 0 then [l]
else take next l : partition (sublists -1) (drop next l)
-- | To use with 'sortBy'.
descending :: Ord a => a -> a -> Ordering
descending = flip compare
-- | Escapes non-alphanumeric or space characters in a String
escape :: String -> String
escape [] = []
escape (c:cs)
= if isAlphaNum c || isSpace c
then c : escape cs
else '%' : showHex (fromEnum c) "" ++ escape cs
-- | Strict version of 'foldM'.
foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
foldM' _ acc [] = return acc
foldM' f acc (x:xs) = do
!acc' <- f acc x
foldM' f acc' xs
-- | 'FB.foldrM' for 'Map' with key.
foldrWithKeyM :: (Monad m) => (k -> a -> b -> m b) -> b -> Map k a -> m b
foldrWithKeyM f b = FB.foldrM (uncurry f) b . M.toList
-- | 'FB.foldlM' for 'Map' with key.
foldlWithKeyM :: (Monad m) => (b -> k -> a -> m b) -> b -> Map k a -> m b
foldlWithKeyM f b = FB.foldlM f' b . M.toList
where f' a = uncurry (f a)
-- | Monadic 'when'.
whenM :: Monad m => m Bool -> m () -> m ()
whenM bm f = bm >>= \b -> when b f
-- ------------------------------------------------------------
-- Aeson helper
-- ------------------------------------------------------------
-- | Like 'Data.Aeson.object' to use with '.=?', '.==' and '.\.'.
-- This allows omitting (default) values in 'ToJSON' instances.
--
-- > toJSON (Example maybe list float) = object' $
-- > [ "maybe" .=? maybe .\. isNothing
-- > , "list" .=? list .\. null
-- > , "float" .=? float .\. (== 1.0)
-- > ]
object' :: [[Pair]] -> Value
object' = object . Prelude.concat
-- | Like '.=' but allows omitting of (default) values in 'ToJSON' instances.
--
-- See 'object''.
(.=?) :: ToJSON a => Text -> (a, a -> Bool) -> [Pair]
name .=? (value, cond) = if cond value then [] else [ name .= value ]
-- | '.==' for 'object''.
--
-- See 'object''.
(.==) :: ToJSON a => Text -> a -> [Pair]
name .== value = [ name .= value ]
-- | Use with '.=?' to specify which value to omit.
--
-- See 'object''.
(.\.) :: ToJSON a => a -> (a -> Bool) -> (a, a -> Bool)
v .\. c = (v,c)
infixl 8 .=?
-- ------------------------------------------------------------