diff --git a/src/Ganeti/Utils.hs b/src/Ganeti/Utils.hs index 0ff1984aabfd7a665ad5390a86901757f0418698..b4a8c3cacfbadee13e0c265399ccfb8e1903b5a9 100644 --- a/src/Ganeti/Utils.hs +++ b/src/Ganeti/Utils.hs @@ -53,11 +53,14 @@ module Ganeti.Utils , trim , defaultHead , exitIfEmpty + , splitEithers + , recombineEithers ) where import Data.Char (toUpper, isAlphaNum, isDigit, isSpace) import Data.Function (on) import Data.List +import Control.Monad (foldM) import Debug.Trace @@ -382,3 +385,44 @@ defaultHead _ (x:_) = x exitIfEmpty :: String -> [a] -> IO a exitIfEmpty _ (x:_) = return x exitIfEmpty s [] = exitErr s + +-- | Split an 'Either' list into two separate lists (containing the +-- 'Left' and 'Right' elements, plus a \"trail\" list that allows +-- recombination later. +-- +-- This is splitter; for recombination, look at 'recombineEithers'. +-- The sum of \"left\" and \"right\" lists should be equal to the +-- original list length, and the trail list should be the same length +-- as well. The entries in the resulting lists are reversed in +-- comparison with the original list. +splitEithers :: [Either a b] -> ([a], [b], [Bool]) +splitEithers = foldl' splitter ([], [], []) + where splitter (l, r, t) e = + case e of + Left v -> (v:l, r, False:t) + Right v -> (l, v:r, True:t) + +-- | Recombines two \"left\" and \"right\" lists using a \"trail\" +-- list into a single 'Either' list. +-- +-- This is the counterpart to 'splitEithers'. It does the opposite +-- transformation, and the output list will be the reverse of the +-- input lists. Since 'splitEithers' also reverses the lists, calling +-- these together will result in the original list. +-- +-- Mismatches in the structure of the lists (e.g. inconsistent +-- lengths) are represented via 'Bad'; normally this function should +-- not fail, if lists are passed as generated by 'splitEithers'. +recombineEithers :: (Show a, Show b) => + [a] -> [b] -> [Bool] -> Result [Either a b] +recombineEithers lefts rights trail = + foldM recombiner ([], lefts, rights) trail >>= checker + where checker (eithers, [], []) = Ok eithers + checker (_, lefts', rights') = + Bad $ "Inconsistent results after recombination, l'=" ++ + show lefts' ++ ", r'=" ++ show rights' + recombiner (es, l:ls, rs) False = Ok (Left l:es, ls, rs) + recombiner (es, ls, r:rs) True = Ok (Right r:es, ls, rs) + recombiner (_, ls, rs) t = Bad $ "Inconsistent trail log: l=" ++ + show ls ++ ", r=" ++ show rs ++ ",t=" ++ + show t diff --git a/test/hs/Test/Ganeti/Utils.hs b/test/hs/Test/Ganeti/Utils.hs index 28610ae2ba8d9a1b117f55d170677e7c924ff60d..8436cd3421b813e2ce8c5aa57e58b4853e50ac17 100644 --- a/test/hs/Test/Ganeti/Utils.hs +++ b/test/hs/Test/Ganeti/Utils.hs @@ -32,6 +32,7 @@ import Test.QuickCheck hiding (Result) import Test.HUnit import Data.Char (isSpace) +import qualified Data.Either as Either import Data.List import System.Time import qualified Text.JSON as J @@ -294,6 +295,29 @@ prop_trim (NonEmpty str) = trim "" ==? "" ] +-- | Tests 'splitEithers' and 'recombineEithers'. +prop_splitRecombineEithers :: [Either Int Int] -> Property +prop_splitRecombineEithers es = + conjoin + [ printTestCase "only lefts are mapped correctly" $ + splitEithers (map Left lefts) ==? (reverse lefts, emptylist, falses) + , printTestCase "only rights are mapped correctly" $ + splitEithers (map Right rights) ==? (emptylist, reverse rights, trues) + , printTestCase "recombination is no-op" $ + recombineEithers splitleft splitright trail ==? Ok es + , printTestCase "fail on too long lefts" $ + isBad (recombineEithers (0:splitleft) splitright trail) + , printTestCase "fail on too long rights" $ + isBad (recombineEithers splitleft (0:splitright) trail) + , printTestCase "fail on too long trail" $ + isBad (recombineEithers splitleft splitright (True:trail)) + ] + where (lefts, rights) = Either.partitionEithers es + falses = map (const False) lefts + trues = map (const True) rights + (splitleft, splitright, trail) = splitEithers es + emptylist = []::[Int] + -- | Test list for the Utils module. testSuite "Utils" [ 'prop_commaJoinSplit @@ -319,4 +343,5 @@ testSuite "Utils" , 'prop_chompPrefix_last , 'prop_chompPrefix_empty_string , 'prop_chompPrefix_nothing + , 'prop_splitRecombineEithers ]