X.hs

{-# LANGUAGE Haskell2010, Safe #-}
{-# OPTIONS -Wall #-}

-- |
-- Module       : Haskell.X
-- Copyright    : (c) Julian Fleischer 2013
-- License      : MIT (See LICENSE file in cabal package)
--
-- Maintainer   : julian.fleischer@fu-berlin.de
-- Stability    : provisional
-- Portability  : portable
--
-- Haskell extra utility functions. Best imported by @import qualified Haskell.X as X@.
module Haskell.X where

import Prelude
import Data.Char
import Data.List
import Data.Ord
import Control.Arrow

-- | Apply a function exhaustively.
exhaustively :: Eq a => (a -> a) -> a -> a
exhaustively = exhaustivelyBy (==)

-- | Apply a function exhaustively.
exhaustivelyBy :: (a -> a -> Bool) -> (a -> a) -> a -> a
exhaustivelyBy predicate func dat = case predicate dat result of
    True -> result
    False -> exhaustivelyBy predicate func result
  where result = func dat

-- | Apply a monadic function exhaustively.
exhaustivelyM :: (Eq a, Monad m) => (a -> m a) -> a -> m a
exhaustivelyM = exhaustivelyByM (==)

-- | Apply a monadic function exhaustively.
exhaustivelyByM :: Monad m => (a -> a -> Bool) -> (a -> m a) -> a -> m a
exhaustivelyByM predicate func dat = do
    result <- func dat
    case predicate dat result of
        True -> return result
        False -> exhaustivelyByM predicate func result

-- | Sort a list and leave out duplicates. Like @nub . sort@ but faster.
uniqSort :: (Ord a) => [a] -> [a]
uniqSort = map head . group . sort

-- | Sort, then group
aggregateBy :: (a -> a -> Ordering) -> [a] -> [[a]]
aggregateBy x = groupBy (\a b -> x a b == EQ) . sortBy x

-- | Sort, then group
aggregate :: (Ord a) => [a] -> [[a]]
aggregate = aggregateBy compare

-- | Aggregate an association list, such that keys become unique.
--
-- (c) 
aggregateAL :: (Ord a) => [(a,b)] -> [(a,[b])]
aggregateAL = map (fst . head &&& map snd) . aggregateBy (comparing fst)

-- | Replace all occurences of a specific thing in a list of things another thing. 
tr :: Eq a => a -> a -> [a] -> [a]
tr n r (x:xs)
    | x == n = r : tr n r xs
    | otherwise = x : tr n r xs
tr _ _ [] = []

-- | Counts how many elements there are in a 4 levels deep list.
count4 :: [[[[a]]]] -> Int
count4 = sum . map (sum . map (sum . map length))

-- | Counts how many elements there are in a 3 levels deep list.
count3 :: [[[a]]] -> Int
count3 = sum . map (sum . map length)

-- | Counts how many elements there are in a 2 levels deep list.
count2 :: [[a]] -> Int
count2 = sum . map length

-- | Counts how many elements there are in a 1 level deep list.
count1 :: [a] -> Int
count1 = length

-- | Segments the elements of a 3 levels deep list such that
-- the segments contain at least the specified amount of elements,
-- without breaking apart any subsegments.
segment3 :: Int -> [[[a]]] -> [[a]]
segment3 _    [] = []
segment3 size as = if null segments then [concatMap concat as]
                                    else concatMap concat segment : segment3 size rest
  where
    segmentations = zip (inits as) (tails as)
    segments = dropWhile ((< size) . count3 . fst) segmentations
    (segment, rest) = head segments

-- | Segments the elements of a 2 levels deep list such that
-- the segments contain at least the specified amount of elements,
-- without breaking apart any subsegments.
segment2 :: Int -> [[a]] -> [[a]]
segment2 _    [] = []
segment2 size as = if null segments then [concat as]
                                    else concat segment : segment2 size rest
  where
    segmentations = zip (inits as) (tails as)
    segments = dropWhile ((< size) . count2 . fst) segmentations
    (segment, rest) = head segments

-- | @breakLast xs == (init xs, last xs)@
breakLast :: [a] -> ([a], a)
breakLast [a] = ([], a)
breakLast (a:as) =
    let (init', last') = breakLast as
    in  (a:init', last')
breakLast _ = error "Haskell.X.breakLast: empty list"

-- | If an Either contains the same types in Left and Right,
-- unify it by dropping the Either wrapper.
uneither :: Either a a -> a
uneither = either id id


data Version = Version {
    versionBranch :: [Integer],
    versionTags :: [String]
  } deriving (Eq, Ord)

instance Read Version where
    readsPrec _ = parseVersion

instance Show Version where
    showsPrec _ (Version branch tags) xs
      = tail (concatMap (('.':) . show) branch) ++ concatMap ('-':) tags ++ xs

parseVersion :: String -> [(Version, String)]
parseVersion string =
    let (digits, tagRest) = parseBranch string
        (tags, rest) = parseTags tagRest
    in if null digits then [] else [(Version (map read digits) tags, rest)]
  where
    parseBranch str =
        let next = span isDigit str
        in case next of
            ("", rest) -> ([], rest)
            (ds, '.':rest) -> let (dss, rest') = parseBranch rest
                              in  (ds : dss, rest')
            (ds, rest) -> ([ds], rest)

    parseTags ('-':str) =
        let next = span isAlphaNum str
        in case next of
            ("", rest) -> ([], rest)
            (xs, rest) -> let (xss, rest') = parseTags rest
                              in  (xs : xss, rest')
    parseTags xs = ([], xs)