~jack/misc

misc/cabinsheets/Cabinsheets.hs -rw-r--r-- 5.2 KiB
008ecc90Jack Kelly Add functional-images to default.nix/ci 26 days ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
-- cabinsheet.ml - Generate (crappy) HTML cabin sheets from CSV
-- Copyright (C) 2012  Jack Kelly
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <https://www.gnu.org/licenses/>.

import Data.Char
import qualified Data.Map as Map
import System.Environment
import System.Exit
import System.FilePath
import Text.CSV hiding (csv)
import Text.Html (Html, (!), (<<), (+++))
import qualified Text.Html as Html
import Text.ParserCombinators.Parsec.Error
import Text.Printf

-- Cabinsheets are a lot simpler than bunkplans: it's just a series of
-- records of the form (Cabin, Bunk, Watch, Name). Watch names get
-- colorized, and the string "HOT BUNK" is rendered in purple.
data CabinEntry = CabinEntry {
      _bunk :: String,
      _watch :: String,
      _name :: String
}

type CabinPlan = Map.Map String [CabinEntry]

-- Trim a CSV file: remove empty columns on the left, empty rows at
-- top or bottom and empty cells at the end of the row.
trimCSV :: CSV -> CSV
trimCSV = noEmpty . trimRight . trimLeft where
    noEmpty = filter (/= [])
    trimRight = map $ reverse . dropWhile (== "") . reverse
    trimLeft csv =
      let margin = minimum $ map (length . takeWhile (== "")) csv
      in map (drop margin) csv

-- Non-structural fixups on the CSV.
tidy :: CSV -> CSV
tidy = upper . trimCells where
    upper = map . map $ map toUpper
    trimCells = map . map $ reverse . dropWhile isSpace . reverse

-- Read the cabin plan into something useful.
parseCabinPlan :: CSV -> CabinPlan
parseCabinPlan = foldr addEntry Map.empty where
    addEntry [cabin, bunk, watch, name] =
        Map.insertWith (++) cabin [CabinEntry {
                                     _bunk = bunk,
                                     _watch = watch,
                                     _name = name
                                   }]
    addEntry _ = error "Malformed line in CSV"

readCabinPlan :: FilePath -> IO CabinPlan
readCabinPlan file = do
  csv <- parseCSVFromFile file
  case csv of
    Left err -> error $ concatMap messageString $ errorMessages err
    Right records -> return $ parseCabinPlan $ tidy $ trimCSV records

-- Generate cabin sheet.
colorize :: String -> Html
colorize "RED" = (Html.font << "RED") ! [Html.color Html.red]
colorize "BLUE" = (Html.font << "BLUE") ! [Html.color Html.blue]
colorize "GREEN" = (Html.font << "GREEN") ! [Html.color Html.green]
colorize "HOT BUNK" = (Html.font << "HOT BUNK") ! [Html.color Html.purple]
colorize other = Html.toHtml other

makeCabinSheet :: String -> [CabinEntry] -> String
makeCabinSheet cabin entries =
    doctype ++ Html.prettyHtml (Html.thehtml << (theHead +++ theBody)) where
        doctype = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n"
        size = length entries
        smallCabin = size <= 5
        bigNames = any ((>= 15) . length . _name) entries
        fontSize
            | smallCabin = "6"
            | bigNames   = "5"
            | otherwise  = "4"

        title = printf "BUNK PLAN %s" cabin :: String
        theHead = Html.header << Html.thetitle << title
        theH1 = (Html.h1 << title) ! [Html.align "center"]

        headingCell label = Html.th
          << Html.center
          << (Html.font << Html.underline << label) ! [Html.color Html.navy]
        headingRow = foldl1 (+++) $ map headingCell ["BUNK", "WATCH", "NAME"]
        cell label = Html.td << Html.center << label
        row entry = Html.tr << (cell (_bunk entry)
                           +++ cell (colorize $ _watch entry)
                           +++ cell (_name entry))
        theRows = map row entries
        theTable = (Html.table << (headingRow +++ theRows))
          ! [Html.cellpadding 5, Html.cellspacing 40]
        content = Html.center << ((Html.font << Html.bold << theTable)
                             ! [Html.size fontSize])
        theBody = Html.body << (theH1 +++ content)

-- Turn the input filename into an output filename.
makeFileName :: FilePath -> String -> FilePath
makeFileName template name = dropExtension template ++ "-" ++ name ++ ".html"

printCabinSheet :: FilePath -> String -> [CabinEntry] -> IO ()
printCabinSheet template cabin entries =
    writeFile (makeFileName template cabin) (makeCabinSheet cabin entries)

printCabinSheets :: FilePath -> CabinPlan -> IO ()
printCabinSheets template cabins =
    mapM_ (uncurry $ printCabinSheet template) $ Map.toList cabins

main :: IO ()
main = do
  args <- getArgs
  case args of
    [file] -> do
              plan <- readCabinPlan file
              printCabinSheets file plan
              exitSuccess
    _ -> do
         putStrLn "Must have a single filename argument."
         exitFailure