RosettaCodeData/Task/Functional-coverage-tree/Haskell/functional-coverage-tree.hs

{-# LANGUAGE OverloadedStrings #-}

import Data.Bifunctor (first)
import Data.Bool (bool)
import Data.Char (isSpace)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Read as T
import Data.Tree (Forest, Tree (..), foldTree)
import Numeric (showFFloat)
import System.Directory (doesFileExist)

----------------- FUNCTIONAL COVERAGE TREE ---------------

data Coverage = Coverage
  { name :: T.Text,
    weight :: Float,
    coverage :: Float,
    share :: Float
  }
  deriving (Show)

--------------------------- TEST -------------------------
fp = "./coverageOutline.txt"

main :: IO ()
main =
  doesFileExist fp
    >>= bool
      (print $ "File not found: " <> fp)
      (T.readFile fp >>= T.putStrLn . updatedCoverageOutline)

----------------- UPDATED COVERAGE OUTLINE ---------------
updatedCoverageOutline :: T.Text -> T.Text
updatedCoverageOutline s =
  let delimiter = "|"
      indentedLines = T.lines s
      columnNames =
        init $
          tokenizeWith
            delimiter
            ( head indentedLines
            )
   in T.unlines
        [ tabulation
            delimiter
            (columnNames <> ["SHARE OF RESIDUE"]),
          indentedLinesFromTree
            "    "
            (showCoverage delimiter)
            $ withResidueShares 1.0 $
              foldTree
                weightedCoverage
                (parseTreeFromOutline delimiter indentedLines)
        ]

------ WEIGHTED COVERAGE AND SHARES OF REMAINING WORK ----
weightedCoverage ::
  Coverage ->
  Forest Coverage ->
  Tree Coverage
weightedCoverage x xs =
  let cws = ((,) . coverage <*> weight) . rootLabel <$> xs
      totalWeight = foldr ((+) . snd) 0 cws
   in Node
        ( x
            { coverage =
                foldr
                  (\(c, w) a -> (c * w) + a)
                  (coverage x)
                  cws
                  / bool 1 totalWeight (0 < totalWeight)
            }
        )
        xs

withResidueShares :: Float -> Tree Coverage -> Tree Coverage
withResidueShares shareOfTotal tree =
  let go fraction node =
        let forest = subForest node
            weights = weight . rootLabel <$> forest
            weightTotal = sum weights
            nodeRoot = rootLabel node
         in Node
              ( nodeRoot
                  { share =
                      fraction
                        * (1 - coverage nodeRoot)
                  }
              )
              ( zipWith
                  go
                  ((fraction *) . (/ weightTotal) <$> weights)
                  forest
              )
   in go shareOfTotal tree

---------------------- OUTLINE PARSE ---------------------
parseTreeFromOutline :: T.Text -> [T.Text] -> Tree Coverage
parseTreeFromOutline delimiter indentedLines =
  partialRecord . tokenizeWith delimiter
    <$> head
      ( forestFromLineIndents $
          indentLevelsFromLines $ tail indentedLines
      )

forestFromLineIndents :: [(Int, T.Text)] -> [Tree T.Text]
forestFromLineIndents pairs =
  let go [] = []
      go ((n, s) : xs) =
        let (firstTreeLines, rest) = span ((n <) . fst) xs
         in Node s (go firstTreeLines) : go rest
   in go pairs

indentLevelsFromLines :: [T.Text] -> [(Int, T.Text)]
indentLevelsFromLines xs =
  let pairs = T.span isSpace <$> xs
      indentUnit =
        foldr
          ( \x a ->
              let w = (T.length . fst) x
               in bool a w (w < a && 0 < w)
          )
          (maxBound :: Int)
          pairs
   in first (flip div indentUnit . T.length) <$> pairs

partialRecord :: [T.Text] -> Coverage
partialRecord xs =
  let [name, weightText, coverageText] =
        take
          3
          (xs <> repeat "")
   in Coverage
        { name = name,
          weight = defaultOrRead 1.0 weightText,
          coverage = defaultOrRead 0.0 coverageText,
          share = 0.0
        }

defaultOrRead :: Float -> T.Text -> Float
defaultOrRead n txt = either (const n) fst $ T.rational txt

tokenizeWith :: T.Text -> T.Text -> [T.Text]
tokenizeWith delimiter = fmap T.strip . T.splitOn delimiter

-------- SERIALISATION OF TREE TO TABULATED OUTLINE ------
indentedLinesFromTree ::
  T.Text ->
  (T.Text -> a -> T.Text) ->
  Tree a ->
  T.Text
indentedLinesFromTree tab showRoot tree =
  let go indent node =
        showRoot indent (rootLabel node) :
        (subForest node >>= go (T.append tab indent))
   in T.unlines $ go "" tree

showCoverage :: T.Text -> T.Text -> Coverage -> T.Text
showCoverage delimiter indent x =
  tabulation
    delimiter
    ( [T.append indent (name x), T.pack (showN 0 (weight x))]
        <> (T.pack . showN 4 <$> ([coverage, share] <*> [x]))
    )

tabulation :: T.Text -> [T.Text] -> T.Text
tabulation delimiter =
  T.intercalate (T.append delimiter " ")
    . zipWith (`T.justifyLeft` ' ') [31, 9, 9, 9]

justifyRight :: Int -> a -> [a] -> [a]
justifyRight n c = (drop . length) <*> (replicate n c <>)

showN :: Int -> Float -> String
showN p n = justifyRight 7 ' ' (showFFloat (Just p) n "")