From 62aa7bb8ba54c2a0f480e122c46d967f2102dac5 Mon Sep 17 00:00:00 2001
From: defanor <defanor@uberspace.net>
Date: Tue, 19 Dec 2017 07:58:16 +0300
Subject: Reorganize the modules

---
 Coalpit/Core.hs | 466 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 Coalpit/DSV.hs  |  17 ++-
 2 files changed, 480 insertions(+), 3 deletions(-)
 create mode 100644 Coalpit/Core.hs

(limited to 'Coalpit')

diff --git a/Coalpit/Core.hs b/Coalpit/Core.hs
new file mode 100644
index 0000000..3e84b23
--- /dev/null
+++ b/Coalpit/Core.hs
@@ -0,0 +1,466 @@
+{- |
+Module      :  Coalpit.Core
+Description :  Core Coalpit definitions
+Maintainer  :  defanor <defanor@uberspace.net>
+Stability   :  unstable
+Portability :  non-portable (uses GHC extensions)
+
+The 'Coalpit' class with instances, a few functions to work with it,
+and 'Options' are defined here.
+-}
+
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Coalpit.Core ( Coalpit(..)
+                    -- * Utility functions
+                    , fromArgs
+                    , usage
+                    -- * Options
+                    , Options(..)
+                    , defOpt
+                    ) where
+
+import GHC.Generics
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import Data.Char (toLower)
+import Data.Proxy (Proxy(..))
+import qualified Data.List.NonEmpty as NE
+import Data.Word (Word8, Word16, Word32, Word64)
+import Numeric.Natural (Natural)
+import Data.Int (Int8, Int16, Int32, Int64)
+import Data.Time.Clock (DiffTime, NominalDiffTime, UniversalTime, UTCTime)
+import Data.Time.Format ( TimeLocale, formatTime
+                        , iso8601DateFormat, defaultTimeLocale)
+import Data.Time.Calendar (Day)
+import Data.Time.LocalTime (TimeOfDay, LocalTime, ZonedTime)
+import Data.Scientific (Scientific, FPFormat(..), formatScientific, scientificP)
+import Text.ParserCombinators.ReadP (readP_to_S)
+import Data.Complex (Complex)
+import Data.Version (Version, parseVersion, showVersion)
+import System.Exit (ExitCode)
+import Network.URI (URI, parseURIReference, uriToString)
+
+import Coalpit.Parsing
+
+-- | Printing and parsing options.
+data Options = Options { fieldSeparator :: Char
+                       -- ^ DSV field separator ('showDSV',
+                       -- 'readDSV').
+                       , conNameMod :: String -> String
+                       -- ^ Constructor name modifier.
+                       , selNameMod :: String -> String
+                       -- ^ Record selector name modifier.
+                       , alwaysUseSelName :: Bool
+                       -- ^ Add record selector name always, not just
+                       -- for optional arguments.
+                       , omitNamedOptions :: Bool
+                       -- ^ Omit named Maybe values to indicate
+                       -- 'Nothing'.
+                       , timeLocale :: TimeLocale
+                       , dateFormat :: String
+                       -- ^ See "Data.Time.Format".
+                       , timeFormat :: String
+                       , dateTimeFormat :: String
+                       , scientificFormat :: FPFormat
+                       , scientificDecimals :: Maybe Int
+                       , uriUserInfo :: String -> String
+                       -- ^ Used to map userinfo parts of URIs.
+                       }
+
+-- | Default options.
+defOpt :: Options
+defOpt = Options ' ' (map toLower) (("--" ++) . map toLower) False True
+  defaultTimeLocale (iso8601DateFormat Nothing) "%H:%M:%S"
+  (iso8601DateFormat (Just "%H:%M:%S")) Generic Nothing id
+
+-- | Parses arguments.
+fromArgs :: Coalpit a => Options -> [String] -> Either String a
+fromArgs opt args = case parse (argParser opt) "arguments" (map CLArg args) of
+  Left err -> Left $ parseErrorPretty err
+  Right x -> Right x
+
+-- | Composes a usage string.
+usage :: Coalpit a => Options -> Proxy a -> String
+usage opt = argHelper opt []
+
+-- | Coalpit class: parsing, printing, usage strings.
+class Coalpit a where
+  argParser :: Options -> Parser a
+  default argParser :: (Generic a, GCoalpit (Rep a)) => Options -> Parser a
+  argParser opt = to <$> gArgParser opt
+
+  toArgs :: Options -> a -> [String]
+  default toArgs :: (Generic a, GCoalpit (Rep a)) => Options -> a -> [String]
+  toArgs opt a = gToArgs opt (from a)
+
+  argHelper :: Options -> [String] -> Proxy a -> String
+  default argHelper :: (GCoalpit (Rep a))
+                    => Options -> [String] -> Proxy a -> String
+  argHelper opt path Proxy = gArgHelper opt path (Proxy :: Proxy (Rep a p))
+
+class GCoalpit a where
+  gArgParser :: Options -> Parser (a p)
+  gToArgs :: Options -> a p -> [String]
+  gArgHelper :: Options -> [String] -> Proxy (a p) -> String
+
+
+-- Units
+instance GCoalpit U1 where
+  gArgParser _ = pure U1
+  gToArgs _ U1 = []
+  gArgHelper _ _ (Proxy :: Proxy (U1 f)) = ""
+
+
+-- Products
+instance (GCoalpit a, GCoalpit b) => GCoalpit (a :*: b) where
+  gArgParser opt = (:*:) <$> gArgParser opt <*> gArgParser opt
+  gToArgs opt (x :*: y) = gToArgs opt x ++ gToArgs opt y
+  gArgHelper opt path (Proxy :: Proxy ((a :*: b) p)) =
+    concat [ gArgHelper opt path (Proxy :: Proxy (a p))
+           , " "
+           , gArgHelper opt path (Proxy :: Proxy (b p))]
+
+
+-- Sums
+
+-- | Handles recursive constructors.
+handleRecCon :: GCoalpit a
+             => String
+             -- ^ Constructor name
+             -> Options
+             -> [String]
+             -> Proxy (a p)
+             -> String
+handleRecCon nameA opt path (Proxy :: Proxy (a p)) = conNameMod opt nameA
+  ++ if nameA `elem` path
+     then "..."
+     else case gArgHelper opt (nameA : path) (Proxy :: Proxy (a p)) of
+            "" -> ""
+            s -> ' ' : s
+
+instance (Constructor conA, GCoalpit a, GCoalpit (b :+: c)) =>
+  GCoalpit ((b :+: c) :+: C1 conA a) where
+  gArgParser opt =
+    L1 <$> gArgParser opt
+    <|>
+    R1 <$> (pS (string (conNameMod opt $ conName (undefined :: C1 conA a p)))
+            *> gArgParser opt)
+  gToArgs opt (L1 x) = gToArgs opt x
+  gToArgs opt (R1 x) = conNameMod opt (conName x) : gToArgs opt x
+  gArgHelper opt path (Proxy :: Proxy (((b :+: c) :+: C1 conA a) p)) =
+    let nameA = conName (undefined :: C1 conA f p)
+    in concat [ "("
+              , gArgHelper opt path (Proxy :: Proxy ((b :+: c) p))
+              , " | "
+              , handleRecCon nameA opt path (Proxy :: Proxy (a p))
+              , ")"]
+
+instance (Constructor conA, GCoalpit a, GCoalpit (b :+: c)) =>
+  GCoalpit (C1 conA a :+: (b :+: c)) where
+  gArgParser opt =
+    L1 <$> (pS (string (conNameMod opt $ conName (undefined :: C1 conA a p)))
+            *> gArgParser opt)
+    <|>
+    R1 <$> gArgParser opt
+  gToArgs opt (L1 x) = conNameMod opt (conName x) : gToArgs opt x
+  gToArgs opt (R1 x) = gToArgs opt x
+  gArgHelper opt path (Proxy :: Proxy ((C1 conA a :+: (b :+: c)) p)) =
+    let nameA = conName (undefined :: C1 conA a p)
+    in concat [ "("
+              , handleRecCon nameA opt path (Proxy :: Proxy (a p))
+              , " | "
+              , gArgHelper opt path (Proxy :: Proxy ((b :+: c) p))
+              , ")"]
+
+instance (Constructor conA, Constructor conB, GCoalpit a, GCoalpit b) =>
+  GCoalpit (C1 conA a :+: C1 conB b) where
+  gArgParser opt =
+    L1 <$> (pS (string (conNameMod opt $
+                        conName (undefined :: C1 conA a p)))
+            *> gArgParser opt)
+    <|>
+    R1 <$> (pS (string (conNameMod opt $
+                        conName (undefined :: C1 conB b p)))
+            *> gArgParser opt)
+  gToArgs opt (L1 x) = conNameMod opt (conName x) : gToArgs opt x
+  gToArgs opt (R1 x) = conNameMod opt (conName x) : gToArgs opt x
+  gArgHelper opt path (Proxy :: Proxy ((C1 conA a :+: C1 conB b) p)) =
+    let nameA = conName (undefined :: C1 conA a p)
+        nameB = conName (undefined :: C1 conB b p)
+    in concat [ "("
+              , handleRecCon nameA opt path (Proxy :: Proxy (a p))
+              , " | "
+              , handleRecCon nameB opt path (Proxy :: Proxy (b p))
+              , ")"]
+
+
+-- Record Selectors
+
+parseS1 :: (GCoalpit a) => String -> Options -> Parser (S1 selA a p)
+parseS1 nameA opt =
+  let sName = case (nameA, alwaysUseSelName opt) of
+        ("", _) -> pure ()
+        (_, False) -> pure ()
+        (_, True) -> pS (string (selNameMod opt nameA)) >> pure ()
+  in M1 <$> (sName *> gArgParser opt)
+
+printS1 :: (GCoalpit a, Selector selA) => Options -> S1 selA a p -> [String]
+printS1 opt sel@(M1 x) = case (selName sel, alwaysUseSelName opt) of
+                           ("", _) -> gToArgs opt x
+                           (_, False) -> gToArgs opt x
+                           (name, True) -> selNameMod opt name : gToArgs opt x
+
+helpS1 :: (GCoalpit a)
+       => String -> Options -> [String] -> Proxy (S1 selA a p) -> String
+helpS1 nameA opt path (Proxy :: Proxy (S1 selA a p)) =
+  case (nameA, alwaysUseSelName opt) of
+    ("", _) -> gArgHelper opt path (Proxy :: Proxy (a p))
+    (_, False) -> gArgHelper opt path (Proxy :: Proxy (a p))
+    (_, True) -> concat [ selNameMod opt nameA
+                        , " "
+                        , gArgHelper opt path (Proxy :: Proxy (a p))]
+
+instance (GCoalpit a, Selector selA) => GCoalpit (S1 selA a) where
+  gArgParser = parseS1 (selName (undefined :: S1 selA a p))
+  gToArgs = printS1
+  gArgHelper = helpS1 (selName (undefined :: S1 selA a p))
+
+-- Optional arguments
+instance {-#OVERLAPPING#-}
+  (Coalpit a, Coalpit (Maybe a), Selector selA) =>
+  GCoalpit (S1 selA (Rec0 (Maybe a))) where
+  gArgParser opt =
+    let nameA = selName (undefined :: S1 selA (Rec0 (Maybe a)) p)
+    in case (omitNamedOptions opt, null nameA) of
+      (True, True) -> M1 <$> gArgParser opt
+      (True, False) ->
+        M1 . K1
+        <$> optional (pS (string (selNameMod opt nameA)) *> argParser opt)
+      _ -> parseS1 nameA opt
+  gToArgs opt sel@(M1 (K1 x))
+    | omitNamedOptions opt = case (selName sel, x) of
+        ("", _) -> toArgs opt x
+        (_, Nothing) -> []
+        (nameA, Just x') -> selNameMod opt nameA : toArgs opt x'
+    | otherwise = printS1 opt sel
+  gArgHelper opt path (Proxy :: Proxy (S1 selA (Rec0 (Maybe a)) p)) =
+    let nameA = selName (undefined :: S1 selA (Rec0 (Maybe a)) p)
+    in case (omitNamedOptions opt, null nameA) of
+      (True, True) -> gArgHelper opt path (Proxy :: Proxy (Rec0 (Maybe a) p))
+      (True, False) -> concat [ "["
+                              , selNameMod opt nameA
+                              , " "
+                              , gArgHelper opt path (Proxy :: Proxy (Rec0 a p))
+                              , "]"]
+      _ -> helpS1 nameA opt path (Proxy :: Proxy (S1 selA (Rec0 (Maybe a)) p))
+
+
+-- Constructors
+
+instance (GCoalpit a) => GCoalpit (C1 conA a) where
+  gArgParser = fmap M1 . gArgParser
+  gToArgs opt (M1 x) = gToArgs opt x
+  gArgHelper opt path (Proxy :: Proxy (C1 conA a p)) =
+    gArgHelper opt path (Proxy :: Proxy (a p))
+
+-- Data types
+instance (GCoalpit a) => GCoalpit (D1 conA a) where
+  gArgParser = fmap M1 . gArgParser
+  gToArgs opt (M1 x) = gToArgs opt x
+  gArgHelper opt path (Proxy :: Proxy (D1 conA a p)) =
+    gArgHelper opt path (Proxy :: Proxy (a p))
+
+-- Constraints and such
+instance (Coalpit a) => GCoalpit (K1 i a) where
+  gArgParser = fmap K1 . argParser
+  gToArgs opt (K1 x) = toArgs opt x
+  gArgHelper opt path (Proxy :: Proxy (K1 x a p)) =
+    argHelper opt path (Proxy :: Proxy a)
+
+
+-- Common types
+
+instance Coalpit Int where
+  argParser _ = readArg
+  toArgs _ i = [show i]
+  argHelper _ _ _ = "INT"
+
+instance Coalpit Integer where
+  argParser _ = readArg
+  toArgs _ i = [show i]
+  argHelper _ _ _ = "INTEGER"
+
+instance Coalpit Word8 where
+  argParser _ = readArg
+  toArgs _ i = [show i]
+  argHelper _ _ _ = "WORD8"
+
+instance Coalpit Word16 where
+  argParser _ = readArg
+  toArgs _ i = [show i]
+  argHelper _ _ _ = "WORD16"
+
+instance Coalpit Word32 where
+  argParser _ = readArg
+  toArgs _ i = [show i]
+  argHelper _ _ _ = "WORD32"
+
+instance Coalpit Word64 where
+  argParser _ = readArg
+  toArgs _ i = [show i]
+  argHelper _ _ _ = "WORD64"
+
+instance Coalpit Int8 where
+  argParser _ = readArg
+  toArgs _ i = [show i]
+  argHelper _ _ _ = "INT8"
+
+instance Coalpit Int16 where
+  argParser _ = readArg
+  toArgs _ i = [show i]
+  argHelper _ _ _ = "INT16"
+
+instance Coalpit Int32 where
+  argParser _ = readArg
+  toArgs _ i = [show i]
+  argHelper _ _ _ = "INT32"
+
+instance Coalpit Int64 where
+  argParser _ = readArg
+  toArgs _ i = [show i]
+  argHelper _ _ _ = "INT64"
+
+instance Coalpit Natural where
+  argParser _ = readArg
+  toArgs _ i = [show i]
+  argHelper _ _ _ = "NATURAL"
+
+instance Coalpit Rational where
+  argParser _ = readArg
+  toArgs _ i = [show i]
+  argHelper _ _ _ = "RATIONAL"
+
+instance Coalpit Double where
+  argParser _ = readArg
+  toArgs _ i = [show i]
+  argHelper _ _ _ = "DOUBLE"
+
+instance Coalpit Float where
+  argParser _ = readArg
+  toArgs _ i = [show i]
+  argHelper _ _ _ = "FLOAT"
+
+instance Coalpit Char where
+  argParser _ = readArg
+  toArgs _ c = [show c]
+  argHelper _ _ _ = "CHAR"
+
+instance {-#OVERLAPPING#-} Coalpit String where
+  argParser _ = token (Right . unArg) Nothing
+  toArgs _ i = [i]
+  argHelper _ _ _ = "STRING"
+
+-- | A dot (".").
+instance Coalpit () where
+  argParser _ = pS (char '.') *> pure ()
+  toArgs _ () = ["."]
+  argHelper _ _ _ = "."
+
+instance Coalpit Scientific where
+  argParser _ = try $ do
+    x <- token (Right . unArg) Nothing
+    case reverse $ readP_to_S scientificP x of
+      (n, ""):_ -> pure n
+      _ -> fail $ "Failed to read a scientific number: " ++ x
+  toArgs opt n = [formatScientific
+                  (scientificFormat opt) (scientificDecimals opt) n]
+  argHelper _ _ _ = "SCIENTIFIC"
+
+instance Coalpit Version where
+  argParser _ = try $ do
+    x <- token (Right . unArg) Nothing
+    case reverse $ readP_to_S parseVersion x of
+      (v, ""):_ -> pure v
+      _ -> fail $ "Failed to read a version: " ++ x
+  toArgs _ v = [showVersion v]
+  argHelper _ _ _ = "VERSION"
+
+-- | An URI reference (absolute or relative).
+instance Coalpit URI where
+  argParser _ = try $ do
+    x <- token (Right . unArg) Nothing
+    maybe (fail $ "Failed to parse URI: " ++ x) pure (parseURIReference x)
+  toArgs opt u = [uriToString (uriUserInfo opt) u ""]
+  argHelper _ _ _ = "URI"
+
+
+-- | Uses 'dateTimeFormat'.
+instance Coalpit UTCTime where
+  argParser opt = pTime (timeLocale opt) (dateTimeFormat opt)
+  toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]
+  argHelper _ _ _ = "UTC_TIME"
+
+-- | Uses 'dateTimeFormat'.
+instance Coalpit ZonedTime where
+  argParser opt = pTime (timeLocale opt) (dateTimeFormat opt)
+  toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]
+  argHelper _ _ _ = "ZONED_TIME"
+
+-- | Uses 'dateTimeFormat'.
+instance Coalpit LocalTime where
+  argParser opt = pTime (timeLocale opt) (dateTimeFormat opt)
+  toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]
+  argHelper _ _ _ = "LOCAL_TIME"
+
+-- | Uses 'dateTimeFormat'.
+instance Coalpit UniversalTime where
+  argParser opt = pTime (timeLocale opt) (dateTimeFormat opt)
+  toArgs opt t = [formatTime (timeLocale opt) (dateTimeFormat opt) t]
+  argHelper _ _ _ = "UNIVERSAL_TIME"
+
+-- | Uses 'timeFormat'.
+instance Coalpit TimeOfDay where
+  argParser opt = pTime (timeLocale opt) (timeFormat opt)
+  toArgs opt t = [formatTime (timeLocale opt) (timeFormat opt) t]
+  argHelper _ _ _ = "TIME_OF_DAY"
+
+-- | Uses 'dateFormat'.
+instance Coalpit Day where
+  argParser opt = pTime (timeLocale opt) (dateFormat opt)
+  toArgs opt t = [formatTime (timeLocale opt) (dateFormat opt) t]
+  argHelper _ _ _ = "DAY"
+
+-- | Converts to/from 'Scientific'.
+instance Coalpit NominalDiffTime where
+  argParser opt = fromRational . toRational
+                  <$> (argParser opt :: Parser Scientific)
+  toArgs opt = toArgs opt .
+    (fromRational . toRational :: NominalDiffTime -> Scientific)
+  argHelper _ _ _ = "NOMINAL_DIFF_TIME"
+
+-- | Converts to/from 'Scientific'.
+instance Coalpit DiffTime where
+  argParser opt = fromRational . toRational
+                  <$> (argParser opt :: Parser Scientific)
+  toArgs opt = toArgs opt .
+    (fromRational . toRational :: DiffTime -> Scientific)
+  argHelper _ _ _ = "DIFF_TIME"
+
+
+instance Coalpit Bool
+instance Coalpit Ordering
+instance Coalpit ExitCode
+instance Coalpit a => Coalpit (Complex a)
+instance Coalpit a => Coalpit (Maybe a)
+instance Coalpit a => Coalpit [a]
+instance Coalpit a => Coalpit (NE.NonEmpty a)
+instance (Coalpit a, Coalpit b) => Coalpit (Either a b)
+instance (Coalpit a, Coalpit b) => Coalpit (a, b)
+instance (Coalpit a, Coalpit b, Coalpit c) => Coalpit (a, b, c)
+instance (Coalpit a, Coalpit b, Coalpit c, Coalpit d) => Coalpit (a, b, c, d)
diff --git a/Coalpit/DSV.hs b/Coalpit/DSV.hs
index f11f830..4940843 100644
--- a/Coalpit/DSV.hs
+++ b/Coalpit/DSV.hs
@@ -1,23 +1,25 @@
 {- |
 Module      :  Coalpit.DSV
-Description :  Argument parsing facilities
+Description :  DSV printing and parsing
 Maintainer  :  defanor <defanor@uberspace.net>
 Stability   :  unstable
 Portability :  non-portable (uses GHC extensions)
 
-This module provides functions useful for argument parsing.
+This module provides functions for DSV printing and parsing.
 -}
 
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
 
-module Coalpit.DSV (composeDSV, parseDSV) where
+module Coalpit.DSV (showDSV, readDSV) where
 
 import Data.List
 import Text.Megaparsec
 import Text.Megaparsec.Char
 import Data.Void
 
+import Coalpit.Core
+
 
 composeDSVLine :: Char -> [String] -> String
 composeDSVLine fs = intercalate [fs] . map escapeVal
@@ -63,3 +65,12 @@ parseDSV fs = map parseLine . lines
         parseLine l = case parse (pDSVLine fs) "line" l of
           Left err -> Left $ parseErrorPretty err
           Right x -> Right x
+
+
+-- | Shows values in DSV format.
+showDSV :: Coalpit a => Options -> [a] -> String
+showDSV opt = composeDSV (fieldSeparator opt) . map (toArgs opt)
+
+-- | Reads values from DSV format.
+readDSV :: Coalpit a => Options -> String -> [Either String a]
+readDSV opt = map (>>= fromArgs opt) . parseDSV (fieldSeparator opt)
-- 
cgit v1.2.3