NumberRange.hs

{-# LANGUAGE MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
-- Copyright 2019, Advise-Me 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)
--
-- Data type for ranges of numbers.
--
-----------------------------------------------------------------------------

module Util.NumberRange (NumberRange, range) where

import Control.Monad (forM)
import Data.Semigroup
import Util.String (split)
import Util.List (groupBy')
import Data.List (sort, nub, intercalate)
import Database.HDBC (SqlValue, fromSql, toSql)
import Data.Convertible.Base (Convertible, safeConvert, convError)
import Ideas.Utils.Prelude (readM)

newtype NumberRange = NumberRange [Int]

range :: [Int] -> NumberRange
range = NumberRange . nub

instance Semigroup NumberRange where
   (NumberRange r1) <> (NumberRange r2) = NumberRange . nub $ r1 ++ r2

instance Monoid NumberRange where
   mempty  = NumberRange []
   mappend = (<>)

instance Show NumberRange where
   show (NumberRange range) 
      = intercalate "," 
      . map f 
      . groupBy' (\x y -> abs (x - y) == 1) 
      . sort
      $ range
  
      where 
      f [] = show ""
      f [x] = show x
      f xs = show (head xs) ++ "-" ++ show (last xs)

instance Convertible NumberRange SqlValue where
   safeConvert = Right . toSql . show

instance Convertible SqlValue NumberRange where
   safeConvert sql = either (flip convError sql) Right $ do
      let string = fromSql sql
      ranges <- forM (split ',' string) $ \range ->
         case split '-' range of
            [i] -> do
               i' <- readM i
               return [i']
            [i,j] -> do
               i' <- readM i
               j' <- readM j
               return [i'..j']
            _ -> fail "number range could not be parsed"
      return . NumberRange . concat $ ranges