implemented build-type option parsing

fabb · Feb 15, 2019 · f28dd91 · f28dd91
1 parent b502767
commit f28dd91
Show file tree

Hide file tree

Showing 3 changed files with 38 additions and 3 deletions.
diff --git a/src/CommandParsers.hs b/src/CommandParsers.hs
@@ -79,6 +79,22 @@ platformsParser
     filter (not . null) $ filter isLetter <$> wordsBy (not . isLetter) s
   platformListOrError s = mapM platformOrError $ splitPlatforms s
 
+buildTypeParser :: Opts.Parser BuildType
+buildTypeParser = Opts.option
+  (eitherReader buildTypeOrError)
+  (  Opts.value Carthage
+  <> Opts.metavar "TYPE"
+  <> Opts.long "build-type"
+  <> Opts.help "Build type of the project. One of Carthage or PodBuilder."
+  )
+ where
+  buildTypeOrError s = maybeToEither
+    (  "Unrecognized build-type '"
+    ++ s
+    ++ "', expected 'Carthage' or 'PodBuilder'"
+    )
+    (readMaybe s)
+
 udcPayloadParser :: Opts.Parser RomeUDCPayload
 udcPayloadParser =
   RomeUDCPayload
@@ -88,6 +104,7 @@ udcPayloadParser =
     <*> skipLocalCacheParser
     <*> noIgnoreParser
     <*> noSkipCurrentParser
+    <*> buildTypeParser
 
 uploadParser :: Opts.Parser RomeCommand
 uploadParser = pure Upload <*> udcPayloadParser
@@ -133,6 +150,7 @@ listPayloadParser =
     <*> printFormatParser
     <*> noIgnoreParser
     <*> noSkipCurrentParser
+    <*> buildTypeParser
 
 listParser :: Opts.Parser RomeCommand
 listParser = List <$> listPayloadParser

diff --git a/src/Lib.hs b/src/Lib.hs
@@ -125,7 +125,7 @@ runUDCCommand command absoluteRomefilePath verbose romeVersion = do
 
   case command of
 
-    Upload (RomeUDCPayload gitRepoNames platforms cachePrefixString skipLocalCache noIgnoreFlag noSkipCurrentFlag)
+    Upload (RomeUDCPayload gitRepoNames platforms cachePrefixString skipLocalCache noIgnoreFlag noSkipCurrentFlag buildType)
       -> sayVersionWarning romeVersion verbose
         *> performWithDefaultFlow
              uploadArtifacts
@@ -138,7 +138,7 @@ runUDCCommand command absoluteRomefilePath verbose romeVersion = do
              mlCacheDir
              platforms
 
-    Download (RomeUDCPayload gitRepoNames platforms cachePrefixString skipLocalCache noIgnoreFlag noSkipCurrentFlag)
+    Download (RomeUDCPayload gitRepoNames platforms cachePrefixString skipLocalCache noIgnoreFlag noSkipCurrentFlag buildType)
       -> sayVersionWarning romeVersion verbose
         *> performWithDefaultFlow
              downloadArtifacts
@@ -151,7 +151,7 @@ runUDCCommand command absoluteRomefilePath verbose romeVersion = do
              mlCacheDir
              platforms
 
-    List (RomeListPayload listMode platforms cachePrefixString printFormat noIgnoreFlag noSkipCurrentFlag)
+    List (RomeListPayload listMode platforms cachePrefixString printFormat noIgnoreFlag noSkipCurrentFlag buildType)
       -> do
 
         currentVersion <- deriveCurrentVersion

diff --git a/src/Types/Commands.hs b/src/Types/Commands.hs
@@ -2,6 +2,9 @@ module Types.Commands where
 
 import           Data.Romefile
 import           Data.Carthage.TargetPlatform
+import           Text.Read
+import qualified Text.Read.Lex                 as L
+import           Data.Char                      ( toLower )
 
 data RomeCommand = Upload RomeUDCPayload
                   | Download RomeUDCPayload
@@ -18,6 +21,7 @@ data RomeUDCPayload = RomeUDCPayload { _payload            :: [ProjectName]
                                      , _skipLocalCacheFlag :: SkipLocalCacheFlag
                                      , _noIgnoreFlag       :: NoIgnoreFlag
                                      , _noSkipCurrentFlag  :: NoSkipCurrentFlag
+                                     , _buildType          :: BuildType
                                      }
                                      deriving (Show, Eq)
 
@@ -39,12 +43,25 @@ newtype NoIgnoreFlag = NoIgnoreFlag { _noIgnore :: Bool }
 newtype NoSkipCurrentFlag = NoSkipCurrentFlag { _noSkipCurrent :: Bool }
                                               deriving (Show, Eq)
 
+data BuildType = Carthage
+               | PodBuilder
+               deriving (Show, Eq)
+
+instance Read BuildType where
+    readPrec = parens $ do
+    L.Ident s <- lexP
+    case map toLower s of
+        "carthage"   -> return Carthage
+        "podbuilder" -> return PodBuilder
+        a            -> error $ "Unrecognized BuildType '" ++ a ++ "'"
+
 data RomeListPayload = RomeListPayload { _listMode              :: ListMode
                                        , _listPlatforms         :: [TargetPlatform]
                                        , _listCachePrefix       :: String
                                        , _listFormat            :: PrintFormat
                                        , _listNoIgnoreFlag      :: NoIgnoreFlag
                                        , _listNoSkipCurrentFlag :: NoSkipCurrentFlag
+                                       , _listBuildType         :: BuildType
                                        }
                                        deriving (Show, Eq)