packages feed

hydrogen-util (empty) → 0.5

raw patch · 8 files changed

+340/−0 lines, 8 filesdep +basedep +containersdep +hydrogen-preludesetup-changed

Dependencies added: base, containers, hydrogen-prelude, parsec, time

Files

+ CHANGELOG.md view
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2014 Julian Fleischer++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,2 @@+import Distribution.Simple+main = defaultMain
+ hydrogen-util.cabal view
@@ -0,0 +1,40 @@+name:                 hydrogen-util+version:              0.5+homepage:             https://github.com/scravy/hydrogen-util+synopsis:             Hydrogen Tools+license:              BSD3+license-file:         LICENSE+extra-source-files:   CHANGELOG.md+author:               Julian Fleischer+maintainer:           julfleischer@paypal.com+category:             Language+build-type:           Simple+cabal-version:        >=1.18++source-repository head+    type:             git+    location:         https://github.com/scravy/hydrogen-util++library+  exposed-modules:    Hydrogen.Util+                      , Hydrogen.Util.Files+                      , Hydrogen.Util.Parsec+                      , Hydrogen.Util.Read+  build-depends:      base ==4.7.*+                      , containers ==0.5.*+                      , hydrogen-prelude >=0.4.1+                      , parsec ==3.1.*+                      , time ==1.4.*+  hs-source-dirs:     src+  ghc-options:        -Wall+  default-language:   Haskell2010+  default-extensions:  CPP+                       , EmptyCase+                       , FlexibleContexts+                       , GADTs+                       , LambdaCase+                       , MultiWayIf+                       , NoImplicitPrelude+                       , RecordWildCards+                       , ScopedTypeVariables+
+ src/Hydrogen/Util.hs view
@@ -0,0 +1,29 @@+module Hydrogen.Util where++import Hydrogen.Prelude++-- | Infix to postfix notation (an implementation of the Shunting-Yard-Algorithm)+sya :: (Ord p, Eq o)+    => (a -> Maybe o)   -- ^ Determine operator+    -> (o -> Bool)      -- ^ Is left precedence?+    -> (o -> p)         -- ^ Precedence of given operator+    -> [a]              -- ^ The input stream (infix notation)+    -> [a]              -- ^ The output stream (postfix notation)+sya mkOp isL p = sy []+  where+    sy (t : ts) (x : xs)+        | isOp x && isOp t && cmp t x = t : sy ts (x : xs)++    sy ts (x : xs)+        | isOp x    = sy (x : ts) xs+        | otherwise = x : sy ts xs++    sy ts [] = ts++    isOp = isJust . mkOp++    cmp o1 o2 = isL o1' && p o1' == p o2' || p o1' > p o2'+      where+        Just o1' = mkOp o1+        Just o2' = mkOp o2+
+ src/Hydrogen/Util/Files.hs view
@@ -0,0 +1,78 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Hydrogen.Util.Files where++import Hydrogen.Prelude.System+import qualified Data.Set as Set+++findFilesRecursively :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath]+findFilesRecursively f dir =+    map fst <$> findFilesRecursivelyWithContext (\c _ _ -> return c) f () dir+++findFilesRecursivelyWithContext+    :: forall c.+       (c -> FilePath -> [FilePath] -> IO c)  -- ^ update function for current context+    -> (FilePath -> IO Bool)                  -- ^ predicate to filter files+    -> c                                      -- ^ current context+    -> FilePath -> IO [(FilePath, c)]+findFilesRecursivelyWithContext updater predicate context dir = do++    cwd <- getCurrentDirectory+    snd <$> find Set.empty context (cwd </> dir)++  where+    find :: Set FilePath -> c -> FilePath -> IO (Set FilePath, [(FilePath, c)])+    find visited context dir = do++      thisDirectory <- canonicalizePath dir+      if | Set.member thisDirectory visited -> return (Set.empty, [])+         | otherwise -> do++            allFiles <- map (dir </>) <$> getDirectoryContents dir+            theFiles <- filterFiles allFiles+            theDirs  <- filterM isDir allFiles+            context' <- updater context dir theFiles++            let visited' = Set.insert thisDirectory visited+                f (visited, files) dir = do+                    (visited', files') <- find visited context' dir+                    return (visited', files' : files)++            (visited'', files') <- foldM f (visited', []) theDirs+            +            return (visited'', concat (zip theFiles (repeat context') : files'))++    filterFiles = filterM (\x -> liftM2 (&&) (doesFileExist x) (predicate x))+    isDir x = liftM2 (&&) (doesDirectoryExist x) (return (head (takeFileName x) /= '.'))+++escape :: String -> String+escape s = case s of+    ('/' : xs)+        -> '_' : escape xs+    (x : xs) ->+      if | isSafeChar x -> x : escape xs+         | ord x <= 255 -> '$' : printf "%02X" (ord x) ++ escape xs+         | otherwise    -> "$$" ++ printf "%04X" (ord x) ++ escape xs+    [] -> []+  where+    isSafeChar x = isAscii x && isAlphaNum x || x `elem` ".-"+++unescape :: String -> Maybe String+unescape s = case s of+    ('$' : '$' : a : b : c : d : xs)+        -> (chr <$> hexnum (a : b : c : [d])) `cons` unescape xs+    ('$' : a : b : xs)+        -> (chr <$> hexnum (a : [b])) `cons` unescape xs+    ('_' : xs)+        -> pure '/' `cons` unescape xs+    (x : xs)+        -> pure x `cons` unescape xs+    [] -> return []+  where+    cons = liftA2 (:)+    hexnum = fmap fst . listToMaybe . readHex+
+ src/Hydrogen/Util/Parsec.hs view
@@ -0,0 +1,43 @@+module Hydrogen.Util.Parsec (+    module Text.Parsec.Combinator+  , module Text.Parsec.Prim+  , module Text.Parsec.Pos+  , Parser+  , SomethingBad+  , Tokens+  , mkError+  , sourceToken+  , (>+>)+  , (<+<)+  ) where++import Hydrogen.Prelude++import Text.Parsec.Combinator+import Text.Parsec.Error+import Text.Parsec.Pos+import Text.Parsec.Prim++type SomethingBad = (SourcePos, [String])+type Parser source result = source -> Either SomethingBad result+type Tokens t = [(SourcePos, t)]++mkError :: ParseError -> Either SomethingBad b+mkError e = Left (errorPos e, map messageString (errorMessages e))++sourceToken :: (Show t, Stream (Tokens t) m (SourcePos, t))+    => (t -> Maybe a)+    -> ParsecT [(SourcePos, t)] u m a+sourceToken f = tokenPrim (show . snd) nextPos (f . snd)+  where+    nextPos p _ = \case+        ((p', _) : _) -> p'+        _ -> p++(>+>) :: Parser a b -> Parser b c -> Parser a c+p1 >+> p2 = join <$> fmap p2 <$> p1++(<+<) :: Parser b c -> Parser a b -> Parser a c+(<+<) = flip (>+>)++
+ src/Hydrogen/Util/Read.hs view
@@ -0,0 +1,129 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Hydrogen.Util.Read where++import Hydrogen.Prelude+import Hydrogen.Prelude.Extra++import Data.Time.Calendar.OrdinalDate++ignoreUnderscores :: String -> String+ignoreUnderscores = \case+    x : xs -> x : ignore xs+    xs -> xs+  where+    ignore = \case+        xs@(x : '_' : _) | not (isAlphaNum x) -> xs+        '_' : x : xs | isAlphaNum x -> x : ignore xs+        x : xs -> x : ignore xs+        xs -> xs++tryReadDecimal :: String -> Maybe Rational+tryReadDecimal = \case+    ('-' : xs) -> negate <$> readRational xs+    ('+' : xs) -> readRational xs+    ('.' : xs) -> readRational ("0." ++ xs)+    xs -> readRational xs+  where+    readRational = tryRead readFloat . ignoreUnderscores++tryReadRational :: String -> Maybe Rational+tryReadRational xs = case right of+    (_ : right') -> liftM2 (%) numer denom+      where+        numer = tryRead reads left+        denom = tryRead reads right'++    _ -> Nothing+  where+    (left, right) = span (/= '/') (ignoreUnderscores xs)++tryReadHex :: String -> Maybe Rational+tryReadHex = tryRead readHex . ignoreUnderscores . hex+  where+    hex = \case+      '0' : 'x' : xs -> xs+      _ -> ""++tryReadUUID :: String -> Maybe UUID+tryReadUUID = tryRead reads++tryReadVersion :: String -> Maybe Version+tryReadVersion = \case+    ('v' : xs) -> tryRead reads xs+    _ -> fail "no version"++tryReadDateTime :: String -> Maybe (Maybe ZonedTime)+tryReadDateTime xs = case xs =~ dateTime of++    [[_, y, m, d, h, min, _, s, s', z, zm, _, zs]]+        -> Just (liftM2 ZonedTime (liftM2 LocalTime date time) zone)+      where+        (year, month, day, hour, minute) = (read y, read m, read d, read h, read min)+        sec = read ((if null s then "0" else s) ++ (if null s' then ".0" else s'))++        time = makeTimeOfDayValid hour minute sec+        date = fromGregorianValid year month day++        zone = Just $ case z of+            "Z" -> utc+            ('-' : _) -> minutesToTimeZone (negate zn)+            _ -> minutesToTimeZone zn+          where+            zn = read zm * 60 + (if zs == "" then 0 else read zs)++    _ -> Nothing++  where+    date = "([0-9]{4})-?([0-9]{2})-?([0-9]{2})"+    time = "([0-9]{2}):?([0-9]{2})(:?([0-9]{2})(\\.[0-9]{1,12})?)?"+    timeZone = "(Z|[+-]([0-9]{1,2})(:?([0-9]{2}))?)"+    dateTime = concat [date, "T?", time, timeZone]++tryReadDate :: String -> Maybe (Maybe Day)+tryReadDate xs = case xs =~ date of+    [[_, y, _, m, d, ""]] -> Just (fromGregorianValid year month day)+      where+        (year, month, day) = (read y, read m, read d)++    [[_, y, _, _, _, d]] -> Just (fromOrdinalDateValid year day)+      where+        (year, day) = (read y, read d)++    _ -> Nothing+  where+    date = "([0-9]{4})-(([0-9]{2})-([0-9]{2})|([0-9]{3}))"++tryReadTime :: String -> Maybe (Maybe TimeOfDay)+tryReadTime xs = case xs =~ time of+    [[_, h, m, _, s]] -> Just (makeTimeOfDayValid hour min sec)+      where+        (hour, min, sec) = (read h, read m, if null s then 0 else read s)++    _ -> Nothing+  where+    time = "([0-9]{2}):([0-9]{2})(:([0-9]{2}))?"++tryReadBool :: String -> Maybe Bool+tryReadBool = \case+    "true" -> return True+    "TRUE" -> return True+    "True" -> return True+    "false" -> return False+    "False" -> return False+    "FALSE" -> return False+    _ -> Nothing++tryRead :: (Monad m) => ReadS a -> String -> m a+tryRead p s = case p s of+    [(val, "")] -> return val+    [] -> fail "no parse"+    _ -> fail "ambiguous parse"++firstJust :: [a -> Maybe b] -> a -> Maybe b+firstJust (f : fs) v = case f v of+    Nothing -> firstJust fs v+    x -> x+firstJust [] _ = Nothing++