Haskell implementation of FastOrderLine parser

Cli.hs

import Control.Applicative ((<$>))

import Combinable (combineAll)
import LineParser (parseInput)
import Order (Order, orderWithDefaults, removeZeroQty, validate)

main :: IO ()
main = display . parse =<< getContents

parse :: String -> Either String [Order]
parse contents =
    mapM validate
    =<< removeZeroQty
    . combineAll
    <$> parseOrders currentUserId contents

display :: Either String [Order] -> IO ()
display (Left error) = putStrLn error
display (Right orders) = mapM_ print orders

parseOrders :: Int -> String -> Either String [Order]
parseOrders userId = parseInput linePattern match
    where

        match :: [String] -> Maybe Order
        match (ref1:prnum:qty:ref3:ref4:[]) =
            Just $ orderWithDefaults ref1 prnum (read qty) ref3 ref4 userId
        match _ = Nothing

        -- F1234/0/1|11-87-17|1|JOHN DOE|COMPANY
        linePattern = "^(.+/\\d+/\\d+)\\|(\\d\\d-\\d\\d-\\d\\d)\\|(-?\\d+)\\|([^|]+)\\|([^|]+)$"

currentUserId = 6

Combinable.hs

module Combinable (Combinable, combine, combineAll, similar) where

import Data.Sequence ((<|), empty, findIndexL, fromList, Seq, adjust)
import qualified Data.Foldable as Foldable

class Combinable a where
    similar :: Combinable a => a -> a -> Bool
    combine :: Combinable a => a -> a -> a

combineAll :: Combinable a => [a] -> [a]
combineAll = Foldable.toList . Foldable.foldl combineOne empty . fromList

combineOne :: Combinable a => Seq a -> a -> Seq a
combineOne xs x =
    case findIndexL (similar x) xs of
        Just i -> adjust (combine x) i xs
        Nothing -> x <| xs

example_orders

F1234/0/1|11-87-17|1|JOHN DOE|COMPANY
F1234/0/1|11-87-17|1|JOHN DOE|COMPANY
F1234/0/1|11-87-38|1|JOHN DOE|COMPANY
F1234/0/1|11-87-39|1|JOHN DOE|COMPANY
F1234/0/1|11-87-39|-1|JOHN DOE|COMPANY

LineParser.hs

module LineParser (parseInput) where

import Text.Regex.PCRE ((=~), getAllTextSubmatches)

parseInput :: String -> ([String] -> Maybe a) -> String -> Either String [a]
parseInput pattern parser = mapEither (parser . matchLine pattern) . lines

matchLine :: String -> String -> [String]
matchLine pattern line = tail $ getAllTextSubmatches $ line =~ pattern

mapEither :: Show a => (a -> Maybe b) -> [a] -> Either String [b]
mapEither f = mapM (indexMaybeToEither f) . elemsWithIndex
    where elemsWithIndex = zip [1..]

indexMaybeToEither :: Show a => (a -> Maybe b) -> (Int, a) -> Either String b
indexMaybeToEither f (index,input) =
    case f input of
        Nothing -> Left error
        Just result -> Right result
    where error = "Error on " ++ (show index) ++ ": " ++ (show input)

Order.hs

module Order (Order, orderWithDefaults, removeZeroQty, validate) where

import Combinable

data Order = Order {
  vatRate :: Int
, lineVat :: Int
, productId :: Int
, price :: Int
, sellingUnit :: Int
, specialId :: Int
, checkoutref1 :: String
, prnum :: String
, qty :: Int
, checkoutref3 :: String
, checkoutref4 :: String
, userId :: Int
} deriving (Show)

instance Combinable Order where
    combine a b = a { qty = qty a + qty b }
    similar a b = key a == key b

key :: Order -> [String]
key order = map ($ order) [prnum, checkoutref3, checkoutref1]

orderWithDefaults :: String -> String -> Int -> String -> String -> Int -> Order
orderWithDefaults = Order defaultVatRate 0 0 0 1 0

removeZeroQty :: [Order] -> [Order]
removeZeroQty = filter $ (/= 0) . qty

validate :: Order -> Either String Order
validate order
    | qty order < 0 =
        Left "You have a negative quantity(s), please fix it, and retry."
    | otherwise =
        Right order


defaultVatRate = 5