ledgering.hs

{-# LANGUAGE Arrows            #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TupleSections     #-}
import           Control.Applicative ((<|>))
import           Control.Arrow
import           Control.Category
import           Control.Monad       (unless)
import           Data.Maybe          (fromJust)
import           Data.Text           (Text)
import qualified Data.Text           as T
import           Data.Text.IO        (readFile, writeFile)
import           GHC.Generics
import           Prelude             hiding (id, readFile, writeFile, (.))
import           System.Directory    (createDirectoryIfMissing, doesFileExist,
                                      getModificationTime, listDirectory,
                                      renameFile)
import           System.FilePath     (dropExtension, takeDirectory,
                                      (<.>), (</>))
import           System.IO.Temp
import           System.Process      (callProcess)

-- An arrowized hakyll like compiler for hledger

-- The basic compiler type, this is almost 1:1 to hakylls. There are features I might not need and features that I don't have, but that's for another session
data Compiler a b = Compiler { dependencies :: [FilePath]
                             , output       :: Maybe (IO FilePath)
                             , action       :: Kleisli IO a b
                             }
                  deriving Generic

-- It is an functor
instance Functor (Compiler a) where
  fmap f Compiler{..} = Compiler { dependencies = dependencies
                                 , output = output
                                 , action = Kleisli (fmap f . runKleisli action) }

-- And an applicative
instance Applicative (Compiler a) where
  pure a = Compiler { dependencies = []
                    , output = Nothing
                    , action = Kleisli (\_ -> pure a) }
  g <*> f = Compiler { dependencies = dependencies g <> dependencies f
                     , output = output g <|> output f
                     , action = Kleisli (\a -> (runKleisli (action g) a) <*> runKleisli (action f) a)
                     }

-- But most importantly it's a category
instance Category Compiler where
  id = Compiler { dependencies = []
                , output = Nothing
                , action = Kleisli pure }
  g . f = Compiler { dependencies = dependencies g <> dependencies f
                   , output = output g <|> output f
                   , action = action g . action f }

-- And an arrow
instance Arrow Compiler where
  arr f = Compiler { dependencies = []
                   , output = Nothing
                   , action = Kleisli (pure . f) }
  first Compiler{..} = Compiler dependencies output (Kleisli (\(b,d) -> (,d) <$> runKleisli action b))

newtype CSV = CSV Text

-- Clean up nordea statements
cleanup :: Compiler Text CSV
cleanup = arr (CSV . go)
  where
    go :: Text -> Text
    go = T.unlines
       . map (T.intercalate ",")
       . filter ((==) 14 . length)
       . map (T.splitOn "\t" . T.replace "," ".")
       . filter (not . ("Kirjauspäivä" `T.isPrefixOf`))
       . T.lines

newtype Rule = Rule Text

-- Read a file into text
readAction :: FilePath -> Compiler () Text
readAction path = Compiler { dependencies = [path]
                           , output = Nothing
                           , action = Kleisli (\_ -> readFile path)
                           }

-- Write a text into file
writeAction :: FilePath -> Compiler Text ()
writeAction path = Compiler { dependencies = []
                            , output = Just (pure path)
                            , action = Kleisli go
                            }
  where
    go content = withTempDirectory "_build" "ledger" $ \temp -> do
      let actual = "_out" </> path
      createDirectoryIfMissing True (takeDirectory actual)
      createDirectoryIfMissing True (takeDirectory (temp </> path))
      writeFile (temp </> path) content
      renameFile (temp </> path) actual

-- Write a text into file and keep track fo the path
writeActionPath :: FilePath -> Compiler Text FilePath
writeActionPath path = writeAction path >>> arr (const path)

-- Create a combination journal file
createAll :: FilePath -> Compiler [FilePath] ()
createAll path = arr format >>> writeAction path
  where
    format :: [FilePath] -> Text
    format = T.unlines . map (("!include " <>) . T.pack)


readRule :: FilePath -> Compiler () Rule
readRule = fmap Rule . readAction


-- Import ledger
-- it makes sure the file names are correct for hledger and that the import process succeeds with 0
importLedger :: Compiler (Rule, CSV) Text
importLedger = Compiler { dependencies = []
                        , output = Nothing
                        , action = Kleisli go
                        }
  where
    go :: (Rule, CSV) -> IO Text
    go (Rule rule, CSV csv)= do
      createDirectoryIfMissing True "_build"
      withTempDirectory "_build" "ledger" $ \path -> do
        writeFile (path </> "ledger.rules") rule
        writeFile (path </> "ledger") csv
        writeFile (path </> "ledger.journal") ""
        callProcess "hledger" ["import", "-f", path </> "ledger.journal", path </> "ledger"]
        readFile (path </> "ledger.journal")

-- Build a ledger out of rules and statements
buildLedger :: FilePath -> FilePath -> Compiler () FilePath
buildLedger rulesFile statementsFile = proc () -> do
  statements <- readAction statementsFile -< ()
  r <- readRule rulesFile -< ()
  csv <- cleanup -< statements
  out <- importLedger -< (r,csv)
  writeActionPath outFile -< out
  where
    outFile = (dropExtension statementsFile) <.> "journal"

-- Copy ledger as-is
copyLedger :: FilePath -> Compiler () FilePath
copyLedger path = readAction path >>> writeActionPath path

-- list dir and create ledgers out of it
-- Not convinced of this implementation, this has an ugly outer layer of IO
buildLedgers :: FilePath -> FilePath -> IO (Compiler () [FilePath])
buildLedgers rulesFile directory =
  sequenceA . map (buildLedger rulesFile) <$> (map (directory </>) <$> listDirectory directory)

-- Run the compiler. I'm not convinved of this implementation. It's doing too much work
runCompiler :: Compiler () () -> IO ()
runCompiler Compiler{output=Nothing} = return ()
runCompiler Compiler{..} = do
  url <- fromJust output -- XXX: Not ideal
  putStrLn url
  valid <- isFileMoreRecent url dependencies
  unless valid (runKleisli action ())
  where
    isFileMoreRecent :: FilePath -> [FilePath] -> IO Bool
    isFileMoreRecent current comp = do
      exists <- doesFileExist current
      if exists
         then newer <$> getModificationTime current <*> traverse getModificationTime comp
         else pure False
    newer x = all (\y -> x > y)




main :: IO ()
main = do
  checkings <- buildLedgers "rules/nordea_checking.rules" "checking_input/"
  savings <- buildLedgers "rules/nordea_saving.rules" "savings_input/"
  let base = copyLedger "base.journal"
  runCompiler $ proc () -> do
    c <- checkings -< ()
    s <- savings -< ()
    b <- base -< ()
    createAll "all.journal" -< (c <> s <> [b])

-- Couldn't get the arrows to match on this
-- listAction :: FilePath -> Compiler () [FilePath]
-- listAction dir = Compiler { dependencies = []
--                           , output = Nothing
--                           , action = Kleisli (\_ -> map (dir </>) <$> listDirectory dir) }

-- Ended up not using this
-- mustache :: String -> Compiler Text (Either ParseError Template)
-- mustache name = arr (compileTemplate name)