First work on argument parsing

3 files changed, 171 insertions, 4 deletions

diff --git a/tprint/src/Main.hs b/tprint/src/Main.hs
index e9e1deb..e8d4670 100644
--- a/tprint/src/Main.hs
+++ b/tprint/src/Main.hs
@@ -1,2 +1,164 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time
+       
+import Data.Foldable
+import Data.Char
+import Text.Read
+import Data.Maybe
+import Data.List
+
+import GHC.Generics (Generic)
+
+import Text.Show.Pretty (Value, PrettyVal(..), dumpStr)
+import qualified Text.Show.Pretty as PShow (Value(..))
+
+import Thermoprint.Client
+import Options.Applicative
+
+import Debug.Trace
+
+instance PrettyVal Scheme
+instance PrettyVal BaseUrl
+instance PrettyVal PrinterId
+instance PrettyVal JobId
+instance PrettyVal DraftId
+instance PrettyVal a => PrettyVal (Range a)
+
+instance PrettyVal UTCTime where
+  prettyVal = PShow.String . formatTime defaultTimeLocale "%Z %F %X"
+
+instance PrettyVal Text where
+  prettyVal = prettyVal . T.unpack
+
+data TPrint = TPrint
+  { baseUrl :: BaseUrl
+  , dryRun :: Bool
+  , output :: Output
+  , operation :: Operation
+  }
+  deriving (Show, Generic, PrettyVal)
+
+data Operation
+  = Printers
+  | Jobs
+    { printer :: Maybe PrinterId
+    , jobRange :: Maybe (Range JobId)
+    , timeRange :: Maybe (Range UTCTime)
+    }
+  | JobCreate
+    { printer :: Maybe PrinterId
+    , input :: Input
+    }
+  | Job { jobId :: JobId }
+  | JobStatus { jobId :: JobId }
+  | JobDelete { jobId :: JobId }
+  | Drafts
+  | DraftCreate
+    { draftTitle :: Maybe DraftTitle
+    , input :: Input
+    }
+  | DraftReplace
+    { draftId :: DraftId
+    , draftTitle :: Maybe DraftTitle
+    , input :: Input
+    }
+  | Draft { draftId :: DraftId }
+  | DraftDelete { draftId :: DraftId }
+  | DraftPrint
+    { draftId :: DraftId
+    , printer :: Maybe PrinterId
+    }
+  deriving (Show, Generic, PrettyVal)
+
+type Input  = (Format, Source)
+type Output = (Format, Sink  )
+
+data Format = Human | BBCode | Internal | JSON
+  deriving (Enum, Bounded, Show, Read, Generic, PrettyVal)
+
+data Source = Stdin | ReadFile FilePath
+  deriving (Show, Generic, PrettyVal)
+
+data Sink = Stdout | WriteFile FilePath
+  deriving (Show, Generic, PrettyVal)
+
+cmdPrinters :: ParserInfo Operation
+cmdPrinters = info cmdPrinters' $ mconcat [ header "List all available printers"
+                                          ]
+  where cmdPrinters' = pure Printers
+
+cmdJobs :: ParserInfo Operation
+cmdJobs = info cmdJobs' $ mconcat [ header "List printjobs"
+                                  ]
+  where
+    cmdJobs' = Jobs
+      <$> optional (option (PrinterId <$> auto) $ metavar "PRINTER" <> long "printer" <> short 'p' <> help "List only jobs associated with printer #PRINTER")
+      <*> pRange (JobId <$> auto) (metavar "JOB") (long "min-job" <> short 'j' <> help "List only jobs with id greater than or equal to JOB") (long "max-job" <> short 'J' <> help "List only jobs with id less than or equal to JOB")
+      <*> pRange rTime (metavar "TIME") (long "min-time" <> short 't' <> help "List only jobs created after or at TIME") (long "max-time" <> short 'T' <> help "List only jobs created before or at TIME")
+
+pOperation :: Parser Operation
+pOperation = hsubparser $ mconcat [ command "printers" cmdPrinters
+                                  , command "jobs" cmdJobs
+                                  ]
+
+pTPrint :: Parser TPrint
+pTPrint = TPrint <$> option (eitherReader parseBaseUrl) (metavar "URL" <> long "baseurl" <> short 'u' <> help "Server to interact with" <> value (BaseUrl Http "localhost" 3000) <> showDefaultWith showBaseUrl)
+  <*> switch (long "dry-run" <> short 'n' <> help "Don't send any requests that would be expected to change the servers state" <> showDefault)
+  <*> pOutput
+  <*> pOperation
+
+pOutput :: Parser Output
+pOutput = (,) <$> pOutputFormat <*> pSink
+  where
+    pOutputFormat = option ciAuto $ metavar "FORMAT" <> long "output-format" <> short 'O' <> help ("Format to use for all output (possible values: " ++ show ([minBound..maxBound] :: [Format]) ++ ")") <> value Human <> showDefault
+    pSink = option rSink $ metavar "PATH" <> long "output" <> short 'o' <> help "Send output to PATH (`-' means stdout)" <> value Stdout <> showDefault
+    rSink = rSink' <$> str
+      where
+        rSink' "-" = Stdout
+        rSink' x   = WriteFile x
+
+ciAuto :: (Read a, Show a) => ReadM a
+ciAuto = 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
+
 main :: IO ()
-main = undefined
+main = customExecParser (prefs $ showHelpOnError) (info pTPrint $ header "tprint - A cli interface to Thermoprint.Client") >>= tprint
+
+tprint :: TPrint -> IO ()
+tprint = putStrLn . dumpStr -- *DEBUG*
diff --git a/tprint/tprint.cabal b/tprint/tprint.cabal
index e7a5797..d61ea01 100644
--- a/tprint/tprint.cabal
+++ b/tprint/tprint.cabal
@@ -24,6 +24,10 @@ executable tprint
                      , thermoprint-bbcode >=1.0.0 && <2
                      , thermoprint-client ==0.0.*
                      , optparse-applicative >=0.12.1 && <1
+                     , containers >=0.5.6 && <1
+                     , time >=1.5.0 && <2
+                     , pretty-show >=1.6.9 && <2
+                     , text -any
   hs-source-dirs:      src
   default-language:    Haskell2010
   ghc-options:         -Wall
\ No newline at end of file
diff --git a/tprint/tprint.nix b/tprint/tprint.nix
index 413774a..9954b02 100644
--- a/tprint/tprint.nix
+++ b/tprint/tprint.nix
@@ -1,5 +1,5 @@
-{ mkDerivation, base, optparse-applicative, stdenv
-, thermoprint-bbcode, thermoprint-client
+{ mkDerivation, base, containers, optparse-applicative, pretty-show
+, stdenv, thermoprint-bbcode, thermoprint-client, time
 }:
 mkDerivation {
   pname = "tprint";
@@ -8,7 +8,8 @@ mkDerivation {
   isLibrary = false;
   isExecutable = true;
   executableHaskellDepends = [
-    base optparse-applicative thermoprint-bbcode thermoprint-client
+    base containers optparse-applicative pretty-show thermoprint-bbcode
+    thermoprint-client time
   ];
   homepage = "http://dirty-haskell.org/tags/thermoprint.html";
   description = "A CLI for thermoprint-client";