packages feed

servant-serf 0.2.1 → 0.3.0.1

raw patch · 27 files changed

+500/−429 lines, 27 filesdep +Cabaldep +directorydep +exceptionsdep −attoparsecdep −hpackdep −mtldep ~base

Dependencies added: Cabal, directory, exceptions, filepath, servant-serf

Dependencies removed: attoparsec, hpack, mtl, optparse-applicative, regex-base, regex-tdfa, text

Dependency ranges changed: base

Files

+ CHANGELOG.markdown view
@@ -0,0 +1,4 @@+# Change log++servant-serf follows the [Package Versioning Policy](https://pvp.haskell.org).+You can find release notes [on GitHub](https://github.com/EdutainmentLIVE/servant-serf/releases).
− LICENSE 
@@ -1,7 +0,0 @@-Copyright © 2021 EdutainmentLIVE, LLC--Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:--The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.--THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ LICENSE.markdown view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2022 ACI Learning++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.markdown view
@@ -0,0 +1,3 @@+# servant-serf++<https://hackage.haskell.org/package/servant-serf>
− README.md 
@@ -1,55 +0,0 @@-# 🚜 servant-serf--## Example--### Input:-```haskell-{-# OPTIONS_GHC -F -pgmF servant-serf-  -optF --package-name=servant-serf-example-  -optF --is-handler-module=Foo.Handler.*-  -optF --ghc-options=-freduction-depth=0-#-}--module Foo.Api where--import Foo.Handler.HelloWorld-import Foo.Handler.GoodbyeWorld-```--### Output:-```haskell-{-# OPTIONS_GHC -fno-warn-partial-type-signatures -freduction-depth=0 #-}-{-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE TypeOperators #-}-module Foo.Api (type Route, handler) where--import Servant ((:<|>)((:<|>)))-import qualified GHC.Stack as Stack-import qualified Servant--import qualified Foo.Handler.HelloWorld-import qualified Foo.Handler.GoodbyeWorld--type Route-  = Foo.Handler.HelloWorld.Route-  :<|> Foo.Handler.GoodbyeWorld.Route--handler :: Stack.HasCallStack => Servant.ServerT Route _-handler-  = Foo.Handler.HelloWorld.handler-  :<|> Foo.Handler.GoodbyeWorld.handler-```--### Module discovery:-When the preprocessor runs it looks at your package.yaml and the `is-handler-module` option-to determine which modules should be imported to the generated API module.-Because the ordering of the routes matters, you must explicitly import each route in the order-they will appear in the Route type. If you haven't yet imported a module which `servant-serf` has-disovered, you'll receive a helpful error message like the following:-```-/home/zach/Dev/servant-serf/servant-serf-example//tmp/ghc32747_0/ghc_1.hspp:9:11: error:-    • Missing handler imports. Consider adding the following imports to the file src/Foo/Api.hs-       or updating the is_handler_module regular expression in your .servant-serf.toml-      import Foo.Handler.GoodbyeWorld-```
− app/ApiModule.hs 
@@ -1,137 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}--module ApiModule where--import qualified Data.Attoparsec.Text as Atto-import qualified Data.Text as T-import Data.Text (Text)-import Data.Char (isSpace)-import Data.List (sort, (\\))-import Control.Applicative (some, Alternative(..))-import Control.Monad (void)--import Options (Config(..))--newtype Module = Module { getModuleName :: Text }--data ApiModule = ApiModule-  { moduleName :: Module-  , imports :: [Module]-  }--renderApiModule :: Config -> ApiModule -> Text-renderApiModule config ApiModule { moduleName, imports } =-  ( T.unlines-    $ "{-# OPTIONS_GHC -fno-warn-partial-type-signatures " <> ghcOptions config <> " #-}"-    : "{-# LANGUAGE PartialTypeSignatures #-}"-    : "{-# LANGUAGE ExplicitNamespaces #-}"-    : "{-# LANGUAGE TypeOperators #-}"-    : ""-    : "module " <> getModuleName moduleName <> " (type Route, handler) where"-    : ""-    : "import qualified GHC.Stack"-    : "import qualified Servant"-    : ""-    : fmap renderImport imports-  )-  <> "\n"-  <> renderApiType imports-  <> "\n\n"-  <> renderServerFunction imports-  where-    renderImport :: Module -> Text-    renderImport modu = "import qualified " <> getModuleName modu-    renderApiType :: [Module] -> Text-    renderApiType modules = "type Route\n  = "-      <> T.intercalate "\n  Servant.:<|> " (fmap (\modul -> getModuleName modul <> ".Route") modules)-    renderServerFunction :: [Module] -> Text-    renderServerFunction modules =-      "handler :: GHC.Stack.HasCallStack => Servant.ServerT Route _\n"-        <> "handler\n  = "-        <> handler-      where-        handler =-          T.intercalate "\n  Servant.:<|> " (fmap (\modul -> getModuleName modul <> ".handler") modules)---- | used to calculate the difference between discovered handler modules--- and imported modules at the call sight of @makeApi@ splice-difference :: Ord a => [a] -> [a] -> [a]-difference listA listB =-  let-    sortedA = sort listA-    sortedB = sort listB-  in sortedA \\ sortedB--decodeApiModule :: Text -> Either String ApiModule-decodeApiModule input = Atto.parseOnly parserApiModule input--parserApiModule :: Atto.Parser ApiModule-parserApiModule = ApiModule-  <$> parserModule-  <*> parserImports--skipBlockComment ::-  -- | Start of block comment-  Text ->-  -- | End of block comment-  Text ->-  Atto.Parser ()-skipBlockComment start end = p *> void (Atto.manyTill Atto.anyChar n)-  where-    p = Atto.string start-    n = Atto.string end--skipLineComment ::-  Text -> Atto.Parser ()-skipLineComment prefix =-  Atto.string prefix *> (Atto.skipWhile (/= '\n'))-{-# INLINEABLE skipLineComment #-}--comment :: Atto.Parser ()-comment =-      skipBlockComment "{-" "-}"-  <|> skipLineComment "--"--spaceConsumer :: Atto.Parser ()-spaceConsumer = Atto.skipMany singleSpaceConsumer-  where-  singleSpaceConsumer =-        (Atto.skipMany1 $ Atto.skip isSpace)-    <|> comment--parserModule :: Atto.Parser Module-parserModule = do-  spaceConsumer-  void $ Atto.string "module "-  moduleName <- Atto.takeWhile1 (not . isSpace)-  Atto.skipWhile (/= '\n')-  spaceConsumer-  pure $ Module moduleName--parserImports :: Atto.Parser [Module]-parserImports = some parserImport-  where-  parserImport = do-    void $ Atto.string "import "-    moduleName <- Atto.takeWhile1 (not . isSpace)-    spaceConsumer-    pure $ Module moduleName--failModule :: Text -> [Text] -> Text-failModule modName errMsgs =-  let typeErrors = fmap (\err -> "GHC.TypeLits.Text \"" <> err <> "\"") errMsgs-  in-    T.unlines-      [ "{-# LANGUAGE ExplicitNamespaces #-}"-      , "{-# LANGUAGE TypeOperators #-}"-      , "{-# LANGUAGE DataKinds #-}"-      , ""-      , "module " <> modName <> " where"-      , ""-      , "import qualified GHC.TypeLits"-      , ""-      , "handler :: GHC.TypeLits.TypeError (" <> T.intercalate " GHC.TypeLits.:$$: " typeErrors <> ")"-      , "handler = undefined"-      ]
− app/Main.hs 
@@ -1,99 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}--module Main where--import Control.Monad.Except-import Data.Text (Text)-import Options-import Regex-import ApiModule-import System.Environment (getArgs)-import System.Exit (exitFailure)-import System.IO (stderr)-import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Hpack.Config as Hpack--type Preprocessor = ExceptT PreprocessorException IO--data PreprocessorException-  = PackageYamlParseFailure Text-  | NoLibrary-  | EmptyHandlerModules [Text]-  | MissingImports [Text]--logErrLn :: MonadIO m => Text -> m ()-logErrLn text = liftIO $ T.hPutStrLn stderr text--main :: IO ()-main = do-  Options{..} <- execParser options-  (origInputFile : input : output : _) <- getArgs-  contents <- liftIO $ T.readFile input-  apiModule@ApiModule{..} <- case decodeApiModule contents of-    Right apiModule -> pure apiModule-    Left err -> do-      logErrLn $ "Parse error: " <> T.pack err-      exitFailure-  mException <- runExceptT $ mainPP apiModule config-  let-    outputModule = case mException of-      Left exception -> renderException origInputFile moduleName exception-      Right () -> renderApiModule config apiModule-  T.writeFile output outputModule--mainPP :: ApiModule -> Config -> Preprocessor ()-mainPP ApiModule{..} Config{..} = do-  -- parse package.yaml-  epackage <- liftIO $ Hpack.readPackageConfig $ Hpack.defaultDecodeOptions-    { Hpack.decodeOptionsProgramName = Hpack.ProgramName $ T.unpack packageName-    }-  package :: Hpack.Package <- fmap Hpack.decodeResultPackage $ case epackage of-    Left e -> throwError $ PackageYamlParseFailure $ T.pack e-    Right p -> pure p-  allModules :: [Text] <- case Hpack.packageLibrary package of-    Nothing -> throwError NoLibrary-    Just section ->-      let lib = Hpack.sectionData section-      in pure $ getAllModules lib-  let handlerModules = filterPattern isHandlerModule allModules-  case handlerModules of-    [] -> throwError $ EmptyHandlerModules allModules-    _ -> do-      let handlerImports = filterPattern isHandlerModule $ fmap getModuleName imports-      case difference handlerModules handlerImports of-        [] -> pure () -- all good, discovered modules are in scope-        xs -> throwError $ MissingImports xs--getAllModules :: Hpack.Library -> [Text]-getAllModules lib = T.pack . unModule <$> Hpack.libraryExposedModules lib <> Hpack.libraryOtherModules lib--#if MIN_VERSION_hpack(0, 34, 3)-unModule :: Hpack.Module -> String-unModule = Hpack.unModule-#else-unModule :: String -> String-unModule = id-#endif--renderException :: String -> Module -> PreprocessorException -> Text-renderException origInputFile (Module modName) exception = case exception of-  PackageYamlParseFailure errMsg ->-    failModule modName ["Failed to parse package.yaml. Error message: " <> errMsg]-  NoLibrary -> failModule modName ["No library exists in package.yaml"]-  EmptyHandlerModules allModules ->-    failModule modName ["empty handlerModules. allModules = " <> T.pack (show allModules)]-  MissingImports unimported -> do-    let-      makeImportStatement :: Text -> Text-      makeImportStatement x = "import " <> x-      importStatements = fmap makeImportStatement unimported-    failModule modName-      $ [ "Missing handler imports. Consider adding the following imports to the file "-          <> T.pack origInputFile-        , " or updating the is_handler_module regular expression in your .servant-serf.toml"-        ]-      <> importStatements
− app/Options.hs 
@@ -1,64 +0,0 @@-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Options-  ( Options(..)-  , options-  , Options.Applicative.execParser-  , Config(..)-  , Pattern'-  ) where--import Data.Bifunctor-import Data.Text (Text)-import Options.Applicative-import Regex--data Options = Options-  { originalInputFile :: FilePath-  , inputFile :: FilePath-  , outputFile :: FilePath-  , config :: Config-  }--options :: ParserInfo Options-options = info (options' <**> helper)-  (  fullDesc-  <> progDesc "Generates a servant API module"-  <> header "servant-serf"-  )--options' :: Parser Options-options' = Options-  <$> strArgument-    (   metavar "ORIGINAL_INPUT_FILEPATH"-    )-  <*> strArgument-    (   metavar "INPUT_FILEPATH"-    )-  <*> strArgument-    (   metavar "OUTPUT_FILEPATH"-    )-  <*> configParser--configParser :: Parser Config-configParser = Config-  <$> option str-    (  long "package-name"-    <> short 'p'-    )-  <*> option (eitherReader $ first show . parseRegex)-    (  long "is-handler-module"-    <> short 'm'-    )-  <*> option str-    (  long "ghc-options"-    <> value ""-    )--data Config = Config-  { packageName :: Text-  , isHandlerModule :: Pattern'-  , ghcOptions :: Text-  }
− app/Regex.hs 
@@ -1,22 +0,0 @@-module Regex-  ( Pattern'-  , filterPattern-  , parseRegex-  ) where--import Data.Text (Text)-import Text.Regex.TDFA (defaultExecOpt, defaultCompOpt, RegexLike(..))-import Text.Regex.TDFA.Pattern-import Text.Regex.TDFA.ReadRegex (parseRegex)-import Text.Regex.TDFA.TDFA ( patternToRegex )-import Text.Regex.TDFA.Text--type Pattern' = (Pattern, (GroupIndex, DoPa))--filterPattern :: Pattern' -> [Text] -> [Text]-filterPattern pattern strings = filter matchPattern strings-  where-  regex :: Regex-  regex = patternToRegex pattern defaultCompOpt defaultExecOpt-  matchPattern :: Text -> Bool-  matchPattern x = matchTest regex x
servant-serf.cabal view
@@ -1,54 +1,138 @@-cabal-version:      1.12-name:               servant-serf-version:            0.2.1-license:            MIT-license-file:       LICENSE-maintainer:         ACI Learning-homepage:           https://github.com/EdutainmentLIVE/servant-serf#readme-bug-reports:        https://github.com/EdutainmentLIVE/servant-serf/issues-synopsis:           Generates a servant API module+cabal-version: 2.0++name: servant-serf+version: 0.3.0.1+synopsis: Automatically generate Servant API modules. description:-    A preprocessor which will parse a psuedo-haskell module with imports and generate a module with exports a Route type and a handler function+  = servant-serf+  .+  servant-serf is a preprocessor for GHC that automatically generates Servant+  API modules. It is similar to the @hspec-discover@ package.+  .+  == Example input+  .+  > {-# OPTIONS_GHC -F -pgmF servant-serf #-}+  .+  == Example output+  .+  > {-# LINE 1 "Example.hs" #-}+  > {-# OPTIONS_GHC -w #-}+  >+  > module Example where+  >+  > import qualified Servant+  >+  > import qualified Example.One+  > import qualified Example.Two+  >+  > type API+  >   = Example.One.API+  >   Servant.:<|> Example.Two.API+  >+  > server+  >   = Example.One.server+  >   Servant.:<|> Example.Two.server+  .+  == Options+  .+  To pass options into servant-serf, use @-optF@. For example:+  .+  > {-# OPTIONS_GHC -F -pgmF servant-serf -optF --depth=shallow #-}+  .+  - @--module-name=STRING@: Sets the name to use for the generated module. By+  default this is determined from the source file path. For example @src/X.hs@+  would use the module name @X@.+  .+  - @--depth=deep|shallow@: Controls whether to search through only one+  dierctory (@shallow@) or recursively (@deep@). Defaults to @deep@.+  .+  - @--api-name=STRING@: Sets the name to use for the API type. Defaults to+  @API@. Note that the same name is used for both referenced API types and the+  generated API type.+  .+  - @server-name=STRING@: Sets the name to use for the server value. Defaults+  to @server@. Note that the same name is used for both referenced server+  values and the generated server value.+  .+  == Notes+  .+  - The input module is completely ignored.+  .+  - Modules are sorted by name. There is no way to customize how they are+  sorted.+  .+  - All modules below the current module are included. There is no way to+  customize which modules are included or excluded.+  .+  - The generated server value does not have a type signature. It should have+  type @Servant.ServerT API m@ for some @m@, but that @m@ can change and is+  easily inferred by GHC. -category:           Code Generation-build-type:         Simple-extra-source-files: README.md+build-type: Simple+category: Web+extra-source-files: CHANGELOG.markdown README.markdown+license-file: LICENSE.markdown+license: MIT+maintainer: ACI Learning  source-repository head-    type:     git-    location: https://github.com/EdutainmentLIVE/servant-serf+  location: https://github.com/EdutainmentLIVE/servant-serf+  type: git +flag pedantic+  default: False+  description: Enables @-Werror@, which turns warnings into errors.+  manual: True+ library-    default-language: Haskell2010-    ghc-options:-        -Weverything -Wno-all-missed-specializations -Wno-implicit-prelude-        -Wno-missed-specialisations -Wno-missing-deriving-strategies-        -Wno-missing-export-lists -Wno-missing-exported-signatures-        -Wno-missing-import-lists -Wno-redundant-constraints -Wno-safe-        -Wno-unsafe+  autogen-modules: Paths_servant_serf+  build-depends:+    base >= 4.14.0 && < 4.17+    , Cabal >= 3.2.0 && < 3.7+    , directory >= 1.3.6 && < 1.4+    , exceptions >= 0.10.4 && < 0.11+    , filepath >= 1.4.2 && < 1.5+  default-language: Haskell2010+  ghc-options:+    -Weverything+    -Wno-all-missed-specialisations+    -Wno-implicit-prelude+    -Wno-missing-deriving-strategies+    -Wno-missing-export-lists+    -Wno-missing-exported-signatures+    -Wno-missing-safe-haskell-mode+    -Wno-prepositive-qualified-module+    -Wno-safe+    -Wno-unsafe+  exposed-modules:+    ServantSerf+    ServantSerf.Directory+    ServantSerf.Exception.ExtraArgument+    ServantSerf.Exception.InvalidDepth+    ServantSerf.Exception.InvalidModuleName+    ServantSerf.Exception.InvalidOption+    ServantSerf.Exception.MissingArgument+    ServantSerf.Exception.UnknownOption+    ServantSerf.Main+    ServantSerf.Module+    ServantSerf.Type.Config+    ServantSerf.Type.Context+    ServantSerf.Type.Depth+    ServantSerf.Type.Flag+    ServantSerf.Type.ModuleName+    ServantSerf.Version+  hs-source-dirs: source/library+  other-modules: Paths_servant_serf -executable servant-serf-    main-is:          Main.hs-    hs-source-dirs:   app-    other-modules:-        ApiModule-        Options-        Regex+  if impl(ghc >= 9.2)+    ghc-options: -Wno-missing-kind-signatures -    default-language: Haskell2010-    ghc-options:-        -Weverything -Wno-all-missed-specializations -Wno-implicit-prelude-        -Wno-missed-specialisations -Wno-missing-deriving-strategies-        -Wno-missing-export-lists -Wno-missing-exported-signatures-        -Wno-missing-import-lists -Wno-redundant-constraints -Wno-safe-        -Wno-unsafe+  if flag(pedantic)+    ghc-options: -Werror -    build-depends:-        attoparsec >=0.13.2.5,-        base >=4.14.1.0 && <=5.2.0.0,-        hpack >=0.34.4,-        mtl >=2.2.2,-        optparse-applicative >=0.15.1.0,-        regex-base >=0.94.0.0,-        regex-tdfa >=1.3.1.0,-        text >=1.2.4.1+executable servant-serf+  build-depends: base, servant-serf+  default-language: Haskell2010+  ghc-options: -rtsopts -threaded+  hs-source-dirs: source/executable+  main-is: Main.hs
+ source/executable/Main.hs view
@@ -0,0 +1,4 @@+import qualified ServantSerf++main :: IO ()+main = ServantSerf.defaultMain
+ source/library/ServantSerf.hs view
@@ -0,0 +1,6 @@+module ServantSerf+  ( ServantSerf.Main.defaultMain+  , ServantSerf.Main.mainWith+  ) where++import qualified ServantSerf.Main
+ source/library/ServantSerf/Directory.hs view
@@ -0,0 +1,25 @@+module ServantSerf.Directory where++import qualified ServantSerf.Type.Depth as Depth+import qualified System.Directory as Directory+import qualified System.FilePath as FilePath++list :: Depth.Depth -> FilePath -> IO [FilePath]+list depth = case depth of+  Depth.Deep -> listDeep+  Depth.Shallow -> listShallow++listDeep :: FilePath -> IO [FilePath]+listDeep directory = do+  entries <- listShallow directory+  concat <$> mapM listDeepHelper entries++listDeepHelper :: FilePath -> IO [FilePath]+listDeepHelper entry = do+  isDirectory <- Directory.doesDirectoryExist entry+  if isDirectory then listDeep entry else pure [entry]++listShallow :: FilePath -> IO [FilePath]+listShallow directory = do+  entries <- Directory.listDirectory directory+  pure $ fmap (FilePath.combine directory) entries
+ source/library/ServantSerf/Exception/ExtraArgument.hs view
@@ -0,0 +1,9 @@+module ServantSerf.Exception.ExtraArgument where++import qualified Control.Monad.Catch as Exception++newtype ExtraArgument+    = ExtraArgument String+    deriving (Eq, Show)++instance Exception.Exception ExtraArgument
+ source/library/ServantSerf/Exception/InvalidDepth.hs view
@@ -0,0 +1,9 @@+module ServantSerf.Exception.InvalidDepth where++import qualified Control.Monad.Catch as Exception++newtype InvalidDepth+    = InvalidDepth String+    deriving (Eq, Show)++instance Exception.Exception InvalidDepth
+ source/library/ServantSerf/Exception/InvalidModuleName.hs view
@@ -0,0 +1,9 @@+module ServantSerf.Exception.InvalidModuleName where++import qualified Control.Monad.Catch as Exception++newtype InvalidModuleName+    = InvalidModuleName String+    deriving (Eq, Show)++instance Exception.Exception InvalidModuleName
+ source/library/ServantSerf/Exception/InvalidOption.hs view
@@ -0,0 +1,9 @@+module ServantSerf.Exception.InvalidOption where++import qualified Control.Monad.Catch as Exception++newtype InvalidOption+    = InvalidOption String+    deriving (Eq, Show)++instance Exception.Exception InvalidOption
+ source/library/ServantSerf/Exception/MissingArgument.hs view
@@ -0,0 +1,9 @@+module ServantSerf.Exception.MissingArgument where++import qualified Control.Monad.Catch as Exception++newtype MissingArgument+    = MissingArgument String+    deriving (Eq, Show)++instance Exception.Exception MissingArgument
+ source/library/ServantSerf/Exception/UnknownOption.hs view
@@ -0,0 +1,9 @@+module ServantSerf.Exception.UnknownOption where++import qualified Control.Monad.Catch as Exception++newtype UnknownOption+    = UnknownOption String+    deriving (Eq, Show)++instance Exception.Exception UnknownOption
+ source/library/ServantSerf/Main.hs view
@@ -0,0 +1,37 @@+module ServantSerf.Main where++import qualified Control.Monad as Monad+import qualified ServantSerf.Directory as Directory+import qualified ServantSerf.Module as Module+import qualified ServantSerf.Type.Config as Config+import qualified ServantSerf.Type.Context as Context+import qualified ServantSerf.Type.Flag as Flag+import qualified ServantSerf.Version as Version+import qualified System.Console.GetOpt as Console+import qualified System.Environment as Environment+import qualified System.Exit as Exit+import qualified System.FilePath as FilePath++defaultMain :: IO ()+defaultMain = do+  name <- Environment.getProgName+  arguments <- Environment.getArgs+  mainWith name arguments++mainWith :: String -> [String] -> IO ()+mainWith name arguments = do+  context <- Context.fromArguments arguments+  Monad.when (Config.help $ Context.config context) $ do+    putStr $ Console.usageInfo (header name) Flag.options+    Exit.exitSuccess+  Monad.when (Config.version $ Context.config context) $ do+    putStrLn Version.string+    Exit.exitSuccess+  files <-+    Directory.list (Config.depth $ Context.config context)+    . FilePath.dropExtension+    $ Context.source context+  writeFile (Context.output context) $ Module.generate context files++header :: String -> String+header name = name <> " SOURCE INPUT OUTPUT"
+ source/library/ServantSerf/Module.hs view
@@ -0,0 +1,49 @@+module ServantSerf.Module where++import qualified Data.List as List+import qualified Data.Maybe as Maybe+import qualified ServantSerf.Type.Config as Config+import qualified ServantSerf.Type.Context as Context+import qualified ServantSerf.Type.ModuleName as ModuleName+import qualified System.FilePath as FilePath++generate :: Context.Context -> [FilePath] -> String+generate context files =+  let+    source = Context.source context+    config = Context.config context+    apiName = Config.apiName config+    serverName = Config.serverName config+    moduleName = case Config.moduleName config of+      Nothing ->+        maybe "Main" ModuleName.toString+          . ModuleName.fromFilePath+          $ Context.source context+      Just x -> ModuleName.toString x+    moduleNames =+      fmap ModuleName.toString+        . List.sort+        . Maybe.mapMaybe ModuleName.fromFilePath+        $ filter (FilePath.isExtensionOf "hs") files+  in unlines+    [ "{-# LINE 1 " <> show source <> " #-}"+    , "{-# OPTIONS_GHC -w #-}"+    , ""+    , "module " <> moduleName <> " where"+    , ""+    , "import qualified Servant"+    , ""+    , List.intercalate "\n" $ fmap ("import qualified " <>) moduleNames+    , ""+    , "type " <> apiName+    , "\t= " <> if null moduleNames+      then "Servant.EmptyAPI"+      else List.intercalate "\n\tServant.:<|> "+        $ fmap (<> "." <> apiName) moduleNames+    , ""+    , serverName+    , "\t= " <> if null moduleNames+      then "Servant.emptyServer"+      else List.intercalate "\n\tServant.:<|> "+        $ fmap (<> "." <> serverName) moduleNames+    ]
+ source/library/ServantSerf/Type/Config.hs view
@@ -0,0 +1,45 @@+module ServantSerf.Type.Config where++import qualified Control.Monad as Monad+import qualified Control.Monad.Catch as Exception+import qualified ServantSerf.Exception.InvalidDepth as InvalidDepth+import qualified ServantSerf.Exception.InvalidModuleName as InvalidModuleName+import qualified ServantSerf.Type.Depth as Depth+import qualified ServantSerf.Type.Flag as Flag+import qualified ServantSerf.Type.ModuleName as ModuleName++data Config = Config+  { apiName :: String+  , depth :: Depth.Depth+  , help :: Bool+  , moduleName :: Maybe ModuleName.ModuleName+  , serverName :: String+  , version :: Bool+  }+  deriving (Eq, Show)++fromFlags :: (Foldable t, Exception.MonadThrow m) => t Flag.Flag -> m Config+fromFlags = Monad.foldM applyFlag initial++applyFlag :: Exception.MonadThrow m => Config -> Flag.Flag -> m Config+applyFlag config flag = case flag of+  Flag.ApiName x -> pure config { apiName = x }+  Flag.Depth x -> case Depth.fromString x of+    Nothing -> Exception.throwM $ InvalidDepth.InvalidDepth x+    Just y -> pure config { depth = y }+  Flag.Help -> pure config { help = True }+  Flag.ModuleName x -> case ModuleName.fromString x of+    Nothing -> Exception.throwM $ InvalidModuleName.InvalidModuleName x+    Just y -> pure config { moduleName = Just y }+  Flag.ServerName x -> pure config { serverName = x }+  Flag.Version -> pure config { version = True }++initial :: Config+initial = Config+  { apiName = "API"+  , depth = Depth.Deep+  , help = False+  , moduleName = Nothing+  , serverName = "server"+  , version = False+  }
+ source/library/ServantSerf/Type/Context.hs view
@@ -0,0 +1,33 @@+module ServantSerf.Type.Context where++import qualified Control.Monad.Catch as Exception+import qualified ServantSerf.Exception.ExtraArgument as ExtraArgument+import qualified ServantSerf.Exception.InvalidOption as InvalidOption+import qualified ServantSerf.Exception.MissingArgument as MissingArgument+import qualified ServantSerf.Exception.UnknownOption as UnknownOption+import qualified ServantSerf.Type.Config as Config+import qualified ServantSerf.Type.Flag as Flag+import qualified System.Console.GetOpt as Console++data Context = Context+  { config :: Config.Config+  , input :: FilePath+  , output :: FilePath+  , source :: FilePath+  }+  deriving (Eq, Show)++fromArguments :: Exception.MonadThrow m => [String] -> m Context+fromArguments arguments = do+  let+    (fs, as, us, is) = Console.getOpt' Console.Permute Flag.options arguments+  mapM_ (Exception.throwM . UnknownOption.UnknownOption) us+  mapM_ (Exception.throwM . InvalidOption.InvalidOption) is+  c <- Config.fromFlags fs+  case as of+    [] -> Exception.throwM $ MissingArgument.MissingArgument "SOURCE"+    [_] -> Exception.throwM $ MissingArgument.MissingArgument "INPUT"+    [_, _] -> Exception.throwM $ MissingArgument.MissingArgument "OUTPUT"+    s : i : o : xs -> do+      mapM_ (Exception.throwM . ExtraArgument.ExtraArgument) xs+      pure Context { config = c, input = i, output = o, source = s }
+ source/library/ServantSerf/Type/Depth.hs view
@@ -0,0 +1,12 @@+module ServantSerf.Type.Depth where++data Depth+    = Deep+    | Shallow+    deriving (Eq, Show)++fromString :: String -> Maybe Depth+fromString x = case x of+  "deep" -> Just Deep+  "shallow" -> Just Shallow+  _ -> Nothing
+ source/library/ServantSerf/Type/Flag.hs view
@@ -0,0 +1,46 @@+module ServantSerf.Type.Flag where++import qualified System.Console.GetOpt as Console++data Flag+    = ApiName String+    | Depth String+    | Help+    | ModuleName String+    | ServerName String+    | Version+    deriving (Eq, Show)++options :: [Console.OptDescr Flag]+options =+  [ Console.Option+    ['h', '?']+    ["help"]+    (Console.NoArg Help)+    "Shows this help message, then exits."+  , Console.Option+    []+    ["version"]+    (Console.NoArg Version)+    "Shows the version number, then exits."+  , Console.Option+    []+    ["api-name"]+    (Console.ReqArg ApiName "API_NAME")+    "Sets the name to use for the API type. Defaults to `API`."+  , Console.Option+    []+    ["depth"]+    (Console.ReqArg Depth "DEPTH")+    "Controls whether to search through only one directory (`shallow`) or recursively (`deep`). Defaults to `deep`."+  , Console.Option+    []+    ["module-name"]+    (Console.ReqArg ModuleName "MODULE_NAME")+    "Sets the name of the generated module. By default this is generated from the source file name."+  , Console.Option+    []+    ["server-name"]+    (Console.ReqArg ServerName "SERVER_NAME")+    "Sets the name to use for the server value. Defaults to `server`."+  ]
+ source/library/ServantSerf/Type/ModuleName.hs view
@@ -0,0 +1,25 @@+module ServantSerf.Type.ModuleName where++import qualified Data.List as List+import qualified Data.Maybe as Maybe+import qualified Distribution.ModuleName as Cabal+import qualified Distribution.Text as Cabal+import qualified System.FilePath as FilePath++newtype ModuleName+    = ModuleName Cabal.ModuleName+    deriving (Eq, Ord, Show)++toString :: ModuleName -> String+toString (ModuleName x) = Cabal.display x++fromString :: String -> Maybe ModuleName+fromString = fmap ModuleName . Cabal.simpleParse++fromFilePath :: FilePath -> Maybe ModuleName+fromFilePath =+  Maybe.listToMaybe+    . Maybe.mapMaybe (fromString . List.intercalate ".")+    . List.tails+    . FilePath.splitDirectories+    . FilePath.dropExtensions
+ source/library/ServantSerf/Version.hs view
@@ -0,0 +1,7 @@+module ServantSerf.Version where++import qualified Data.Version as Version+import qualified Paths_servant_serf as Package++string :: String+string = Version.showVersion Package.version