From 61c983bd242ec45726ce572e85c069ca9274c71e Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Tue, 1 Mar 2016 07:34:23 +0100
Subject: Cleanup

---
 tprint/src/Options/Utils.hs | 48 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 48 insertions(+)
 create mode 100644 tprint/src/Options/Utils.hs

(limited to 'tprint/src/Options')

diff --git a/tprint/src/Options/Utils.hs b/tprint/src/Options/Utils.hs
new file mode 100644
index 0000000..80b4a7e
--- /dev/null
+++ b/tprint/src/Options/Utils.hs
@@ -0,0 +1,48 @@
+module Options.Utils
+       ( rCI
+       , rTime
+       , pRange
+       ) where
+
+import Options.Applicative
+
+import Data.Char
+import Data.Maybe
+import Data.List
+import Text.Read
+
+import Data.Time
+
+import Thermoprint.Client (Range(..))
+
+rCI :: (Read a, Show a) => ReadM a
+rCI = eitherReader rRep'
+  where
+    rRep' str = case mapMaybe readMaybe $ cases str of
+      []  -> Left $ "Could not parse `" ++ str ++ "'"
+      [x] -> Right x
+      xs  -> Left $ "Ambiguous parse for `" ++ str ++ "': " ++ show xs
+    cases []     = []
+    cases (c:cs) = [(c':cs') | c' <- [toLower c, toUpper c], cs' <- cases cs]
+
+rTime :: ReadM UTCTime
+rTime = eitherReader rTime'
+  where
+    rTime' str = maybe (Left $ "Could not parse `" ++ str ++ "' as a specification of time -- try the output of `date -u +'%Y-%m-%d %H:%M:%S' \"" ++ str ++ "\"`") Right
+      . foldr (<|>) Nothing
+      $ map (flip (parseTimeM True defaultTimeLocale) str) ( "%c" : "%s" : perms' [ [time, date, timezone] | time <- ["%T", "%X", "%I:%M:%S", "%r", "%X%Q", "%I:%M:%S%Q %p"], date <- ["%x", "%F"], timezone <- ["%z", "%Z"]] )
+    perms' :: [[String]] -> [String]
+    perms' = map unwords . concatMap subsequences . concatMap permutations
+
+pRange :: ReadM a
+          -> Mod OptionFields a -- ^ Modifiers applied to both min & max
+          -> Mod OptionFields a -- ^ Modifiers for minimum
+          -> Mod OptionFields a -- ^ Modifiers for maximum
+          -> Parser (Maybe (Range a))
+pRange r both min max = toRange <$> optional (option r (both <> min)) <*> optional (option r (both <> max))
+  where
+    toRange Nothing Nothing = Nothing
+    toRange (Just min) Nothing = Just $ Min min
+    toRange Nothing (Just max) = Just $ Max max
+    toRange (Just min) (Just max) = Just $ min `Through` max
+
-- 
cgit v1.2.3