module HAX.Report where
import HAX.Accounting
import HAX.Bookkeeping
import HAX.Common hiding ((!))
import Data.Aeson hiding (Array)
import qualified Data.ByteString.Lazy as BL
import Data.List
import Data.List.Split
import Data.Text (Text)
import qualified Data.Map as M
import Data.Maybe
import Data.Ord
import System.Directory
import System.FilePath
import Text.Blaze hiding (text)
import Text.Blaze.Html.Renderer.Utf8
import qualified Text.Blaze.Html5 as H
import Text.Blaze.Html5 hiding (head,map,object,text)
import qualified Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html5.Attributes hiding (id,title)
import qualified Text.PrettyPrint.Boxes as P
import Text.PrettyPrint.Boxes hiding (left,(<>))
writeHtml :: FilePath
-> World -> IO ()
writeHtml dir world = do
createDirectoryIfMissing True dir
res <- generate world
let resHtml = toHtmlTable res
BL.writeFile (dir </> "header.html") $ indexPage $ resHtml
BL.writeFile (dir </> "index.html") $ indexPage $ do
iframe ! src "header.html" ! width "100%" !
customAttribute "scrolling" "no" ! A.style "position:fixed; border: 0px" ! height "37px" $ ""
resHtml
BL.writeFile (dir </> "data.js") . toVar "data" . encode $ res
toHtmlTable (FullLedger (FixedLedger balances logEntries) accounts) = do
table ! A.id "data" $ do
tr $ mapM_ headerColumn headerFANs
sequence_ $ zipWith f (elems logEntries) $ to2DTable balances
where headerColumn (FAN entity acc) = th ! class_ (fromString entity)
$ toMarkup entity >> br >> toMarkup acc
f logs (d,row) = do
mapM_ (logHtml headerFANs d $ length row) $ reverse logs
tr ! (monthClass "regular" d) $ rowHtml headerFANs show "" (d,row)
headerFANs = FAN "" "Month" : sortedAccountNames accounts ++ [FAN "" "Comment"]
monthClass cl d = class_ $ fromString $ cl ++" "++ if getMonth d == 12 then "endOfYear" else "duringYear"
rowHtml headerFANs f comment drow = zipWithM_ g headerFANs $ toRow show (f.scale) drow ++ [comment]
where g (FAN entity _) x = td ! class_ (fromString entity) $ toMarkup x
logHtml :: [FullAccountName] -> ADate -> Int
-> EntityLogEntry -> Html
logHtml _ d len (ent,LComment s) = tr ! (monthClass ("comment " ++ ent) d) $ do
td $ toMarkup $ show d
td ! colspan (toValue $ len + 1) $ fromString s
logHtml headerFANs d len (ent,LTx tx) = tr ! (monthClass ("transaction " ++ ent) d) $
rowHtml headerFANs
(\x -> if x == 0 then "" else show x) comment (d,row)
where (row,comment) = transactionRow (1,len) tx
css x = link ! rel "stylesheet" ! type_ "text/css" ! href x
js x = script ! src x $ ""
indexPage htmlBody = renderHtml $ docTypeHtml $ do
H.head $ do
meta ! charset "UTF-8"
js "http://code.jquery.com/jquery-1.11.1.min.js"
css "http://cdn.datatables.net/1.10.2/css/jquery.dataTables.min.css"
js "http://cdn.datatables.net/1.10.2/js/jquery.dataTables.min.js"
js "data.js"
js "../static/code.js"
title "hax results"
body $ do H.table ! A.id "example" $ ""
htmlBody
toVar :: (Monoid a,IsString a) => a -> a -> a
toVar name value = "var " <> name <> " = " <> value
instance ToJSON FullLedger where
toJSON (FullLedger (FixedLedger balances logEntries) accounts) =
object [ "accounts" .= toJSON (FAN "" "Month" : accs)
, "balances" .= (toRow toJSON (toJSON.scale) <$> to2DTable balances)
, "dates" .= range (bounds logEntries)
, "log" .= elems logEntries
, "entities" .= ((\x -> fromString (fEntity $ head x) .= (fAccount <$> x))
<$> groupBy ((==) `on` fEntity) accs :: [(Text, Value)])
]
where accs = sortedAccountNames accounts
instance ToJSON FullAccountName
instance ToJSON LogEntry
instance ToJSON Tx
instance ToJSON Decimal where
toJSON d = toJSON ( conv d :: Double)
instance ToJSON ADate where
toJSON = toJSON . show
scale = (roundTo 2.(/1000))
transactionRow :: (AccountNumber,AccountNumber)
-> Tx -> (Row Amount,Comment)
transactionRow accBounds txn = (postings,tComment txn)
where postings = elems $ accumArray (+) 0 accBounds
$ tPostings txn
col x = if x == 0 then ""
else (" "++) $ show $ scale x
type Row e = [e]
type Group e = [Row e]
type Scale b = (Amount -> b)
renderTable :: [Group String] -> String
renderTable groups = render $ punctuateH top seps
$ fmap renderCol (transpose $ intercalate [vertSep] $ groups)
where seps = vcat P.left $ map text $ replicate
(length groups 1 + length (head combined)) " | "
renderCol xs = vcat P.left $ map text xs
where rH h = [h,replicate (maximum $ length <$> (h:xs)) '-']
combined = transpose $ concat groups
vertSep = map (\c -> replicate (maximum $ length <$> c) '-') combined
toRow :: (r -> e) -> (a -> e) -> (r,Row a) -> Row e
toRow conv1 conv2 (d,row) = conv1 d : fmap conv2 row
to2DTable :: (Ix r,Ix c) => Array (r,c) a -> [(r,Row a)]
to2DTable array = zip (range (r1,r2))
$ chunksOf (rangeSize (c1,c2)) $ elems array
where ((r1,c1),(r2,c2)) = bounds array