-- 
--  Copyright (C) 2003 Don Stewart - http://www.cse.unsw.edu.au/~dons
--        (see http://www.gnu.org/copyleft/gpl.html)
--  
--  This program is free software; you can redistribute it and/or
--  modify it under the terms of the GNU General Public License as
--  published by the Free Software Foundation; either version 2 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
--  General Public License for more details.
-- 
--  You should have received a copy of the GNU General Public License
--  along with this program; if not, write to the Free Software
--  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
--  02111-1307, USA.
-- 
--
-- This program implements a work-hours clock suitable for SAL16 use
--

-- todo: provide total hours for this fortnight?

module Main where

import System
import Numeric
import Time
import Locale

-- for flock
#if __GLASGOW_HASKELL__ >= 600
import System.Posix.IO
#else
import GHC.Posix
#endif

------------------------------------------------------------
-- possible commands
data Cmd = 
      Start
    | BreakStart
    | BreakEnd
    | End
    | NoLunch
    | NewDelim
    | Error
    

-- possible log access modes
data Mode = RO | RW


-- structure of log file entries
data LogBlock = Block LogEntry
                      LogEntry
                      LogEntry
                      LogEntry
                      LogEntry

data LogEntry = 
      LogSTime  CalendarTime
    | LogBStart TimeDiff
    | LogBEnd   TimeDiff
    | LogETime  CalendarTime
    | LogDiff   TimeDiff
    | NoBreak
    | NoEntry
                      
------------------------------------------------------------
-- let's begin
main = do
        args <- getArgs 

        let (cmd,mode,msg) = parseArgs args 
        () <- case cmd of Error -> die msg ; _ -> return ()

        time <- gettime

        -- parse log file here, returning relevant block fragment
        -- but! must create file if it doesn't exist!
        -- and lock it too!
        log  <- logpath
        logs <- parseLog log time

        -- typecheck block, in context of cmd


        let result = eval cmd time
   
        case mode of
               RO -> putStrLn result
               RW -> putStrLn result -- truncate block
                                     -- overwrite with new block


------------------------------------------------------------
-- what is the logfile called?
logfile = ".timesheet"

-- find the canonical path to the log file
logpath = do home <- getEnv "HOME"
             return $ home ++ "/" ++ logfile 


-------------------------------------------------------
-- parse the log file
-- 
-- return the log file in a typecheckable, block structured form
-- where strings have been transformed to calendartime thingies
--

-- take a filepath and return a list of LogBlocks
--
-- attempts to do some flock'y posixy things
parseLog :: String -> CalendarTime -> IO [LogBlock]
parseLog [] _ = return [] -- this is an error 
parseLog f  t =
    do
        -- h1 <- openFile f ReadMode

        -- flock
        -- open or make
        s <- readFile f
        -- close
        let entries = parseBlocks (lines s) t
        return entries

-- real (and pure) parsing functions
-- generate a list of logblocks, given the whole file in strings
parseBlocks :: [String] -> CalendarTime -> [LogBlock]
parseSD     :: String -> CalendarTime -> Maybe LogEntry


-- actually parse the blocks
parseBlocks [] _ = []
-- parseBlocks (x:xs) = let startdate = parseSD x in
                

-- this returns a partially correct timestruct, which we will
-- then fill out correctly with other lines of the file
parseSD s t = 
    let 
        (wday,xs)  = psplit (== ' ') s 
        (day,ys)   = psplit (== '.') xs
        (mon,year) = psplit (== '.') ys

        -- convert to proper format
        ctYear = toInt ("20" ++ year) -- millenium bug
        ctDay  = toInt day
        mon'   = toInt mon

        ctWDay  = toDay wday
        ctMonth = toMonth mon'

    in if ( ctYear < 2000 || ctYear > 2099 )  || 
          ( ctDay < 1 || ctDay > 31 )       ||
          ( mon'  < 1 || mon'  > 12 )       

       then Nothing

       else case (ctWDay, ctMonth) of
            (Nothing,_)                 -> Nothing
            (_,Nothing)                 -> Nothing
            (Just ctWDay, Just ctMonth) -> 
                Just ( LogSTime ( 
                        t { ctYear  = ctYear,
                            ctMonth = ctMonth,
                            ctDay   = ctDay,
                            ctWDay  = ctWDay } ) )


toMonth :: Int -> Maybe Month
toMonth i = 
    let months = [ January, February, March, April, May, June, July, 
                   August, September, October, November, December ]
    in if ( i < 1 || i > 12 ) then Nothing else Just $ months !! (i-1)


toDay :: String -> Maybe Day
toDay "Sun" = Just Sunday
toDay "Mon" = Just Monday
toDay "Tue" = Just Tuesday
toDay "Wed" = Just Wednesday 
toDay "Thu" = Just Thursday
toDay "Fri" = Just Friday
toDay "Sat" = Just Saturday
toDay _ = Nothing

------------------------------------------------------------
-- parse the arguments
-- 
-- the rules is:
--      zero args : is an error
--      one arg   : in which case it must pattern match
--      two args  : first must be "-w", second is case for one arg
--      three args: is an error

parseArgs :: [String] -> (Cmd,Mode,String)

parseArgs [] = (Error,RO,"wrong number of arguments")
parseArgs [a] = 
    let x = check a in case x of 
        Error -> (Error,RO,"invalid argument \""++a++"\"")
        _     -> (x,RO,"")
parseArgs ["-w",a] = 
    let (x,_,s) = parseArgs [a] in case x of 
        Error -> (x,RO,s)
        _     -> (x,RW,"")
parseArgs _ = (Error,RO,"invalid arguments")


check "s"   = Start
check "bs"  = BreakStart
check "be"  = BreakEnd
check "e"   = End
check "nl"  = NoLunch
check "new" = NewDelim
check _ = Error


------------------------------------------------------------
-- evaluate the appropriate operation, returning the string
-- to be written to the log file

-- eval returns the string that is to be written to the log file
eval :: Cmd -> CalendarTime -> String

eval Start      t = fmt "%a %d.%m.%y\n\t%H:%M" t

eval BreakStart t = fmt "\t%H:%M" t

eval BreakEnd   t = fmt "\t%H:%M" t

eval NoLunch    _ = "\t-\n\t-"

eval NewDelim   _ = "----------------------------------------" 

eval End        t = "not implemented" 

-- shorthand
fmt :: String -> CalendarTime -> String
fmt s t = formatCalendarTime defaultTimeLocale s t

------------------------------------------------------------
-- time functions

-- take a string of the format %H:%M and return a time struct
-- suitable for manipulation
--
-- an assumption is made: the %H:%M is today.

strToTime :: String -> CalendarTime -> CalendarTime
strToTime [] t = undefined -- I really don't want this to happen
strToTime s t = 
    let (h,m) = psplit (== ':') s 
        (hour,min) = (toInt h,toInt m)
    in t { ctHour = hour, ctMin = min }

-- yup
toInt :: String -> Int
toInt s = fst $ head $ readDec s

        
-- grab the current time
gettime :: IO CalendarTime
gettime = do ct  <- getClockTime
             ct' <- toCalendarTime ct
             return ct'


------------------------------------------------------------
-- list helper functions

-- in the style of perl we remove delimiters
psplit :: (a -> Bool) -> [a] -> ([a],[a])
psplit p s = let (xs,ys) = break p s 
             in case ys of      
                [] -> (xs,[])
                _  -> (xs,tail ys)


------------------------------------------------------------
-- helper functions

-- canonical message
usage :: IO String
usage = do argc <- getProgName
           return $
            "\nusage: " ++ argc ++ " [-w] [s bs be e nl new]" ++
            "\n" ++
            "\t-w  : write to file\n" ++
            "\n" ++
            "\ts  : start of day\n" ++
            "\tbs : start break\n"  ++
            "\tbe : end break\n"    ++
            "\te  : end of day\n"   ++
            "\tnl : no lunch\n"     ++
            "\tnew: new fortnight\n"


-- die with a message
die :: String -> IO ()
die s = do putStrLn s
           u <- usage
           putStr u
           exitFailure