packages feed

attoparsec-time (empty) → 0.1

raw patch · 8 files changed

+431/−0 lines, 8 filesdep +attoparsecdep +basedep +base-preludebuild-type:Customsetup-changed

Dependencies added: attoparsec, base, base-prelude, directory, doctest, filepath, text, time

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2017, Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,42 @@+-- The code is mostly ripped from+-- https://github.com/ekmett/lens/blob/697582fb9a980f273dbf8496253c5bbefedd0a8b/Setup.lhs+import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )+import Distribution.Text ( display )+import Distribution.Verbosity ( Verbosity, normal )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+     buildHook simpleUserHooks pkg lbi hooks flags+  }++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+  let dir = autogenModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir+  withLibLBI pkg lbi $ \_ libcfg -> do+    withTestLBI pkg lbi $ \suite suitecfg -> do+      rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines+        [ "module Build_" ++ testName suite ++ " where"+        , "import Prelude"+        , "deps :: [String]"+        , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+        ]+  where+    formatdeps = map (formatone . snd)+    formatone p = case packageName p of+      PackageName n -> n ++ "-" ++ showVersion (packageVersion p)++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys+
+ attoparsec-time.cabal view
@@ -0,0 +1,78 @@+name:+  attoparsec-time+version:+  0.1+synopsis:+  Attoparsec parsers of time+description:+  A collection of Attoparsec parsers for the \"time\" library+category:+  Attoparsec, Parsers, Time+homepage:+  https://github.com/sannsyn/attoparsec-time +bug-reports:+  https://github.com/sannsyn/attoparsec-time/issues +author:+  Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer:+  Nikita Volkov <nikita.y.volkov@mail.ru>+copyright:+  (c) 2017, Nikita Volkov+license:+  MIT+license-file:+  LICENSE+build-type:+  Custom+cabal-version:+  >=1.10++source-repository head+  type:+    git+  location:+    git://github.com/sannsyn/attoparsec-time.git++library+  hs-source-dirs:+    library+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+  exposed-modules:+    Attoparsec.Time+  other-modules:+    Attoparsec.Time.Prelude+    Attoparsec.Time.Validators+    Attoparsec.Time.Constructors+  build-depends:+    -- +    attoparsec >= 0.13 && < 0.15,+    --+    time >= 1.4 && < 2,+    text >= 1 && < 2,+    --+    base-prelude < 2++test-suite doctest+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    doctest+  main-is:+    Main.hs+  ghc-options:+    -threaded+    "-with-rtsopts=-N"+    -funbox-strict-fields+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+  build-depends:+    doctest == 0.11.*,+    directory >= 1.2 && < 2,+    filepath >= 1.4 && < 2,+    base-prelude < 2,+    base < 5
+ doctest/Main.hs view
@@ -0,0 +1,35 @@+-- The code is mostly ripped from+-- https://github.com/ekmett/lens/blob/d1d97469f0e93c1d3535308954a060e8a04e37aa/tests/doctests.hsc+import BasePrelude+import System.Directory+import System.FilePath+import Test.DocTest+import Build_doctest (deps)++main :: IO ()+main = do+  sources <- getSources+  doctest $ defaultParams ++ map ("-package="++) deps ++ extensionParams ++ sources+  where+    defaultParams = +      [+        "-isrc",+        "-idist/build/autogen",+        "-optP-include",+        "-optPdist/build/autogen/cabal_macros.h",+        "-hide-all-packages"+      ]+    extensionParams =+      ["-XArrows", "-XBangPatterns", "-XConstraintKinds", "-XDataKinds", "-XDefaultSignatures", "-XDeriveDataTypeable", "-XDeriveFoldable", "-XDeriveFunctor", "-XDeriveGeneric", "-XDeriveTraversable", "-XEmptyDataDecls", "-XFlexibleContexts", "-XFlexibleInstances", "-XFunctionalDependencies", "-XGADTs", "-XGeneralizedNewtypeDeriving", "-XLambdaCase", "-XLiberalTypeSynonyms", "-XMagicHash", "-XMultiParamTypeClasses", "-XMultiWayIf", "-XNoImplicitPrelude", "-XNoMonomorphismRestriction", "-XOverloadedStrings", "-XPatternGuards", "-XParallelListComp", "-XQuasiQuotes", "-XRankNTypes", "-XRecordWildCards", "-XScopedTypeVariables", "-XStandaloneDeriving", "-XTemplateHaskell", "-XTupleSections", "-XTypeFamilies", "-XTypeOperators", "-XUnboxedTuples"]++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "library"+  where+    go dir = do+      (dirs, files) <- getFilesAndDirectories dir+      (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
+ library/Attoparsec/Time.hs view
@@ -0,0 +1,156 @@+module Attoparsec.Time+(+  timeOfDayInISO8601,+  dayInISO8601,+  timeZoneInISO8601,+  utcTimeInISO8601,+)+where++import Attoparsec.Time.Prelude hiding (take, takeWhile)+import Data.Attoparsec.Text+import qualified Attoparsec.Time.Constructors as A+import qualified Attoparsec.Time.Validators as B+import qualified Data.Text as C+++validated :: Show a => B.Validator a -> Parser a -> Parser a+validated validator parser =+  parser >>= \x -> B.run validator (pure x) fail x++sign :: Parser Bool+sign =+  anyChar >>= \case+    '+' -> return True+    '-' -> return False+    _ -> empty++decimalChar :: Parser Int+decimalChar =+  satisfyWith ((subtract 48) . ord) ((&&) <$> (>= 0) <*> (<= 9))++decimalOfLength :: Num a => Int -> Parser a+decimalOfLength length =+  fmap (foldl' (\a b -> a * 10 + b) 0) $+  replicateM length (fmap fromIntegral decimalChar)++shortMonth :: Parser Int+shortMonth =+  liftM C.toLower (take 3) >>= \case+    "jan" -> return 1+    "feb" -> return 2+    "mar" -> return 3+    "apr" -> return 4+    "may" -> return 5+    "jun" -> return 6+    "jul" -> return 7+    "aug" -> return 8+    "sep" -> return 9+    "oct" -> return 10+    "nov" -> return 11+    "dec" -> return 12+    _ -> empty++picoWithBasisOfLength :: Int -> Parser Pico+picoWithBasisOfLength basisLength =+  (\a b -> MkFixed (foldl' (\a b -> a * 10 + fromIntegral b) 0 (a ++ b))) <$> beforePoint <*> afterPoint+  where+    resolution =+      12+    beforePoint =+      replicateM basisLength decimalChar+    afterPoint =+      padListFromRight 0 [] resolution <$> ((char '.' *> many decimalChar) <|> pure [])+      where+        padListFromRight padding accumulator length list =+          case length of+            0 -> reverse accumulator+            _ -> case list of+              head : tail -> padListFromRight padding (head : accumulator) (pred length) tail+              _ -> reverse accumulator ++ replicate length padding++{-|+>>> parseOnly timeOfDayInISO8601 "05:03:58"+Right 05:03:58++>>> parseOnly timeOfDayInISO8601 "05:03:58.02"+Right 05:03:58.02++>>> parseOnly timeOfDayInISO8601 "05:03:58.020"+Right 05:03:58.02+-}+{-# INLINE timeOfDayInISO8601 #-}+timeOfDayInISO8601 :: Parser TimeOfDay+timeOfDayInISO8601 =+  unnamedParser <?> "timeOfDayInISO8601"+  where+    unnamedParser =+      A.timeOfDay <$>+      (validated B.hour (decimalOfLength 2) <* char ':') <*>+      (validated B.minute (decimalOfLength 2) <* char ':') <*>+      (validated B.second (picoWithBasisOfLength 2))++{-|+>>> parseOnly dayInISO8601 "2017-02-01"+Right 2017-02-01+-}+{-# INLINE dayInISO8601 #-}+dayInISO8601 :: Parser Day+dayInISO8601 =+  unnamedParser <?> "dayInISO8601"+  where+    unnamedParser =+      do+        year <- decimalOfLength 4+        char '-'+        month <- decimalOfLength 2+        char '-'+        day <- decimalOfLength 2+        case fromGregorianValid year month day of+          Just day -> return day+          Nothing -> fail (error year month day)+      where+        error year month day =+          showString "Invalid combination of year month and day: " $ +          show (year, month, day)++{-|+>>> parseOnly timeZoneInISO8601 "+01:00"+Right +0100++>>> parseOnly timeZoneInISO8601 "+0100"+Right +0100++>>> parseOnly timeZoneInISO8601 "-0100"+Right -0100++>>> parseOnly timeZoneInISO8601 "Z"+Right UTC+-}+timeZoneInISO8601 :: Parser TimeZone+timeZoneInISO8601 =+  unnamedParser <?> "timeZoneInISO8601"+  where+    unnamedParser =+      z <|> offset+      where+        z =+          char 'Z' $> utc+        offset =+          A.timeZone <$> sign <*> decimalOfLength 2 <*> (char ':' *> decimalOfLength 2 <|> decimalOfLength 2 <|> pure 0)++{-|+>>> parseOnly utcTimeInISO8601 "2017-02-01T05:03:58+01:00"+Right 2017-02-01 04:03:58 UTC+-}+utcTimeInISO8601 :: Parser UTCTime+utcTimeInISO8601 =+  unnamedParser <?> "utcTimeInISO8601"+  where+    unnamedParser =+      do+        day <- dayInISO8601+        char 'T'+        time <- timeOfDayInISO8601+        zone <- timeZoneInISO8601+        return (A.utcTimeFromDayAndTimeOfDay day time zone)
+ library/Attoparsec/Time/Constructors.hs view
@@ -0,0 +1,38 @@+-- |+-- Efficient construction functions for values of the \"time\" library.+module Attoparsec.Time.Constructors where++import Attoparsec.Time.Prelude+++{-# INLINE timeZone #-}+timeZone :: Bool -> Int -> Int -> TimeZone+timeZone positive hour minute =+  minutesToTimeZone $+  bool negate id positive $+  hour * 60 + minute++{-# INLINE day #-}+day :: Int -> Int -> Int -> Day+day y m d =+  fromGregorian (fromIntegral y) m d++{-# INLINE timeOfDay #-}+timeOfDay :: Int -> Int -> Pico -> TimeOfDay+timeOfDay =+  TimeOfDay++{-# INLINE zonedTime #-}+zonedTime :: Day -> TimeOfDay -> TimeZone -> ZonedTime+zonedTime day tod tz =+  ZonedTime (LocalTime day tod) tz++{-# INLINE utcTimeFromDayAndTimeOfDay #-}+utcTimeFromDayAndTimeOfDay :: Day -> TimeOfDay -> TimeZone -> UTCTime+utcTimeFromDayAndTimeOfDay day tod tz =+  zonedTimeToUTC (zonedTime day tod tz)++{-# INLINE utcTimeFromComponents #-}+utcTimeFromComponents :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> TimeZone -> UTCTime+utcTimeFromComponents year month day hour minute second millisecond timeZone =+  undefined
+ library/Attoparsec/Time/Prelude.hs view
@@ -0,0 +1,17 @@+module Attoparsec.Time.Prelude+( +  module Exports,+)+where++-- base-prelude+-------------------------+import BasePrelude as Exports hiding (second)++-- text+-------------------------+import Data.Text as Exports (Text)++-- time+-------------------------+import Data.Time as Exports
+ library/Attoparsec/Time/Validators.hs view
@@ -0,0 +1,43 @@+module Attoparsec.Time.Validators where++import Attoparsec.Time.Prelude+++data Validator a =+  Validator String (a -> Bool)++run :: Show a => Validator a -> b -> (String -> b) -> a -> b+run (Validator name predicate) onNoError onError input =+  if predicate input+    then+      onNoError+    else+      onError $+      showString "Validator " $+      shows name $+      showString " failed on the following input: " $+      show input++month :: (Num a, Ord a) => Validator a+month =+  Validator "month" (liftA2 (&&) (>= 1) (<= 12))++monthDay :: (Num a, Ord a) => Validator a+monthDay =+  Validator "monthDay" (liftA2 (&&) (>= 1) (<= 31))++weekDay :: (Num a, Ord a) => Validator a+weekDay =+  Validator "weekDay" (liftA2 (&&) (>= 1) (<= 7))++hour :: (Num a, Ord a) => Validator a+hour =+  Validator "hour" (liftA2 (&&) (>= 0) (< 24))++minute :: (Num a, Ord a) => Validator a+minute =+  Validator "minute" (liftA2 (&&) (>= 0) (< 60))++second :: (Num a, Ord a) => Validator a+second =+  Validator "second" (liftA2 (&&) (>= 0) (< 60))