1 files changed, 90 insertions, 0 deletions
diff --git a/Coalpit/Parsing.hs b/Coalpit/Parsing.hs
new file mode 100644
index 0000000..f8fe8fc
--- /dev/null
+++ b/Coalpit/Parsing.hs
@@ -0,0 +1,90 @@
+{- |
+Module      :  Coalpit.Parsing
+Description :  Argument parsing facilities
+Maintainer  :  defanor <defanor@uberspace.net>
+Stability   :  unstable
+Portability :  non-portable (uses GHC extensions)
+
+This module provides functions useful for argument parsing.
+-}
+
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Coalpit.Parsing ( Parser
+                       , CLArg(..)
+                       , pS
+                       , readArg
+                       , pTime
+                       ) where
+
+import Text.Megaparsec
+import Data.Proxy (Proxy(..))
+import Data.Time.Format (TimeLocale, ParseTime, readSTime)
+import Data.Void (Void)
+import qualified Data.List.NonEmpty as NE
+import Data.List (foldl')
+import Data.Semigroup ((<>))
+
+-- | Command-line argument wrapper, used to avoid orphan ShowToken
+-- String and Stream [String] instances.
+newtype CLArg = CLArg { unArg :: String }
+  deriving (Ord, Eq)
+
+-- | Advances by one token.
+advance :: Pos -> SourcePos -> t -> SourcePos
+advance _ (SourcePos n l c) _ = SourcePos n l (c <> pos1)
+
+-- | A list of strings (command-line arguments) stream.
+instance Stream [CLArg] where
+  type Token [CLArg] = CLArg
+  type Tokens [CLArg] = [CLArg]
+  tokenToChunk Proxy = pure
+  tokensToChunk Proxy = id
+  chunkToTokens Proxy = id
+  chunkLength Proxy = length
+  chunkEmpty Proxy = null
+  advance1 Proxy = advance
+  advanceN Proxy w = foldl' (advance w)
+  take1_ [] = Nothing
+  take1_ (t:ts) = Just (t, ts)
+  takeN_ n s
+    | n <= 0    = Just ([], s)
+    | null s    = Nothing
+    | otherwise = Just (splitAt n s)
+  takeWhile_ = span
+
+instance ShowToken CLArg where
+  showTokens xs = concat $ NE.map unArg xs
+
+-- | Command-line arguments parser.
+type Parser = Parsec Void [CLArg]
+
+-- | Applies a String parser to a single argument.
+pS :: Parsec Void String a -> Parsec Void [CLArg] a
+pS p = try $ do
+  x <- token (Right . unArg) Nothing
+  case parse p "argument" x of
+    Left e -> fail $ show e
+    Right x' -> pure x'
+
+-- | Reads an argument using its 'Read' instance.
+readArg :: Read a => Parser a
+readArg = do
+  x <- token (Right . unArg) Nothing
+  case reads x of
+    [(n, "")] -> pure n
+    _ -> fail $ "Failed to read: " ++ x
+
+-- | Parses a time argument.
+pTime :: ParseTime a
+      => TimeLocale
+      -- ^ Options, to read 'timeLocale' from.
+      -> String
+      -- ^ Time format to use.
+      -> Parser a
+pTime tl tf = try $ do
+    x <- token (Right . unArg) Nothing
+    case readSTime False tl tf x of
+      [(t, "")] -> pure t
+      _ -> fail "Failed to parse time"