diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright factis research GmbH (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexander Thiemann nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# A collection of commonly used utils + +[![CircleCI](https://circleci.com/gh/factisresearch/opensource-mono.svg?style=svg)](https://circleci.com/gh/factisresearch/opensource-mono) + +This package contains utility functions for data types of basic libraries and common general purpose combinators. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Control/Applicative/Plus.hs b/src/Control/Applicative/Plus.hs new file mode 100644 --- /dev/null +++ b/src/Control/Applicative/Plus.hs @@ -0,0 +1,36 @@ +module Control.Applicative.Plus + ( withOptional + , optional' + , module Control.Applicative + ) +where + +import Control.Applicative +import Control.Monad +import qualified Data.Foldable as F + +{-# SPECIALIZE + withOptional :: (a -> (b -> m c) -> m c) -> Maybe a -> (Maybe b -> m c) -> m c + #-} +withOptional :: + (Foldable t, Alternative t) + => (a -> (b -> m c) -> m c) + -> t a + -> (t b -> m c) + -> m c +withOptional withReq wrappedVal go = + do let runAction = + flip fmap wrappedVal $ \val -> + withReq val $ \inner -> go (pure inner) + emptyCase = go empty + actionOrEmptyCase = + F.foldl' (\_ a -> a) emptyCase runAction + actionOrEmptyCase + +-- | A generalized version of 'optional' that works with 'Option' for example +optional' :: (MonadPlus t, Alternative f) => f a -> f (t a) +optional' x = + flip fmap (optional x) $ \val -> + case val of + Just ok -> pure ok + Nothing -> empty diff --git a/src/Data/List/Plus.hs b/src/Data/List/Plus.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Plus.hs @@ -0,0 +1,233 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Data.List.Plus + ( module Data.List + , catMaybes + , chunksOf + , extractLast + , groupOn + , groupOn' + , groupOnSort + , groupOnSort' + , groupBySort + , groupUnsortedOn + , headM + , lastElems + , lastM + , lookupM + , makeMapping + , mapMaybe + , maximumM + , merge + , middle + , minimumM + , monotone + , nubMerge + , prefixesAndSuffixes + , sconcatBy + , spanTailRec + , stripSuffix + , tryStripPrefix + , ungroupMay + , withLast + ) +where + +import Safe.Plus + +import Control.Arrow (first, second) +import Data.Function +import Data.Hashable (Hashable) +import Data.List +import Data.Maybe (mapMaybe, catMaybes) +import qualified Data.Foldable as F +import qualified Data.HashSet as HashSet +import qualified Data.List as L +import qualified Data.List.NonEmpty as NL +import qualified Data.Semigroup as S + +-- | Computes the element in the middle of the list +-- If the list has an even number of elements, you will get the element after the middle of the +-- list. +middle :: [a] -> Maybe a +middle xs = + case drop (length xs `div` 2) xs of + [] -> Nothing + x:_ -> Just x + +-- O(n) requires a list sorted by the group key +groupOn :: Eq b => (a -> b) -> [a] -> [(b,[a])] +groupOn _ [] = [] +groupOn proj (x:xs) = (x', (x:ys)) : groupOn proj zs + where + x' = proj x + (ys,zs) = span ((==x') . proj) xs + +-- First sort and then group the list +groupOnSort :: Ord b => (a -> b) -> [a] -> [(b,[a])] +groupOnSort proj = groupOn proj . L.sortOn proj + +-- First sort and then group the list +groupBySort :: Ord b => (b -> b -> Ordering) -> (a -> b) -> [a] -> [(b,[a])] +groupBySort cmp proj = groupOn proj . L.sortBy (\x y -> cmp (proj x) (proj y)) + +-- O(n^2) +-- Group the list, but don't sort it +groupUnsortedOn :: forall a b. Eq b => (a -> b) -> [a] -> [(b, [a])] +groupUnsortedOn proj = + L.foldl' (addToGroups) [] + where + addToGroups :: [(b, [a])] -> a -> [(b, [a])] + addToGroups m val = + let key = proj val + in case break ((== key) . fst) m of + (_, []) -> m ++ [(key, [val])] + (p, f:r) -> p ++ [(fst f, snd f ++ [val])] ++ r + +-- O(n) requires a list sorted by the group key +groupOn' :: Eq b => (a -> (b,c)) -> [a] -> [(b,[c])] +groupOn' proj = map (second (map (snd . proj))) . groupOn (fst . proj) + +groupOnSort' :: Ord b => (a -> (b,c)) -> [a] -> [(b,[c])] +groupOnSort' proj = groupOn' proj . L.sortOn (fst . proj) + +sconcatBy :: (Ord b, Foldable f, S.Semigroup s) => (a -> b) -> (a -> s) -> f a -> [(b,s)] +sconcatBy p1 p2 = + fmap proj + . NL.groupBy ((==) `on` p1) + . L.sortOn p1 + . F.toList + where + proj gr = (p1 $ NL.head gr, S.sconcat $ NL.map p2 gr) + +extractLast :: a -> [a] -> ([a], a) +extractLast x xs = + case reverse xs of + [] -> ([], x) + y:ys -> (x : reverse ys, y) + +lastElems :: Int -> [a] -> [a] +lastElems n = + reverse . take n . reverse + +headM :: Monad m => [a] -> m a +headM xs = + case xs of + [] -> safeFail "Cannot compute head of empty list" + x:_ -> return x + +lastM :: Monad m => [a] -> m a +lastM xs = + case xs of + [] -> safeFail "Cannot compute last of empty list" + x:[] -> return x + _:xs -> lastM xs + +withLast :: (a -> a) -> [a] -> [a] +withLast _ [] = [] +withLast f [x] = [f x] +withLast f (x:xs) = x : withLast f xs + +minimumM :: (Monad m, Ord a) => [a] -> m a +minimumM xs = + case xs of + [] -> safeFail "Cannot compute minimum of empty list" + y:ys -> return $ L.foldl' min y ys + +maximumM :: (Monad m, Ord a) => [a] -> m a +maximumM xs = + case xs of + [] -> safeFail "Connot compute maximum of empty list" + y:ys -> return $ L.foldl' max y ys + +lookupM :: (Eq a, Monad m) => (a -> String) -> a -> [(a,b)] -> m b +lookupM str x xs = + case lookup x xs of + Nothing -> + safeFail ("Lookup of " ++ str x ++ " failed. Valid values are: " + ++ show (map (str . fst) xs)) + Just a -> + return a + +ungroupMay :: [(a,[b])] -> Maybe [(a,b)] +ungroupMay [] = Just [] +ungroupMay ((_,[]):_) = Nothing +ungroupMay ((a,bs):rest) = + do r <- ungroupMay rest + return (map ((,) a) bs ++ r) + +-- Returns false if and only if there are elements in decreasing order in the list. +monotone :: (Ord a) => [a] -> Bool +monotone (x0:x1:xs) + | x0 <= x1 = monotone (x1:xs) + | otherwise = False +monotone _ = True + +-- makeMapping takes a list of pairs and create a list of key-value pairs +-- such that each key appears only once in the result list. Moreover, +-- the result list contains the pairs in the same order as the input list. +-- Example: [(k1, v1), (k2, v2), (k1, v3)] --> [(k2, v2), (k1, v3)] +makeMapping :: (Eq a, Hashable a) => [(a, b)] -> [(a, b)] +makeMapping l = + go (reverse l) HashSet.empty [] + where + go [] _ acc = acc + go (x@(k, _) : xs) done acc = + if k `HashSet.member` done + then go xs done acc + else go xs (HashSet.insert k done) (x:acc) + +-- | Merge two sorted list so that the resulting list is sorted as well. +-- and contains all elements from one of the lists. +-- The length of the resulting list is the sum of the lengths of the given lists. +merge :: Ord a => [a] -> [a] -> [a] +merge [] ys = ys +merge xs [] = xs +merge (x:xs) (y:ys) + | x == y = x:y:(merge xs ys) + | x < y = x:(merge xs (y:ys)) + | otherwise = y:(merge (x:xs) ys) + +-- | Merge the two sorted lists and remove all duplicates. +nubMerge :: Ord a => [a] -> [a] -> [a] +nubMerge xs ys = nubSorted $ merge xs ys + where + nubSorted :: Ord a => [a] -> [a] + nubSorted = foldr consUniqSorted [] + + consUniqSorted :: Ord a => a -> [a] -> [a] + consUniqSorted x [] = [x] + consUniqSorted x ys@(y:_) | x == y = ys + | otherwise = x:ys + +chunksOf :: Int -> [a] -> [[a]] +chunksOf n xs = + case splitAt n xs of + ([], _) -> [] + (first, rest) -> first : chunksOf n rest + +stripSuffix :: (Eq a) => [a] -> [a] -> Maybe [a] +stripSuffix s = (fmap reverse) . L.stripPrefix (reverse s) . reverse + +prefixesAndSuffixes :: [a] -> [([a],[a])] +prefixesAndSuffixes a = + case a of + [] -> [([], [])] + (a : r) -> ([], a : r) : map (first (a:)) (prefixesAndSuffixes r) + +-- | Strips as elements of a given prefix list as possible. Stops stripping +-- if the prefix doesn't match anymore or is exhausted and returns the remaining +-- string. +tryStripPrefix :: Eq a => [a] -> [a] -> [a] +tryStripPrefix [] xs = xs +tryStripPrefix _ [] = [] +tryStripPrefix (x:xs) yys@(y:ys) + | x == y = tryStripPrefix xs ys + | otherwise = yys + +spanTailRec :: (a -> Bool) -> [a] -> ([a], [a]) +spanTailRec p xs = go ([], xs) + where go (xs,[]) = (reverse xs, []) + go (xs,(y:ys)) + | p y = go (y : xs, ys) + | otherwise = (reverse xs, y:ys) diff --git a/src/GHC/Stack/Plus.hs b/src/GHC/Stack/Plus.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Plus.hs @@ -0,0 +1,34 @@ +{-| Helper functions for dealing with call stacks and source locations. + -} +module GHC.Stack.Plus + ( callerLocation + , callerFile + , callerLine + , adjustSourceFilePath + ) +where + +import GHC.Stack +import Safe (tailSafe, lastNote) + +adjustSourceFilePath :: FilePath -> FilePath +adjustSourceFilePath = tailSafe . dropWhile (/='/') . drop 1 . dropWhile (/= '/') + +callerLocation :: (HasCallStack) => String +callerLocation = callerFile ++ ":" ++ show callerLine + +-- | The filename of the first caller which called a function with implicit +-- parameter @(callStack :: 'CallStack')@. +callerFile :: (HasCallStack) => String +callerFile = srcLocFile . callerSrcLoc $ callStack + +-- | The line number of the first caller which called a function with +-- implicit parameter @(callStack :: 'CallStack')@. +callerLine :: (HasCallStack) => Int +callerLine = srcLocStartLine . callerSrcLoc $ callStack + +callerSrcLoc :: CallStack -> SrcLoc +callerSrcLoc = snd . caller + +caller :: CallStack -> (String, SrcLoc) +caller = lastNote "Empty CallStack?!" . getCallStack diff --git a/src/Safe/Plus.hs b/src/Safe/Plus.hs new file mode 100644 --- /dev/null +++ b/src/Safe/Plus.hs @@ -0,0 +1,127 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +module Safe.Plus + ( callerFile + , callerLine + , callerLocation + , safeDigitToInt + , safeRead + , readNoteVerbose + , safeFromJust + , safeFromJustNote + , safeHead + , safeTail + , safeInit + , safeLast + , safeMaximum + , safeMinimum + , safeHeadNote + , safeFromRight + , fromRightNote + , safeFromLeft + , fromLeftNote + , safeAtArray + , atArrayNote + , safeAt + , safeError + , safeFail + , safeUndef + ) +where + +import Data.Array.IArray +import Data.Char +import Data.Monoid +import GHC.Stack +import GHC.Stack.Plus +import Safe + +-- | Convert a single digit 'Char' to the corresponding 'Int'. +-- This function fails unless its argument satisfies 'isHexDigit', +-- but recognises both upper and lower-case hexadecimal digits +-- (i.e. @\'0\'@..@\'9\'@, @\'a\'@..@\'f\'@, @\'A\'@..@\'F\'@). +safeDigitToInt :: Monad m => Char -> m Int +safeDigitToInt c + | isDigit c = return $ ord c - ord '0' + | c >= 'a' && c <= 'f' = return $ ord c - ord 'a' + 10 + | c >= 'A' && c <= 'F' = return $ ord c - ord 'A' + 10 + | otherwise = safeFail ("Char.safeDigitToInt: not a digit " ++ show c) + +safeUndef :: (HasCallStack) => a +safeUndef = safeError "undefined!" + +safeRead :: (HasCallStack, Read a) => String -> a +safeRead = readNoteVerbose callerLocation + +readNoteVerbose :: Read a => String -> String -> a +readNoteVerbose msg s = + case [x | (x,t) <- reads s, ("","") <- lex t] of + [x] -> x + [] -> error $ "Prelude.read: no parse, " ++ msg ++ ", on " ++ prefix + _ -> error $ "Prelude.read: ambiguous parse, " ++ msg ++ ", on " ++ prefix + where + prefix = '\"' : a ++ if null b then "\"" else "..." + where (a,b) = splitAt 1024 s + +safeFromJust :: (HasCallStack) => Maybe a -> a +safeFromJust = Safe.fromJustNote callerLocation + +safeFromJustNote :: (HasCallStack) => String -> Maybe a -> a +safeFromJustNote s = Safe.fromJustNote (callerLocation ++ ": " ++ s) + +safeFail :: (HasCallStack, Monad m) => String -> m a +safeFail x = fail (callerLocation ++ ": FAIL: " ++ x) + +safeHead :: (HasCallStack) => [a] -> a +safeHead = Safe.headNote callerLocation + +safeTail :: (HasCallStack) => [a] -> [a] +safeTail = Safe.tailNote callerLocation + +safeInit :: (HasCallStack) => [a] -> [a] +safeInit = Safe.initNote callerLocation + +safeLast :: (HasCallStack) => [a] -> a +safeLast = Safe.lastNote callerLocation + +safeMaximum :: (HasCallStack, Ord a) => [a] -> a +safeMaximum = Safe.maximumNote callerLocation + +safeMinimum :: (HasCallStack, Ord a) => [a] -> a +safeMinimum = Safe.minimumNote callerLocation + +safeHeadNote :: (HasCallStack) => String -> [a] -> a +safeHeadNote x = Safe.headNote (callerLocation ++ ": " ++ x) + +safeFromRight :: (HasCallStack) => Either a b -> b +safeFromRight = fromRightNote callerLocation + +fromRightNote :: String -> Either a b -> b +fromRightNote msg (Left _) = error $ "fromRight got a left value: " ++ msg +fromRightNote _ (Right x) = x + +safeFromLeft :: (HasCallStack) => Either a b -> a +safeFromLeft = fromLeftNote callerLocation + +fromLeftNote :: String -> Either a b -> a +fromLeftNote msg (Right _) = safeError $ "fromLeft got a right value: " ++ msg +fromLeftNote _ (Left x) = x + +safeAtArray :: (HasCallStack, IArray a e, Ix i, Show i) => a i e -> i -> e +safeAtArray = atArrayNote callerLocation + +atArrayNote :: (IArray a e, Ix i, Show i) => String -> a i e -> i -> e +atArrayNote msg array index + | inRange arrayBounds index = array ! index + | otherwise = + error $ concat + [ "lookup at index ", show index, " in an array was outside of its bounds " + , show arrayBounds, ": ", msg + ] + where + arrayBounds = bounds array + +safeAt :: (HasCallStack) => [a] -> Int -> a +safeAt = Safe.atNote callerLocation + +safeError :: (HasCallStack) => String -> a +safeError err = error $ callerLocation <> ": " <> err diff --git a/test/Data/List/PlusSpec.hs b/test/Data/List/PlusSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/List/PlusSpec.hs @@ -0,0 +1,209 @@ +{-# OPTIONS_GHC -F -pgmF htfpp -fno-warn-type-defaults #-} +module Data.List.PlusSpec + ( htf_thisModulesTests + ) +where + +import Data.List.Plus +import Test.Framework +import Test.QuickCheck.Function +import qualified Data.List.Plus as L +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +prop_spanTailRec :: Fun Int Bool -> [Int] -> Bool +prop_spanTailRec (Fun _ f) lst = L.span f lst == spanTailRec f lst + +test_middle :: IO () +test_middle = + do assertNothing (middle ([] :: [Int])) + assertEqual (Just 1) (middle [1]) + assertEqual (Just 2) (middle [1,2]) + assertEqual (Just 2) (middle [1,2,3]) + assertEqual (Just 3) (middle [1,2,3,4]) + +test_tryStripPrefix :: IO () +test_tryStripPrefix = + do assertEqual "foobar" (tryStripPrefix "" "foobar") + assertEqual "" (tryStripPrefix "foobar" "") + assertEqual "z" (tryStripPrefix "foobar" "foobaz") + assertEqual "baz" (tryStripPrefix "foobar" "foobarbaz") + assertEqual "" (tryStripPrefix "foobarbaz" "foobar") + +test_groupUnsortedOn :: IO () +test_groupUnsortedOn = + do assertEqual [] $ groupUnsortedOn id ([] :: [()]) + assertEqual [((), [()])] $ groupUnsortedOn id [()] + assertEqual [((), [(), ()])] $ groupUnsortedOn id [(), ()] + assertEqual [(1, [1]), (0, [2])] $ groupUnsortedOn (`mod` 2) [1, 2] + assertEqual [(0, [2]), (1, [1])] $ groupUnsortedOn (`mod` 2) [2, 1] + assertEqual [(1, [1, 3]), (0, [2, 4])] $ groupUnsortedOn (`mod` 2) [1, 2, 3, 4] + assertEqual [(1, [1, 3]), (0, [2, 4])] $ groupUnsortedOn (`mod` 2) [1, 2, 4, 3] + assertEqual [(0, [2, 4]), (1, [1, 3])] $ groupUnsortedOn (`mod` 2) [2, 1, 4, 3] + +test_groupOnSort :: IO () +test_groupOnSort = + do assertEqual [] $ groupOnSort id ([] :: [()]) + assertEqual [((), [()])] $ groupOnSort id [()] + assertEqual [((), [(), ()])] $ groupOnSort id [(), ()] + assertEqual [(0, [2]), (1, [1])] $ groupOnSort (`mod` 2) [1, 2] + assertEqual [(0, [2]), (1, [1])] $ groupOnSort (`mod` 2) [2, 1] + assertEqual [(0, [2, 4]), (1, [1, 3])] $ groupOnSort (`mod` 2) [1, 2, 3, 4] + assertEqual [(0, [2, 4]), (1, [1, 3])] $ groupOnSort (`mod` 2) [1, 2, 4, 3] + assertEqual [(0, [2, 4]), (1, [1, 3])] $ groupOnSort (`mod` 2) [2, 1, 4, 3] + +test_headM :: IO () +test_headM = + do assertEqual Nothing $ headM ([] :: [()]) + assertEqual (Just ()) $ headM [()] + assertEqual (Just 1) $ headM [1,2] + +test_lastM :: IO () +test_lastM = + do assertEqual Nothing $ lastM ([] :: [()]) + assertEqual (Just ()) $ lastM [()] + assertEqual (Just 2) $ lastM [1,2] + +test_minimumM :: IO () +test_minimumM = + do assertEqual Nothing $ minimumM ([] :: [Int]) + assertEqual (Just 1) $ minimumM [1] + assertEqual (Just 1) $ minimumM [1,2] + assertEqual (Just 1) $ minimumM [2,1] + assertEqual (Just 1) $ minimumM [2,1,2] + +test_maximumM :: IO () +test_maximumM = + do assertEqual Nothing $ maximumM ([] :: [Int]) + assertEqual (Just 2) $ maximumM [2] + assertEqual (Just 2) $ maximumM [2,1] + assertEqual (Just 2) $ maximumM [1,2] + assertEqual (Just 2) $ maximumM [1,2,1] + +test_merge :: IO () +test_merge = + do assertEqual [1, 2, 3, 4, 5] $ nubMerge as bs + assertEqual [] $ nubMerge empty empty + assertEqual [1] $ nubMerge one empty + assertEqual [1] $ nubMerge empty one + assertEqual [1, 2, 3] $ nubMerge cs cs + assertEqual [1, 2, 3, 4, 5, 6] $ nubMerge cs ds + assertEqual [1, 2, 3, 4, 5, 6] $ nubMerge es fs + assertEqual [1] $ nubMerge two one + assertEqual [1] $ nubMerge one two + assertEqual [1] $ nubMerge three empty + assertEqual [1] $ nubMerge empty three + + assertEqual [1, 2, 2, 3, 4, 4, 5] $ merge as bs + assertEqual [] $ merge empty empty + assertEqual [1] $ merge one empty + assertEqual [1] $ merge empty one + assertEqual [1, 1, 2, 2, 3, 3] $ merge cs cs + assertEqual [1, 2, 3, 4, 5, 6] $ merge cs ds + assertEqual [1, 2, 3, 4, 5, 6] $ merge es fs + assertEqual [1, 1, 1] $ merge two one + assertEqual [1, 1, 1] $ merge one two + assertEqual [1, 1, 1] $ merge three empty + assertEqual [1, 1, 1] $ merge empty three + where + empty, one, two, three, as, bs, cs, ds, es, fs :: [Int] + as = [1, 2, 3, 4] + bs = [2, 4, 5] + cs = [1, 2, 3] + ds = [4, 5, 6] + es = [1, 3, 5] + fs = [2, 4, 6] + empty = [] + one = [1] + two = [1, 1] + three = [1, 1, 1] + + +test_ungroup :: IO () +test_ungroup = + assertEqual (Just [("a","1"),("a","2"),("a","3"),("b","4")]) + $ ungroupMay [("a",["1","2","3"]),("b",["4"])] + +test_ungroupGroup :: IO () +test_ungroupGroup = + do let list = [("x","1"),("y","1"),("y","3"),("y","1")] + assertEqual (Just list) (ungroupMay $ groupOn' id list) + +test_stripSuffix :: IO () +test_stripSuffix = + do assertEqual (Just "foo") $ stripSuffix "bar" "foobar" + assertEqual (Just "") $ stripSuffix "bar" "bar" + assertEqual Nothing $ stripSuffix "bar" "foobars" + +test_monotone :: IO () +test_monotone = + do assertEqual True $ monotone [1,2,3] + assertEqual False $ monotone [-1,0,3,2] + assertEqual True $ monotone [1] + assertEqual True $ monotone ([] :: [Int]) + +test_lastElems :: IO () +test_lastElems = + do assertEqual ([]::[Int]) (lastElems 100 []) + assertEqual [1,2,3] (lastElems 5 [1,2,3]) + assertEqual [1,2,3] (lastElems 3 [1,2,3]) + assertEqual [2,3] (lastElems 2 [1,2,3]) + + +prop_lastElems :: [Int] -> Int -> Bool +prop_lastElems l n = + lastElems n l `L.isSuffixOf` l + +test_makeMapping :: IO () +test_makeMapping = + do assertEqual [] (makeMapping ([]::[(Int, String)])) + let l = [(1::Int, "one"), (2, "two")] in assertEqual l (makeMapping l) + assertEqual [(2::Int, "two"), (1, "three")] + (makeMapping [(1, "one"), (2, "two"), (1, "three")]) + assertEqual [(1::Int, "x")] (makeMapping [(1,"x"),(1,"x")]) + let l2 = [(-2,""),(-2,"a"),(-2,"")] + assertBool $ checkOrder (makeMapping l2) l2 + +test_chunksOf :: IO () +test_chunksOf = + do assertEqual [] (chunksOf 1 ([] :: [Int])) + assertEqual [] (chunksOf 0 [1]) + assertEqual [[1], [2], [3], [4]] (chunksOf 1 [1, 2, 3, 4]) + assertEqual [[1, 2], [3, 4]] (chunksOf 2 [1, 2, 3, 4]) + assertEqual [[1, 2], [3]] (chunksOf 2 [1, 2, 3]) + assertEqual [[1, 2, 3]] (chunksOf 3 [1, 2, 3]) + +test_prefixesAndSuffixes :: IO () +test_prefixesAndSuffixes = + do assertEqual (prefixesAndSuffixes "") [("","")] + assertEqual (prefixesAndSuffixes "Hallo") + [("","Hallo"), ("H","allo"),("Ha","llo"),("Hal","lo"),("Hall","o"),("Hallo","")] + +prop_makeMappingConcat :: [(Int, String)] -> Bool +prop_makeMappingConcat l = + makeMapping l == makeMapping (l ++ l) + +prop_makeMappingKeysUnique :: [(Int, String)] -> Bool +prop_makeMappingKeysUnique l = + length (map fst (makeMapping l)) == Set.size (Set.fromList (map fst l)) + +prop_makeMappingKeyValsOk :: [(Int, String)] -> Bool +prop_makeMappingKeyValsOk l = + Map.fromList (makeMapping l) == Map.fromList l + +prop_makeMappingOrderingOk :: [(Int, String)] -> Bool +prop_makeMappingOrderingOk l = + checkOrder (makeMapping l) l + +checkOrder :: [(Int, String)] -> [(Int, String)] -> Bool +checkOrder [] [] = True +checkOrder (x:xs) (y:ys) + | x == y = checkOrder xs (dropWhile ((fst x ==) . fst) ys) + | otherwise = checkOrder (x:xs) ys +checkOrder _ _ = False + +test_withLast :: IO () +test_withLast = + do assertEqual [] (withLast not []) + assertEqual [False] (withLast not [True]) + assertEqual [True,False] (withLast not [True,True]) diff --git a/test/GHC/Stack/PlusSpec.hs b/test/GHC/Stack/PlusSpec.hs new file mode 100644 --- /dev/null +++ b/test/GHC/Stack/PlusSpec.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +module GHC.Stack.PlusSpec + ( htf_thisModulesTests + ) +where + +import GHC.Stack.Plus +import Test.Framework + +test_callerSrcLoc :: IO () +test_callerSrcLoc = + do assertEqual __FILE__ callerFile + assertEqual __LINE__ callerLine diff --git a/test/Safe/PlusSpec.hs b/test/Safe/PlusSpec.hs new file mode 100644 --- /dev/null +++ b/test/Safe/PlusSpec.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +module Safe.PlusSpec where + +import GHC.Exception +import Safe.Plus +import Test.Framework + +test_safeError :: IO () +test_safeError = + assertThrows (safeError msg) (matches (format __FILE__ __LINE__)) + where + matches expected (ErrorCallWithLocation actual _) = expected == actual + format :: String -> Int -> String + format file line = file ++ ":" ++ show line ++ ": " ++ msg + msg = "error message" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +module Main where + +import {-@ HTF_TESTS @-} Data.List.PlusSpec +import {-@ HTF_TESTS @-} GHC.Stack.PlusSpec +import {-@ HTF_TESTS @-} Safe.PlusSpec + +import Test.Framework + +main :: IO () +main = htfMain htf_importedTests diff --git a/util-plus.cabal b/util-plus.cabal new file mode 100644 --- /dev/null +++ b/util-plus.cabal @@ -0,0 +1,49 @@ +name: util-plus +version: 0.1.0.0 +synopsis: A collection of commonly used utils +description: A collection of commonly used util functions for basic libaries +homepage: https://github.com/factisresearch/opensource-mono#readme +license: BSD3 +license-file: LICENSE +author: factis research GmbH +maintainer: mail@athiemann.net +copyright: 2017 factis research GmbH +category: Data +build-type: Simple +extra-source-files: + README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: GHC.Stack.Plus + , Safe.Plus + , Data.List.Plus + , Control.Applicative.Plus + build-depends: base >= 4.7 && < 5 + , safe + , array + , hashable + , containers + , unordered-containers + default-language: Haskell2010 + ghc-options: -Wall + +test-suite util-plus-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: GHC.Stack.PlusSpec + , Safe.PlusSpec + , Data.List.PlusSpec + build-depends: base >= 4.7 && < 5 + , HTF + , QuickCheck + , containers + , util-plus + ghc-options: -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/factisresearch/opensource-mono