servant-serf (empty) → 0.0.1
raw patch · 6 files changed
+395/−0 lines, 6 filesdep +attoparsecdep +basedep +hpack
Dependencies added: attoparsec, base, hpack, mtl, optparse-applicative, parser-combinators, regex-base, regex-tdfa, text, tomland
Files
- LICENSE +7/−0
- app/ApiModule.hs +135/−0
- app/Main.hs +96/−0
- app/Options.hs +66/−0
- app/Regex.hs +36/−0
- servant-serf.cabal +55/−0
+ LICENSE view
@@ -0,0 +1,7 @@+Copyright © 2020 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.
+ app/ApiModule.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# 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)++newtype Module = Module { getModuleName :: Text }++data ApiModule = ApiModule+ { moduleName :: Module+ , imports :: [Module]+ }++renderApiModule :: ApiModule -> Text+renderApiModule ApiModule { moduleName, imports } =+ (T.unlines+ $ "{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}"+ : "{-# LANGUAGE PartialTypeSignatures #-}"+ : "{-# LANGUAGE ExplicitNamespaces #-}"+ : "{-# LANGUAGE TypeOperators #-}"+ : ""+ : "module " <> getModuleName moduleName <> " (type Api, server) where"+ : ""+ : "import Servant ((:<|>)((:<|>)))"+ : "import qualified GHC.Stack as 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 Api\n = "+ <> T.intercalate "\n :<|> " (fmap (\modul -> getModuleName modul <> ".Route") modules)+ renderServerFunction :: [Module] -> Text+ renderServerFunction modules =+ "server :: Stack.HasCallStack => Servant.ServerT Api _\n"+ <> "server\n = "+ <> server+ where+ server =+ T.intercalate "\n :<|> " (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.skipSpace+ *> Atto.skipMany comment + *> Atto.skipSpace++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 -> "TypeLits.Text \"" <> err <> "\"") errMsgs+ in+ T.unlines+ [ "{-# LANGUAGE ExplicitNamespaces #-}"+ , "{-# LANGUAGE TypeOperators #-}"+ , "{-# LANGUAGE DataKinds #-}"+ , ""+ , "module " <> modName <> " where"+ , ""+ , "import qualified GHC.TypeLits as TypeLits"+ , ""+ , "server :: TypeLits.TypeError (" <> T.intercalate " TypeLits.:$$: " typeErrors <> ")"+ , "server = undefined"+ ]
+ app/Main.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++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+import qualified Toml++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+ configTomlRes <- Toml.decodeFileEither configCodec ".servant-serf.toml"+ config <- case configTomlRes of+ Left errs -> do + logErrLn $ Toml.prettyTomlDecodeErrors errs+ exitFailure+ Right config -> pure config+ [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 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 $ T.pack <$> Hpack.libraryExposedModules lib <> Hpack.libraryOtherModules 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++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 view
@@ -0,0 +1,66 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Options + ( Options(..)+ , options+ , Options.Applicative.execParser+ , Config(..)+ , defaultConfig+ , configCodec+ , Pattern'+ ) where++import Data.Text (Text)+import GHC.Generics (Generic(..))+import Options.Applicative+import Regex+import Toml ((.=))+import qualified Data.Text as T+import qualified Toml++data Options = Options+ { originalInputFile :: FilePath+ , inputFile :: FilePath+ , outputFile :: FilePath+ }++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"+ )++data Config = Config+ { packageName :: Text+ , isHandlerModule :: Pattern'+ } deriving (Generic)++configCodec :: Toml.TomlCodec Config+configCodec = Config+ <$> Toml.text "package_name" .= packageName+ <*> patternCodec "is_handler_module" .= isHandlerModule++defaultConfig :: Config+defaultConfig = Config+ { packageName = "example"+ , isHandlerModule = either (error . T.unpack) id $ parseRegex' ".*Handler.*"+ }
+ app/Regex.hs view
@@ -0,0 +1,36 @@+module Regex + ( Pattern'+ , patternCodec+ , 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+import qualified Data.Text as T+import qualified Toml++type Pattern' = (Pattern, (GroupIndex, DoPa))++parseRegex' :: Text -> Either Text Pattern'+parseRegex' inp = case parseRegex (T.unpack inp) of+ Left e -> Left $ T.pack $ show e+ Right pattern -> Right pattern++_Pattern :: Toml.TomlBiMap Pattern' Toml.AnyValue+_Pattern = Toml._TextBy (T.pack . showPattern . fst) parseRegex'++patternCodec :: Toml.Key -> Toml.TomlCodec Pattern'+patternCodec key = Toml.match _Pattern key++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
@@ -0,0 +1,55 @@+cabal-version: 1.12+name: servant-serf+version: 0.0.1+license: MIT+license-file: LICENSE+maintainer: Zachary Churchill <zachary@itpro.tv>+synopsis: Generates a servant API module+description:+ A preprocessor which will parse a psuedo-haskell module with imports and generate a module with exports an Api type and a server function++category: Code Generation+build-type: Simple++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++ if False+ other-modules: Paths_servant_serf++executable servant-serf+ main-is: Main.hs+ hs-source-dirs: app+ other-modules:+ ApiModule+ Options+ Regex++ 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++ build-depends:+ attoparsec >=0.13.2.4,+ base >=4.13.0.0 && <=5.2.0.0,+ hpack >=0.34.2,+ mtl >=2.2.2,+ optparse-applicative >=0.15.1.0,+ parser-combinators >=1.2.1,+ regex-base >=0.94.0.0,+ regex-tdfa >=1.3.1.0,+ text >=1.2.4.0,+ tomland >=1.3.1.0++ if False+ other-modules: Paths_servant_serf