diff --git a/chart-unit.cabal b/chart-unit.cabal --- a/chart-unit.cabal +++ b/chart-unit.cabal @@ -1,5 +1,5 @@ name: chart-unit -version: 0.6.2.0 +version: 0.6.3.0 synopsis: Native haskell charts. description: <> . diff --git a/other/timeExample.svg b/other/timeExample.svg --- a/other/timeExample.svg +++ b/other/timeExample.svg @@ -5,678 +5,661 @@ - + - - Fri, 31 Aug + + Fri, 30 Nov - + - + - - Tue, 31 Jul + + Wed, 31 Oct - + - + - - Fri, 29 Jun + + Fri, 28 Sep - + - + - - Thu, 31 May + + Fri, 31 Aug - + - + - - Mon, 30 Apr + + Tue, 31 Jul - + - + - - Fri, 30 Mar + + Fri, 29 Jun - - - - - - - Wed, 28 Feb - + - - + + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - - 180 + + 180 - - + + - + - - 160 + + 160 - - + + - + - - 140 + + 140 - - + + - + - - 120 + + 120 - - + + - + - - 100 + + 100 - - + + - + - - 80 + + 80 - - + + - + - - 60 + + 60 - - + + - + - - 40 + + 40 - - + + - + - - 20 + + 20 - - + + - + - - 0 + + 0 - - + + - - - - - - - 31 Aug 2018 - - - - + - + - - 31 Jul 2018 + + 30 Nov 2018 - - + + - + - - 30 Jun 2018 + + 31 Oct 2018 - - + + - + - - 31 May 2018 + + 30 Sep 2018 - - + + - + - - 30 Apr 2018 + + 31 Aug 2018 - - + + - + - - 31 Mar 2018 + + 31 Jul 2018 - - + + - + - - 28 Feb 2018 + + 30 Jun 2018 - - + + - + diff --git a/src/Chart/Data/Time.hs b/src/Chart/Data/Time.hs --- a/src/Chart/Data/Time.hs +++ b/src/Chart/Data/Time.hs @@ -1,8 +1,10 @@ {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} @@ -147,20 +149,20 @@ floorGrain (Months n) (UTCTime d _) = UTCTime (addDays (-1) $ fromGregorian y m' 1) 0 where (y,m,_) = toGregorian (addDays 1 d) - m' = fromIntegral $ 1 + fromIntegral n * floor (fromIntegral (m - 1) / fromIntegral n :: Double) + m' = fromIntegral $ (1 + fromIntegral n * floor (fromIntegral (m - 1) / fromIntegral n :: Double) :: Integer) floorGrain (Days _) (UTCTime d _) = UTCTime d 0 floorGrain (Hours h) u@(UTCTime _ t) = addUTCTime x u where s = toDouble' t - x = fromDouble $ fromIntegral (h * 3600 * fromIntegral (floor (s / (fromIntegral h*3600)))) - s + x = fromDouble $ fromIntegral ((h * 3600 * fromIntegral ((floor (s / (fromIntegral h*3600)) :: Integer)))) - s floorGrain (Minutes m) u@(UTCTime _ t) = addUTCTime x u where s = toDouble' t - x = fromDouble $ fromIntegral (m * 60 * fromIntegral (floor (s / (fromIntegral m*60)))) - s + x = fromDouble $ fromIntegral (m * 60 * fromIntegral (floor (s / (fromIntegral m*60)) :: Integer)) - s floorGrain (Seconds secs) u@(UTCTime _ t) = addUTCTime x u where s = toDouble' t - x = fromDouble $ (secs * fromIntegral (floor (s / secs))) - s + x = fromDouble $ (secs * fromIntegral (floor (s / secs) :: Integer)) - s -- | compute the ceiling UTCTime based on the timegrain -- @@ -187,21 +189,21 @@ ceilingGrain (Months n) (UTCTime d _) = UTCTime (addDays (-1) $ fromGregorian y' m'' 1) 0 where (y,m,_) = toGregorian (addDays 1 d) - m' = fromIntegral n * ceiling (fromIntegral m / fromIntegral n :: Double) + m' = fromIntegral n * ceiling (fromIntegral m / fromIntegral n :: Double) :: Integer (y',m'') = fromIntegral <$> if m' == 12 then (y+1,1) else (y,m'+1) ceilingGrain (Days _) (UTCTime d t) = if t==0 then UTCTime d 0 else UTCTime (addDays 1 d) 0 ceilingGrain (Hours h) u@(UTCTime _ t) = addUTCTime x u where s = toDouble' t - x = fromDouble $ fromIntegral (h * 3600 * fromIntegral (ceiling (s / (fromIntegral h*3600)))) - s + x = fromDouble $ fromIntegral (h * 3600 * fromIntegral (ceiling (s / (fromIntegral h*3600)) :: Integer)) - s ceilingGrain (Minutes m) u@(UTCTime _ t) = addUTCTime x u where s = toDouble' t - x = fromDouble $ fromIntegral (m * 60 * fromIntegral (ceiling (s / (fromIntegral m*60)))) - s + x = fromDouble $ fromIntegral (m * 60 * fromIntegral (ceiling (s / (fromIntegral m*60)) :: Integer)) - s ceilingGrain (Seconds secs) u@(UTCTime _ t) = addUTCTime x u where s = toDouble' t - x = fromDouble $ (secs * fromIntegral (ceiling (s / secs))) - s + x = fromDouble $ (secs * fromIntegral (ceiling (s / secs) :: Integer)) - s -- | whether to include lower and upper times data PosDiscontinuous = PosInnerOnly | PosIncludeBoundaries @@ -213,7 +215,7 @@ -- ([(0,"06 Dec"),(1,"31 Dec"),(2,"28 Feb"),(3,"03 Mar")],[]) -- placedTimeLabelDiscontinuous :: PosDiscontinuous -> Maybe Text -> Int -> [UTCTime] -> ([(Int, Text)], [UTCTime]) -placedTimeLabelDiscontinuous posd format n ts = (zip (fst <$> inds') labels, rem) +placedTimeLabelDiscontinuous posd format n ts = (zip (fst <$> inds') labels, rem') where l = minimum ts u = maximum ts @@ -221,7 +223,7 @@ tps' = case posd of PosInnerOnly -> tps PosIncludeBoundaries -> [l] <> tps <> [u] - (rem, inds) = L.fold (matchTimes tps') ts + (rem', inds) = L.fold (matchTimes tps') ts inds' = laterTimes inds fmt = case format of Just f -> Text.unpack f @@ -278,7 +280,7 @@ grain = stepSensibleTime p span n first' = floorGrain grain l last' = ceilingGrain grain u - n' = round $ toDouble (diffUTCTime last' first') / grainSecs grain + n' = round $ toDouble (diffUTCTime last' first') / grainSecs grain :: Integer posns = case p of OuterPos -> take (fromIntegral $ n'+1) InnerPos -> drop (if first'==l then 0 else 1) . take (fromIntegral $ n' + if last'==u then 1 else 0) @@ -291,7 +293,7 @@ -- come up with a sensible step for a grid over a Field stepSensible :: - (Fractional a, Ord a, FromInteger a, QuotientField a, ExpField a) + (Fractional a, Ord a, FromInteger a, QuotientField a Integer, ExpField a) => Pos -> a -> Int @@ -313,7 +315,7 @@ -- come up with a sensible step for a grid over a Field, where sensible means the 18th century -- practice of using multiples of 3 to round stepSensible3 :: - (Fractional a, Ord a, FromInteger a, QuotientField a, ExpField a) + (Fractional a, Ord a, FromInteger a, QuotientField a Integer, ExpField a) => Pos -> a -> Int @@ -336,10 +338,10 @@ stepSensibleTime :: Pos -> NominalDiffTime -> Int -> TimeGrain stepSensibleTime tp span n | yearsstep >= 1 = Years (floor yearsstep) - | monthsstep >= 1 = Months (fromIntegral $ floor monthsstep) - | daysstep >= 1 = Days (fromIntegral $ floor daysstep) - | hoursstep >= 1 = Hours (fromIntegral $ floor hoursstep) - | minutesstep >= 1 = Minutes (fromIntegral $ floor minutesstep) + | monthsstep >= 1 = Months (fromIntegral $ (floor monthsstep :: Integer)) + | daysstep >= 1 = Days (fromIntegral $ (floor daysstep :: Integer)) + | hoursstep >= 1 = Hours (fromIntegral $ (floor hoursstep :: Integer)) + | minutesstep >= 1 = Minutes (fromIntegral $ (floor minutesstep :: Integer)) | secondsstep >= 1 = Seconds secondsstep3 | otherwise = Seconds secondsstep where diff --git a/src/Chart/Hud.hs b/src/Chart/Hud.hs --- a/src/Chart/Hud.hs +++ b/src/Chart/Hud.hs @@ -339,7 +339,7 @@ case opts ^. field @"tickStyle" of TickNone -> ([], []) TickRound n -> (project r asp <$> ticks0, precision 0 ticks0) - where ticks0 = gridSensible OuterPos r n + where ticks0 = gridSensible OuterPos r (fromIntegral n) TickExact n -> (project r asp <$> ticks0, precision 3 ticks0) where ticks0 = grid OuterPos r n TickLabels ls -> @@ -363,7 +363,7 @@ | foldr max 0 xs < 0.01 = precLoop expt' n0 (fromFloatDigits <$> xs) | foldr max 0 xs > 100000 = precLoop expt' n0 (fromFloatDigits <$> xs) | foldr max 0 xs > 1000 = - precLoopInt (const Formatting.commas) n0 (floor <$> xs) + precLoopInt (const Formatting.commas) n0 (floor <$> xs :: [Integer]) | otherwise = precLoop fixed n0 xs where expt' x = scifmt Exponent (Just x) @@ -585,7 +585,7 @@ lineLocations = case gridStyle gopt of GridNone -> [] - GridRound p n -> project r0 asp0 <$> gridSensible (gridPos p) r0 n + GridRound p n -> project r0 asp0 <$> gridSensible (gridPos p) r0 (fromIntegral n) GridExact p n -> project r0 asp0 <$> grid (gridPos p) r0 n GridPlaced xs -> project r0 asp0 <$> xs (asp0, r0) = diff --git a/src/Chart/Text.hs b/src/Chart/Text.hs --- a/src/Chart/Text.hs +++ b/src/Chart/Text.hs @@ -47,7 +47,7 @@ -- | transform from chart-unit to SVGFonts rep of font textFont :: TextFont -> PreparedFont Double -textFont Lin2 = lin2 +textFont Lin2 = unsafePerformIO lin2 textFont (FromFontFile f) = unsafePerformIO (loadFont (Text.unpack f)) -- | options specific to text as SVG text diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,14 +1,14 @@ -resolver: lts-10.10 +resolver: nightly-2018-06-05 packages: - . extra-deps: - generic-lens-labels-0.1.0.2 - - numhask-histogram-0.1.1.0 - - numhask-0.2.0.0 - - numhask-prelude-0.0.3.0 - - numhask-range-0.2.1.0 - - mwc-probability-2.0.2 + - numhask-histogram-0.1.2.1 + # - numhask-0.2.0.0 + # - numhask-prelude-0.0.3.0 + # - numhask-range-0.2.1.0 + # - mwc-probability-2.0.2 allow-newer: true