FIRST COMMIT

LICENSE

+Copyright Alexandre Delanoë (c) 2017
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Alexandre Delanoë nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
\ No newline at end of file

README.md

+# data-time-segment

Setup.hs

+import Distribution.Simple
+main = defaultMain

app/Main.hs

+module Main where
+
+
+main :: IO ()
+main = undefined

data-time-segment.cabal

+name:                data-time-segment
+version:             0.1.0.0
+-- synopsis:
+-- description:
+homepage:            https://github.com/adelanoe/data-time-segment#readme
+license:             BSD3
+license-file:        LICENSE
+author:              Alexandre Delanoë
+maintainer:          devel@delanoe.org
+copyright:           Copyright: (c) 2017 Alexandre Delanoë
+category:            Data
+build-type:          Simple
+extra-source-files:  README.md
+cabal-version:       >=1.10
+
+library
+  hs-source-dirs:      src
+  exposed-modules:     Data.Time.Segment
+                     , Data.Time.Segment.Main
+                     , Data.Time.Segment.Granularity
+  build-depends:       base >= 4.7 && < 5
+                     , time
+                     , safe
+  default-language:    Haskell2010
+
+executable data-time-segment-exe
+  hs-source-dirs:      app
+  main-is:             Main.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , data-time-segment
+  default-language:    Haskell2010
+
+test-suite data-time-segment-test
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             Spec.hs
+  build-depends:       base
+                     , data-time-segment
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  default-language:    Haskell2010
+
+source-repository head
+  type:     git
+  location: https://github.com/adelanoe/data-time-segment

src/Data/Time/Segment.hs

+module Data.Time.Segment ( module Data.Time.Segment.Main
+                         , module Data.Time.Segment.Granularity
+                         ) where
+
+import Data.Time.Segment.Main
+import Data.Time.Segment.Granularity

src/Data/Time/Segment/Granularity.hs

+module Data.Time.Segment.Granularity where
+
+import qualified Safe as S (headMay)
+import Data.Time (UTCTime, getCurrentTime, NominalDiffTime)
+
+-- Grain is time size/density
+data Granularity =
+    M   | W   | D   |
+    H12 | H8  | H6  | H4  | H3 | H2 | H1 |
+    M30 | M15 | M10 | M5  | M1 |
+    -- M30 | M15 | M10 | M5  | M4 | M3 | M2 | M1 |
+    S30 | S15 | S10 | S5 
+   deriving (Show, Read, Eq, Ord, Enum, Bounded)
+
+-- grains ?
+allGranularity :: [Granularity]
+allGranularity = [minBound..maxBound]
+
+grain2seconds :: Granularity -> Int
+grain2seconds grain = case grain of
+                        S5  -> 5
+                        S10 -> 10
+                        S15 -> 15
+                        S30 -> 30
+                        M1  -> 1 * 60
+                        -- M2  -> 2 * 60
+                        -- M3  -> 3 * 60
+                        -- M4  -> 4 * 60
+                        M5  -> 5 * 60
+                        M10 -> 10* 60
+                        M15 -> 15* 60
+                        M30 -> 30* 60
+                        H1  -> 1 * 60 * 60
+                        H2  -> 2 * 60 * 60
+                        H3  -> 3 * 60 * 60
+                        H4  -> 4 * 60 * 60
+                        H6  -> 6 * 60 * 60
+                        H8  -> 8 * 60 * 60
+                        H12 -> 12* 60 * 60
+                        D   -> 24* 60 * 60
+                        W   -> 7 * 24 * 60 * 60
+                        M   -> 31* 24 * 60 * 60
+
+grain2seconds' :: Granularity -> NominalDiffTime
+grain2seconds' grain = case grain of
+                        S5  -> 5
+                        S10 -> 10
+                        S15 -> 15
+                        S30 -> 30
+                        M1  -> 1 * 60
+                        -- M2  -> 2 * 60
+                        -- M3  -> 3 * 60
+                        -- M4  -> 4 * 60
+                        M5  -> 5 * 60
+                        M10 -> 10* 60
+                        M15 -> 15* 60
+                        M30 -> 30* 60
+                        H1  -> 1 * 60 * 60
+                        H2  -> 2 * 60 * 60
+                        H3  -> 3 * 60 * 60
+                        H4  -> 4 * 60 * 60
+                        H6  -> 6 * 60 * 60
+                        H8  -> 8 * 60 * 60
+                        H12 -> 12* 60 * 60
+                        D   -> 24* 60 * 60
+                        W   -> 7 * 24 * 60 * 60
+                        M   -> 31* 24 * 60 * 60
+
+
+
+seconds2grain :: Int -> Granularity
+seconds2grain seconds = do
+    let grain = S.headMay $ filter (\x -> grain2seconds x == seconds) allGranularity
+    case grain of
+      Just grain'  -> grain'
+      Nothing -> M
+
+
+grain2grain :: Granularity -> Int -> Granularity
+grain2grain g s = do
+    if ( s > 0 ) 
+       then grain2grainSup g s
+    else 
+        grain2grainInf g (abs s)
+
+grain2grainSup :: Granularity -> Int -> Granularity
+grain2grainSup g s = do
+    let seconds = (grain2seconds g) * s
+    seconds2grain seconds
+
+
+grain2grainInf :: Granularity -> Int -> Granularity
+grain2grainInf g s = do
+    let seconds = (grain2seconds g) `div` s
+    seconds2grain seconds
+
+

