]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Date/Write.hs
Correction : compatiblité avec GHC-7.6 en limitant l’usage de Prelude.
[comptalang.git] / lib / Hcompta / Date / Write.hs
1 {-# LANGUAGE MagicHash #-}
2 module Hcompta.Date.Write where
3
4 import Data.Char (Char)
5 import Data.Eq (Eq(..))
6 import Data.Ord (Ord(..))
7 import qualified Data.Text as Text
8 import qualified Data.Time.LocalTime as Time
9 import GHC.Exts (Int(..))
10 import GHC.Integer.Logarithms (integerLogBase#)
11 import Prelude ( ($)
12 , (.)
13 , Integer
14 , Num(..)
15 , RealFrac(..)
16 , Show(..)
17 )
18
19
20 import Hcompta.Date (Date)
21 import qualified Hcompta.Date as Date
22 import Hcompta.Lib.Leijen (Doc, (<>))
23 import qualified Hcompta.Lib.Leijen as W
24
25 -- * Write 'Date'
26
27 date :: Date -> Doc
28 date dat = do
29 let (y, mo, d) = Date.gregorian dat
30 (if y == 0 then W.empty else W.integer y <> sep '/') <> do
31 int2 mo <> do
32 sep '/' <> int2 d <> do
33 (case Date.tod dat of
34 Time.TimeOfDay 0 0 0 -> W.empty
35 Time.TimeOfDay h m s ->
36 sep '_' <> int2 h <> do
37 sep ':' <> int2 m <> do
38 (case s of
39 0 -> W.empty
40 _ -> sep ':' <> do
41 (if s < 10 then W.char '0' else W.empty) <> do
42 W.strict_text $ Text.pack $ show $ (truncate s::Integer)))
43 -- (case tz_min of
44 -- 0 -> W.empty
45 -- _ | tz_name /= "" -> W.space <> do W.strict_text $ Text.pack tz_name
46 -- _ -> W.space <> do W.strict_text $ Text.pack $ Time.timeZoneOffsetString tz)
47 where
48 int2 :: Int -> Doc
49 int2 i = if i < 10 then W.char '0' <> W.int i else W.int i
50 sep :: Char -> Doc
51 sep = W.bold . W.dullblack . W.char
52
53 -- ** Measure 'Date'
54
55 date_length :: Date -> Int
56 date_length dat = do
57 let (y, _, _) = Date.gregorian dat
58 (case y of
59 0 -> 0
60 _ ->
61 (if y < 0 then 1 else 0) -- sign
62 + (1 + (I# (integerLogBase# 10 (abs y)))) -- year
63 + 1) -- /
64 + 2 -- month
65 + 1 -- /
66 + 2 -- dom
67 + (case Date.tod dat of
68 Time.TimeOfDay 0 0 0 -> 0
69 Time.TimeOfDay _ _ s ->
70 1 -- _
71 + 2 -- hour
72 + 1 -- :
73 + 2 -- min
74 + (case s of
75 0 -> 0
76 _ -> 1 + 2 -- : sec
77 )
78 )