haskellMonoid

-- | Total all salaries in a company
total :: Company -> Float
total (n, ds) = getSum (mconcat (map totalD ds))
  where
    -- Total all salaries in a department
    totalD :: Department -> Sum Float
    totalD (Department _ m ds es)
      = mconcat (totalE m : map totalD ds ++ map totalE es)
      where
        -- Extract the salary from an employee
        totalE :: Employee -> Sum Float
        totalE (_, _, s) = Sum s

{-| A data model for the 101companies System -}

module Company.Data where

-- | A company consists of name and top-level departments
type Company = (Name, [Department])

-- | A department consists of name, manager, sub-departments, and employees
data Department = Department Name Manager [Department] [Employee]
 deriving (Eq, Read, Show)

-- | An employee consists of name, address, and salary
type Employee = (Name, Address, Salary)

-- | Managers as employees
type Manager = Employee

-- | Names of companies, departments, and employees
type Name = String

-- | Addresses as strings
type Address = String

-- | Salaries as floats
type Salary = Float

{- | Sample data of the 101companies System -}

module Company.Sample where

import Company.Data

-- | A sample company useful for basic tests
sampleCompany :: Company
sampleCompany =
  ( "Acme Corporation",
    [
      Department "Research"
        ("Craig", "Redmond", 123456)
        []
        [
          ("Erik", "Utrecht", 12345),
          ("Ralf", "Koblenz", 1234)
        ],
      Department "Development"
        ("Ray", "Redmond", 234567)
        [
          Department "Dev1"
            ("Klaus", "Boston", 23456)
            [
              Department "Dev1.1"
                ("Karl", "Riga", 2345)
                []
                [("Joe", "Wifi City", 2344)]
            ]
            []
        ]
        []
    ]
  )

{-| The operation of totaling all salaries of all employees in a company -}

module Company.Total where

import Company.Data
import Data.Monoid

-- | Total all salaries in a company
total :: Company -> Float
total (n, ds) = getSum (mconcat (map totalD ds))
  where
    -- Total all salaries in a department
    totalD :: Department -> Sum Float
    totalD (Department _ m ds es)
      = mconcat (totalE m : map totalD ds ++ map totalE es)
      where
        -- Extract the salary from an employee
        totalE :: Employee -> Sum Float
        totalE (_, _, s) = Sum s

{-| The operation to compute the nesting depth of departments in a company -}

module Company.Depth where

import Company.Data
import Data.Monoid
import Data.Max

-- | Compute the nesting depth of a company
depth :: Company -> Int
depth (_, ds) = max' (map depth' ds)
  where
    -- Maximum of a list of natural numbers
    max' = maybe 0 id . getMax . mconcat 
    -- Helper at the department level
    depth' :: Department -> Max Int
    depth' (Department _ _ ds _) = setMax (1 + max' (map depth' ds))

{-| The constraint to check that salaries follow ranks in company hierarchy -}

module Company.Ranking where

import Company.Data
import Data.Monoid
import Data.Max

-- | Check that salaries follow ranks in company hierarchy
ranking :: Company -> Bool
ranking (_, ds) = and (map ranking' ds)
  where
    -- Helper at the department level
    ranking' :: Department -> Bool
    ranking' (Department _ m ds es)
        =  and (map ranking' ds)
        && maybe True (<getSalary m) (getMax subunits)
      where
        -- Maximum of salaries for immediate employees
        employees :: Max Float
        employees = mconcat (map (setMax . getSalary) es)
        -- Maximum of salaries for immediate sub-departments' managers
        managers :: Max Float
        managers = mconcat (map (setMax . getManagerSalary) ds)
        -- "employees" and "managers" combined       
        subunits :: Max Float
        subunits = managers `mappend` employees
    -- Extract the salary of a department's manager
    getManagerSalary :: Department -> Float
    getManagerSalary (Department _ m _ _) = getSalary m
    -- Extract the salary of an employee
    getSalary :: Employee -> Float
    getSalary (_, _, s) = s

-- | A company that violates the ranking constraint
rankingFailSample =
  ( "Fail Industries",
    [ Department "Failure"
        ("Ubermanager", "Top Floor", 100)
        []
        [("Joe Programmer", "Basement", 1000)]
    ]
  )

{-| A monoid for optional maxima -}

module Data.Max (
  Max,
  getMax,
  setMax,
  noMax
) where

import Data.Monoid

-- | A data type for maxima without default
data Ord x => 
     Max x = Max {
       -- | Retrieve maximum, if any
       getMax :: Maybe x 
     }

-- | Set max to "just" a value
setMax :: Ord x => x -> Max x
setMax = Max . Just

-- | The absent maximum
noMax :: Ord x => Max x
noMax = Max { getMax = Nothing }

-- | A monoid for maxima
instance Ord x => Monoid (Max x)
  where
    mempty = Max Nothing
    x `mappend` y
      = case (getMax x, getMax y) of
          (Nothing, m) -> Max m
          (m, Nothing) -> Max m
          (Just m1, Just m2) -> Max (Just (m1 `max` m2))

{-| Tests for the 101companies System -}

module Main where

import Company.Data
import Company.Sample
import Company.Total
import Company.Depth
import Company.Ranking
import Test.HUnit
import System.Exit

-- | Compare salary total of sample company with baseline
totalTest = 399747.0 ~=? total sampleCompany

-- | Compare depth of sample company with baseline
depthTest = 3 ~=? depth sampleCompany

-- | Check ranking constraint for salaries of sample company
rankingOkTest =  True ~=? ranking sampleCompany

-- | Negative test case for ranking constraint
rankingFailTest = False ~=? ranking rankingFailSample

-- | Test for round-tripping of de-/serialization of sample company
serializationTest = sampleCompany ~=? read (show sampleCompany)

-- | The list of tests
tests =
  TestList [
    TestLabel "total" totalTest,
    TestLabel "depth" depthTest,
    TestLabel "rankingOk" rankingOkTest,
    TestLabel "rankingFail" rankingFailTest,
    TestLabel "serialization" serializationTest
  ]

-- | Run all tests and communicate through exit code
main = do
 counts <- runTestTT tests
 if (errors counts > 0 || failures counts > 0)
   then exitFailure
   else exitSuccess

{-| A data model for the 101companies System -}

module Company.Data where

-- | A company consists of name and top-level departments
type Company = (Name, [Department])

-- | A department consists of name, manager, sub-departments, and employees
data Department = Department Name Manager [Department] [Employee]
 deriving (Eq, Read, Show)

-- | An employee consists of name, address, and salary
type Employee = (Name, Address, Salary)

-- | Managers as employees
type Manager = Employee

-- | Names of companies, departments, and employees
type Name = String

-- | Addresses as strings
type Address = String

-- | Salaries as floats
type Salary = Float