src/Data/Time/Segment/Main.hs

+module Data.Time.Segment.Main where
+
+import Data.Time.Segment.Granularity
+
+import Prelude
+import Debug.Trace (trace)
+import Data.Time
+import Data.Time.Clock (utctDay)
+import Data.List (groupBy, scanl', foldl')
+import Data.Time.Calendar.OrdinalDate (sundayStartWeek)
+
+import Data.Fixed (Pico)
+import Control.Concurrent (threadDelay)
+
+
+-----------------------------------------------------------------
+date :: Integer -> Int -> Int -> Int -> Int -> Pico -> UTCTime
+date y m d h mn s = UTCTime (fromGregorian y m d) (timeOfDayToTime $ TimeOfDay h mn s)
+
+jour :: Integer -> Int -> Int -> UTCTime
+jour y m d = date y m d 0 0 0
+
+begin:: UTCTime
+begin = date 2017 03 06 0 0 0
+
+end :: UTCTime
+end   = date 2017 03 04 0 0 0
+
+-----------------------------------------------------------------
+-----------------------------------------------------------------
+data Times = Before | After
+  deriving (Eq, Show, Read)
+
+times :: Times -> Int -> Granularity -> UTCTime -> [UTCTime]
+times t n g d = chronos scanl' t n g d
+
+timeIt :: Times -> Int -> Granularity -> UTCTime -> UTCTime
+timeIt t n g d = chronos foldl' t n g d
+
+chronos :: (Num t3, Enum t3) => ((UTCTime -> t -> UTCTime)
+      -> t2 -> [t3] -> t1) -> Times -> t3 -> Granularity -> t2 -> t1
+chronos f t n g d = f (\n' _ -> addUTCTime (sign sec) n') d [1..n]
+    where
+        sec  = grain2seconds' g
+        sign = case t of
+                  Before  -> negate
+                  _       -> id
+-----------------------------------------------------------------
+-- | After
+timesAfter :: Int -> Granularity -> UTCTime -> [UTCTime]
+timesAfter n g d = times After n g d
+
+-- | Before
+timesBefore :: Int -> Granularity -> UTCTime -> [UTCTime]
+timesBefore n g d = times Before n g d
+
+-- | After now
+timesAfterNow :: Int -> Granularity -> IO [UTCTime]
+timesAfterNow n g = times After n g <$> getCurrentTime
+
+-- | Before now
+timesBeforeNow :: Int -> Granularity -> IO [UTCTime]
+timesBeforeNow n g = times Before n g <$> getCurrentTime
+
+-----------------------------------------------------------------
+minutesAfter :: Int -> UTCTime -> [UTCTime]
+minutesAfter n d = timesAfter n M1 d
+
+minutesBefore :: Int -> UTCTime -> [UTCTime]
+minutesBefore n d = timesBefore n M1 d
+
+-----------------------------------------------------------------
+minutesAfterNow :: Int -> IO [UTCTime]
+minutesAfterNow n = timesAfter n M1 <$> getCurrentTime
+
+minutesBeforeNow :: Int -> IO [UTCTime]
+minutesBeforeNow n = timesBefore n M1 <$> getCurrentTime
+
+
+-----------------------------------------------------------------
+timesBetween :: UTCTime -> UTCTime -> Granularity -> [UTCTime]
+timesBetween begin end grain | begin == end = [begin]
+                             | begin > end  = [] 
+                             | begin < end  = scanl (\n' _ -> addUTCTime sec n') begin [1..end']
+                                   where
+                                       sec  = grain2seconds' grain
+                                       end' = round $ (diffUTCTime end begin) / sec
+
+
+-----------------------------------------------------------------
+sleepToNextMinute :: IO ()
+sleepToNextMinute = do t <- getCurrentTime
+                       let secs = round (realToFrac $ utctDayTime t) `rem` 60
+                       trace (show secs) $ threadDelay $ 10^6 * (60 - secs)
+
+-----------------------------------------------------------------

stack.yaml

+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# http://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+# resolver:
+#  name: custom-snapshot
+#  location: "./custom-snapshot.yaml"
+resolver: lts-8.13
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#   extra-dep: true
+#  subdirs:
+#  - auto-update
+#  - wai
+#
+# A package marked 'extra-dep: true' will only be built if demanded by a
+# non-dependency (i.e. a user package), and its test suites and benchmarks
+# will not be run. This is useful for tweaking upstream packages.
+packages:
+- '.'
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+flags: {}
+
+# Extra package databases containing global packages
+extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.3"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor
\ No newline at end of file

test/Spec.hs

+main :: IO ()
+main = putStrLn "Test suite not yet implemented"