A simple utility to parse a CSV file listing pairs, and find relations between said pairs.

FindRelations.hs

#!/usr/bin/env stack
-- stack --resolver lts-7.10 --install-ghc runghc
--  --package text
--  --package bytestring
--  --package containers
--  --package cassava
--  --package generics
--  --package vector
{-# LANGUAGE DeriveGeneric #-}
-- |
-- Module      :  Main
-- Copyright   :  (c) Jan de Muijnck-Hughes 2016
-- License     :  BSD 3 Clause see https://opensource.org/licenses/BSD-3-Clause
--
-- Maintainer  :  Jan de Muijnck-Hughes
-- Stability   :  stable
-- Portability :  portable
--
-- Utility script to display the relations between name-email pairings from git log entries.
-- The script takes as its argument a file of the form:
--
--    ```
--    <name>,<email>
--    ```
--
-- As generated by the command:
--
--    ```
--    git log --format='%aN, %aE' | sort -u
--    ```
--
-- The result will be a pretty tree showing the links between names and emails.
--
-- Distributed as is, YMMV.
--
-- Graphs are cool, scripting in Haskell is cool once you get past `ByteString` and `Text`.
module Main where

import GHC.Generics

import Control.Monad
import System.IO
import System.Exit
import System.Environment

import Data.Graph
import Data.Tree
import Data.Maybe
import Data.List
import qualified Data.List as L
import Data.Csv
import Data.Vector (Vector)
import qualified Data.Vector as V

import qualified Data.ByteString.Lazy as BS

import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T

type List a = [a]

data Contributor = Contributor
  { name  :: !Text
  , email :: !Text
  } deriving (Show, Generic)

instance FromRecord Contributor
instance ToRecord   Contributor

processArgs :: List String -> IO String
processArgs []    = exitFailure
processArgs (x:_) = pure x

cleanRecord :: Contributor -> Contributor
cleanRecord (Contributor n e) = Contributor (T.strip n) (T.strip e)

mkDesc :: Contributor -> List (Text, List Text)
mkDesc (Contributor n e) = [(n,[e]), (e,[n])]

main :: IO ()
main = do
  args <- getArgs
  fn   <- processArgs args
  str  <- BS.readFile fn
  case (decode NoHeader str :: Either String (Vector Contributor)) of
    Left err -> do
         putStrLn err
         exitFailure
    Right res -> do
      let res'  = concatMap (mkDesc . cleanRecord) (V.toList res)
      let g = buildGraph res'
      putStrLn $ prettySCC g

prettySCC :: DepGraph Text -> String
prettySCC (DepGraph l g) = drawForest (mkPrettyForest (scc g))
  where
    pruneForest :: Forest Vertex -> Forest Vertex
    pruneForest vs = concatMap (\t -> if null (subForest t) then [] else [t]) vs

    mkPrettyForest :: Forest Vertex -> Forest String
    mkPrettyForest vs = reverse $ map mkPrettyTree (pruneForest vs)

    mkPrettyTree :: Tree Vertex -> Tree String
    mkPrettyTree = fmap mkPretty

    mkPretty :: Vertex -> String
    mkPretty i = T.unpack $ fromMaybe (T.pack "nout") (L.lookup i l)

buildLegend :: List (Text, List Text)
            -> Int
            -> List (Text, Int)
            -> List (Text, Int)
buildLegend []         c cs = []
buildLegend ((x,_):xs) c cs = (x,c) : buildLegend xs (c+1) cs


data DepGraph a = DepGraph
  { legend :: List (Int, a)
  , graph  :: Graph
  } deriving (Show)

buildGraph :: List (Text, List Text)
           -> DepGraph Text
buildGraph xs = DepGraph legend' graph
  where
    legend :: List (Text,Int)
    legend = buildLegend xs 1 []

    legend' = map (\(a,b)->(b,a)) legend

    graph :: Graph
    graph = buildG (1, length legend) (catMaybes $ map mergeMaybes buildEdgesStr)

    mergeMaybes :: (Maybe a, Maybe a) -> Maybe (a,a)
    mergeMaybes (Just x, Just y) = Just (x,y)
    mergeMaybes _                = Nothing


    buildEdge :: (Text, List Text) -> List (Text,Text)
    buildEdge (k,vs) = map (\v -> (k,v)) vs

    buildEdges :: List (Text, List Text) -> List (Text,Text)
    buildEdges = concatMap (\e -> buildEdge e)

    buildEdgesStr :: List (Maybe Int, Maybe Int)
    buildEdgesStr = map (\(a,b) -> (L.lookup a legend, L.lookup b legend)) (buildEdges xs)