haskellTree

Headline

Data processing in Language:Haskell with functors and foldable types

The data structure of a company is converted to a leaf-labeled rose tree which preserves the tree-like shape of the input but otherwise only represents the salary values at the leaves. Thus, names and other properties of departments and employees are not exposed. Such trees are declared as a functor and a foldable type. A bidirectional transformation is then employed to model a salary cut. That is, the company structure is converted to the leaf-labeled tree, then, in turn, to a list, on which to perform salary cut so that finally the modified salaries are integrated back into the company structure.

Illustration

Consider the following sample company:

sampleCompany :: Company
sampleCompany =
  Company
    "Acme Corporation"
    [
      Department "Research"
        (Employee "Craig" "Redmond" 123456)
        []
        [
          (Employee "Erik" "Utrecht" 12345),
          (Employee "Ralf" "Koblenz" 1234)
        ],
      Department "Development"
        (Employee "Ray" "Redmond" 234567)
        [
          Department "Dev1"
            (Employee "Klaus" "Boston" 23456)
            [
              Department "Dev1.1"
                (Employee "Karl" "Riga" 2345)
                []
                [(Employee "Joe" "Wifi City" 2344)]
            ]
            []
        ]
        []
    ]

When converted to a leaf-labeled rose tree, the sample company looks as follows:

sampleTree :: LLTree Float
sampleTree =
  Fork [
    Fork [
      Leaf 123456.0,
      Leaf 12345.0,
      Leaf 1234.0],
    Fork [
      Leaf 234567.0,
      Fork [
        Leaf 23456.0,
        Fork [
          Leaf 2345.0,
          Leaf 2344.0]]]]

Here is the corresponding conversion function; it is a get function in the terminology of bidirectional transformation:

get :: Company -> LLTree Float
get (Company n ds) = Fork (map getD ds)
  where
    getD :: Department -> LLTree Float
    getD (Department n m ds es) =  Fork (   [getE m]
                                         ++ map getD ds
                                         ++ map getE es )
      where
        getE :: Employee -> LLTree Float
        getE (Employee     s) = Leaf s

Because LLTree is a foldable type, it is trivial to further convert the tree to a plain list. Accordingly, salary cut can be expressed at the level of lists. The modified salaries are then put back into the tree with a put function, which we skip here for brevity.

cut :: Company -> Company
cut c = put fs' c
  where
    fs = toList (get c)
    fs' = map (/2) fs

Architecture

There are these modules:

A data model for Feature:Hierarchical company

module Company.Data where

data Company = Company Name [Department]
 deriving (Eq, Read, Show)
data Department = Department Name Manager [Department] [Employee]
 deriving (Eq, Read, Show)
data Employee = Employee Name Address Salary
 deriving (Eq, Read, Show)
type Manager = Employee
type Name = String
type Address = String
type Salary = Float

A sample company

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

module Company.Sample where

import Company.Data

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

The implementation of Feature:Total

module Company.Total where

import Company.Data
import Company.BX
import Data.Foldable
import Data.Monoid

total :: Company -> Float
total = getSum . foldMap Sum . get

The implementation of Feature:Cut

module Company.Cut where

import Company.Data
import Company.BX
import Data.Foldable
import Data.Monoid

cut :: Company -> Company
cut c = put fs' c
  where
    fs = toList (get c)
    fs' = map (/2) fs

A bidirectional transformation

module Company.BX where

import Company.Data
import Data.LLTree
import Data.List

get :: Company -> LLTree Float
get (Company n ds) = Fork (map getD ds)
  where
    getD :: Department -> LLTree Float
    getD (Department n m ds es) =  Fork (   [getE m]
                                         ++ map getD ds
                                         ++ map getE es )
      where
        getE :: Employee -> LLTree Float
        getE (Employee _ _ s) = Leaf s

put :: [Float] -> Company -> Company
put fs (Company n ds) = Company n ds'
  where
    ([], ds') = mapAccumL putD fs ds
    putD :: [Float] -> Department -> ([Float], Department)
    putD fs (Department n m ds es) = (fs''', Department n m' ds' es')
      where
        (fs', m') = putE fs m
        (fs'', ds') = mapAccumL putD fs' ds
        (fs''', es') = mapAccumL putE fs'' es
        putE :: [Float] -> Employee -> ([Float], Employee)
        putE (f:fs) (Employee n a s) = (fs, Employee n a f)

Leaf-labeled rose trees

-- Leaf-labeled rose trees

module Data.LLTree where

import Prelude hiding (foldr, concat)
import Data.Functor
import Data.Foldable

data LLTree a = Leaf a | Fork [LLTree a]
  deriving (Eq, Show, Read)

instance Functor LLTree
  where
    fmap f (Leaf a) = Leaf (f a)
    fmap f (Fork ts) = Fork (fmap (fmap f) ts)

instance Foldable LLTree
  where
    foldr f z (Leaf a) = f a z
    foldr f z (Fork ts) = foldr f z (concat (fmap toList ts))

Tests

module Main where

import Company.Data
import Company.Sample
import Company.BX
import Company.Total
import Company.Cut
import Data.LLTree
import Data.Foldable (toList)
import Test.HUnit
import System.Exit

sampleTree :: LLTree Float
sampleTree =
  Fork [
    Fork [
      Leaf 123456.0,
      Leaf 12345.0,
      Leaf 1234.0],
    Fork [
      Leaf 234567.0,
      Fork [
        Leaf 23456.0,
        Fork [
          Leaf 2345.0,
          Leaf 2344.0]]]]

sampleTreeList = [123456.0,12345.0,1234.0,234567.0,23456.0,2345.0,2344.0]

totalTest = 399747.0 ~=? total sampleCompany

cutTest = 199873.5 ~=? total (cut sampleCompany)

serializationTest = sampleCompany ~=? read (show sampleCompany)

getTreeTest = sampleTree ~=? get sampleCompany

getTreeListTest = sampleTreeList ~=? toList (get sampleCompany)

tests =
  TestList [
    TestLabel "total" totalTest,
    TestLabel "cut" cutTest,
    TestLabel "serialization" serializationTest,
    TestLabel "getTree" getTreeTest,
    TestLabel "getTreeList" getTreeListTest
  ]

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

The types of

module Company.Data where

data Company = Company Name [Department]
 deriving (Eq, Read, Show)
data Department = Department Name Manager [Department] [Employee]
 deriving (Eq, Read, Show)
data Employee = Employee Name Address Salary
 deriving (Eq, Read, Show)
type Manager = Employee
type Name = String
type Address = String
type Salary = Float