Generator Improvements (#92)

* Add --skipDuplicates CLI flag and handler * Add prefixMap option for specifying external import roots
2024-09-17 10:27:08 +03:00 · 2019-12-11 13:41:24 +00:00 · 2019-12-11 13:41:24 +00:00 · 337a81fa8b
commit 337a81fa8b
parent bbfec3d854
9 changed files with 166 additions and 59 deletions
--- a/dhall-kubernetes-generator/dhall-kubernetes-generator.cabal
+++ b/dhall-kubernetes-generator/dhall-kubernetes-generator.cabal
@ -20,14 +20,18 @@ executable dhall-kubernetes-generator
  default-extensions: DeriveDataTypeable DeriveGeneric DerivingStrategies DuplicateRecordFields GeneralizedNewtypeDeriving LambdaCase RecordWildCards ScopedTypeVariables OverloadedStrings FlexibleInstances ConstraintKinds ApplicativeDo TupleSections
  ghc-options: -Wall
  build-depends:
-    base          >= 4.8.2.0   && < 5    ,
-    aeson         >= 1.0.0.0   && < 1.5  ,
-    containers    >= 0.5.0.0   && < 0.7  ,
-    dhall         >= 1.22.0    && < 1.28 ,
-    prettyprinter >= 1.2.0.1   && < 1.3  ,
-    text          >= 0.11.1.0  && < 1.3  ,
-    turtle        >= 1.5.0     && < 1.6  ,
-    vector        >= 0.11.0.0  && < 0.13
+    base                 >= 4.8.2.0   && < 5    ,
+    aeson                >= 1.0.0.0   && < 1.5  ,
+    containers           >= 0.5.0.0   && < 0.7  ,
+    dhall                >= 1.22.0    && < 1.28 ,
+    megaparsec           >= 7.0       && < 7.1  ,
+    optparse-applicative >= 0.14.3.0  && < 0.15 ,
+    parser-combinators   >= 1.0.3     && < 1.1  ,
+    prettyprinter        >= 1.2.0.1   && < 1.3  ,
+    sort                 >= 1.0       && < 1.1  ,
+    text                 >= 0.11.1.0  && < 1.3  ,
+    turtle               >= 1.5.0     && < 1.6  ,
+    vector               >= 0.11.0.0  && < 0.13
  default-language: Haskell2010

 source-repository head
--- a/dhall-kubernetes-generator/src/Dhall/Kubernetes/Convert.hs
+++ b/dhall-kubernetes-generator/src/Dhall/Kubernetes/Convert.hs
@ -8,12 +8,13 @@ module Dhall.Kubernetes.Convert
 import qualified Data.List              as List
 import qualified Data.Map.Strict        as Data.Map
 import qualified Data.Set               as Set
+import qualified Data.Sort              as Sort
 import qualified Data.Text              as Text
 import qualified Dhall.Core             as Dhall
 import qualified Dhall.Map

 import           Data.Bifunctor         (first, second)
-import           Data.Maybe             (fromMaybe)
+import           Data.Maybe             (fromMaybe, mapMaybe)
 import           Data.Set               (Set)
 import           Data.Text              (Text)

@ -63,14 +64,19 @@ pathFromRef (Ref r) = (Text.split (== '/') r) List.!! 2

 -- | Build an import from path components (note: they need to be in reverse order)
 --   and a filename
-mkImport :: [Text] -> Text -> Dhall.Import
-mkImport components file = Dhall.Import{..}
+mkImport :: Data.Map.Map Prefix Dhall.Import -> [Text] -> Text -> Dhall.Import
+mkImport prefixMap components file =
+  case Data.Map.toList filteredPrefixMap of
+    []    -> localImport
+    xs    -> (snd . head $ Sort.sortOn (Text.length . fst) xs) <> localImport
  where
+    localImport = Dhall.Import{..}
    importMode = Dhall.Code
    importHashed = Dhall.ImportHashed{..}
    hash = Nothing
    importType = Dhall.Local Dhall.Here Dhall.File{..}
    directory = Dhall.Directory{..}
+    filteredPrefixMap = Data.Map.filterWithKey (\k _ -> Text.isPrefixOf k file) prefixMap

 -- | Get the namespaced object name if the Import points to it
 namespacedObjectFromImport :: Dhall.Import -> Maybe Text
@ -91,8 +97,8 @@ toTextLit str = Dhall.TextLit (Dhall.Chunks [] str)
 --   Note: we cannot do 1-to-1 conversion and we need the whole Map because
 --   many types reference other types so we need to access them to decide things
 --   like "should this key be optional"
-toTypes :: Data.Map.Map ModelName Definition -> Data.Map.Map ModelName Expr
-toTypes definitions = memo
+toTypes :: Data.Map.Map Prefix Dhall.Import -> Data.Map.Map ModelName Definition -> Data.Map.Map ModelName Expr
+toTypes prefixMap definitions = memo
  where
    memo = Data.Map.mapWithKey (\k -> convertToType (Just k)) definitions

@ -139,7 +145,7 @@ toTypes definitions = memo
    convertToType :: Maybe ModelName -> Definition -> Expr
    convertToType maybeModelName Definition{..} = case (ref, typ, properties) of
      -- If we point to a ref we just reference it via Import
-      (Just r, _, _) -> Dhall.Embed $ mkImport [] $ (pathFromRef r <> ".dhall")
+      (Just r, _, _) -> Dhall.Embed $ mkImport prefixMap [] (pathFromRef r <> ".dhall")
      -- Otherwise - if we have 'properties' - it's an object
      (_, _, Just props) ->
        let (required', optional')
@ -169,12 +175,13 @@ toTypes definitions = memo

 -- | Convert a Dhall Type to its default value
 toDefault
-  :: Data.Map.Map ModelName Definition -- ^ All the Swagger definitions
+  :: Data.Map.Map Prefix Dhall.Import  -- ^ Mapping of prefixes to import roots
+  -> Data.Map.Map ModelName Definition -- ^ All the Swagger definitions
  -> Data.Map.Map ModelName Expr       -- ^ All the Dhall types generated from them
  -> ModelName                         -- ^ The name of the object we're converting
  -> Expr                              -- ^ The Dhall type of the object
  -> Maybe Expr
-toDefault definitions types modelName = go
+toDefault prefixMap definitions types modelName = go
  where
    go = \case
      -- If we have an import, we also import in the default
@ -228,29 +235,31 @@ toDefault definitions types modelName = go
    --   but if we want to refer them from the defaults we need to adjust the path
    adjustImport :: Expr -> Expr
    adjustImport (Dhall.Embed imp) | Just file <- namespacedObjectFromImport imp
-      = Dhall.Embed $ mkImport ["types", ".."] (file <> ".dhall")
+      = Dhall.Embed $ mkImport prefixMap ["types", ".."] (file <> ".dhall")
    adjustImport other = other


 -- | Get a Dhall.Map filled with imports, for creating giant Records or Unions of types or defaults
 getImportsMap
-  :: [ModelName]             -- ^ A list of all the object names
-  -> Text                    -- ^ The folder we should get imports from
-  -> [ModelName]             -- ^ List of the object names we want to include in the Map
+  :: Data.Map.Map Prefix Dhall.Import -- ^ Mapping of prefixes to import roots
+  -> DuplicateHandler                 -- ^ Duplicate name handler
+  -> [ModelName]                      -- ^ A list of all the object names
+  -> Text                             -- ^ The folder we should get imports from
+  -> [ModelName]                      -- ^ List of the object names we want to include in the Map
  -> Dhall.Map.Map Text Expr
-getImportsMap objectNames folder toInclude
+getImportsMap prefixMap duplicateNameHandler objectNames folder toInclude
  = Dhall.Map.fromList
  $ Data.Map.elems
  -- This intersection is here to "pick" common elements between "all the objects"
  -- and "objects we want to include", already associating keys to their import
  $ Data.Map.intersectionWithKey
-      (\(ModelName name) key _ -> (key, Dhall.Embed $ mkImport [folder] (name <> ".dhall")))
+      (\(ModelName name) key _ -> (key, Dhall.Embed $ mkImport prefixMap [folder] (name <> ".dhall")))
      namespacedToSimple
      (Data.Map.fromList $ fmap (,()) toInclude)
  where
    -- | A map from namespaced names to simple ones (i.e. without the namespace)
    namespacedToSimple
-      = Data.Map.fromList $ fmap selectObject $ Data.Map.toList $ groupByObjectName objectNames
+      = Data.Map.fromList $ mapMaybe selectObject $ Data.Map.toList $ groupByObjectName objectNames

    -- | Given a list of fully namespaced bjects, it will group them by the
    --   object name
@ -267,8 +276,8 @@ getImportsMap objectNames folder toInclude
    --   (because different API versions, and objects move around packages but k8s
    --   cannot break compatibility so we have all of them), so we have to select one
    --   (and we error out if it's not so after the filtering)
-    selectObject :: (Text, [ModelName]) -> (ModelName, Text)
-    selectObject (kind, namespacedNames) = (namespaced, kind)
+    selectObject :: (Text, [ModelName]) -> Maybe (ModelName, Text)
+    selectObject (kind, namespacedNames) = fmap (,kind) namespaced
      where
        filterFn modelName@(ModelName name) = not $ or
          -- The reason why we filter these two prefixes is that they are "internal"
@ -281,5 +290,5 @@ getImportsMap objectNames folder toInclude
          ]

        namespaced = case filter filterFn namespacedNames of
-          [name] -> name
-          wrong  -> error $ "Got more than one key for "++ show kind ++"! See:\n" <> show wrong
+          [name] -> Just name
+          names  -> duplicateNameHandler (kind, names)
--- a/dhall-kubernetes-generator/src/Dhall/Kubernetes/Types.hs
+++ b/dhall-kubernetes-generator/src/Dhall/Kubernetes/Types.hs
@ -17,6 +17,9 @@ import           GHC.Generics              (Generic)

 type Expr = Dhall.Expr Dhall.Src Dhall.Import

+type DuplicateHandler = (Text, [ModelName]) -> Maybe ModelName
+
+type Prefix = Text

 {-| Type for the Swagger specification.

--- a/dhall-kubernetes-generator/src/Main.hs
+++ b/dhall-kubernetes-generator/src/Main.hs
@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE RecordWildCards #-}

 module Main (main) where

@ -13,15 +14,27 @@ import qualified Dhall.Util
 import qualified Turtle

 import           Data.Aeson                            (decodeFileStrict)
+import           Data.Bifunctor                        (bimap)
 import           Data.Foldable                         (for_)
-import           Data.Text                             (Text)
-import           System.Environment                    (getArgs)
+import           Data.Text                             (Text, pack)
+import qualified Options.Applicative
+import           Control.Applicative.Combinators       (sepBy1, option)
+import           Text.Megaparsec                       (some, parse, (<|>), errorBundlePretty)
+import           Text.Megaparsec.Char                  (char, alphaNumChar)

 import qualified Dhall.Kubernetes.Convert              as Convert
 import           Dhall.Kubernetes.Data                 (patchCyclicImports)
+import qualified Dhall.Parser
 import           Dhall.Kubernetes.Types


+-- | Top-level program options
+data Options = Options
+    { skipDuplicates :: Bool
+    , prefixMap :: Data.Map.Map Prefix Dhall.Import
+    , filename :: String
+    }
+
 -- | Write and format a Dhall expression to a file
 writeDhall :: Turtle.FilePath -> Expr -> IO ()
 writeDhall path expr = do
@ -51,21 +64,70 @@ echo = Turtle.printf (Turtle.s Turtle.% "\n")
 echoStr :: Turtle.MonadIO m => String -> m ()
 echoStr = echo . Text.pack

+errorOnDuplicateHandler :: DuplicateHandler
+errorOnDuplicateHandler (kind, names) = error $ "Got more than one key for "++ show kind ++"! See:\n" <> show names
+
+skipDuplicatesHandler :: DuplicateHandler
+skipDuplicatesHandler = const Nothing
+
+parseImport :: String -> Expr -> Dhall.Parser.Parser Dhall.Import
+parseImport _ (Dhall.Note _ (Dhall.Embed l)) = pure l
+parseImport prefix e = fail $ "Expected a Dhall import for " <> prefix <> " not:\n" <> show e
+
+parsePrefixMap :: Options.Applicative.ReadM (Data.Map.Map Prefix Dhall.Import)
+parsePrefixMap =
+  Options.Applicative.eitherReader $ \s ->
+    bimap errorBundlePretty Data.Map.fromList $ result (pack s)
+  where
+    parser = do
+      prefix <- some (alphaNumChar <|> char '.')
+      char '='
+      e <- Dhall.Parser.expr
+      imp <- parseImport prefix e
+      return (pack prefix, imp)
+    result = parse (Dhall.Parser.unParser parser `sepBy1` char ',') "MAPPING"
+
+parseOptions :: Options.Applicative.Parser Options
+parseOptions = Options <$> parseSkip <*> parsePrefixMap' <*> fileArg
+  where
+    parseSkip =
+      Options.Applicative.switch
+        (  Options.Applicative.long "skipDuplicates"
+        <> Options.Applicative.help "Skip types with the same name when aggregating types"
+        )
+    parsePrefixMap' =
+      option Data.Map.empty $ Options.Applicative.option parsePrefixMap
+        (  Options.Applicative.long "prefixMap"
+        <> Options.Applicative.help "Specify prefix mappings as 'prefix1=importBase1,prefix2=importBase2,...'"
+        <> Options.Applicative.metavar "MAPPING"
+        )
+    fileArg = Options.Applicative.strArgument
+            (  Options.Applicative.help "The swagger file to read"
+            <> Options.Applicative.metavar "FILE"
+            )
+
+-- | `ParserInfo` for the `Options` type
+parserInfoOptions :: Options.Applicative.ParserInfo Options
+parserInfoOptions =
+    Options.Applicative.info
+        (Options.Applicative.helper <*> parseOptions)
+        (   Options.Applicative.progDesc "Swagger to Dhall generator"
+        <>  Options.Applicative.fullDesc
+        )

 main :: IO ()
 main = do
+  Options{..} <- Options.Applicative.execParser parserInfoOptions
+  let duplicateHandler = if skipDuplicates then skipDuplicatesHandler else errorOnDuplicateHandler
  -- Get the Swagger spec
-  args <- getArgs
-  Swagger{..} <- case args of
-    [file] -> do
-      swaggerFile <- decodeFileStrict file
-      case swaggerFile of
-        Nothing -> error "Unable to decode the Swagger file"
-        Just s  -> pure s
-    _ -> error "You need to provide a filename as first argument"
+  Swagger{..} <- do
+    swaggerFile <- decodeFileStrict filename
+    case swaggerFile of
+      Nothing -> error "Unable to decode the Swagger file"
+      Just s  -> pure s

  -- Convert to Dhall types in a Map
-  let types = Convert.toTypes
+  let types = Convert.toTypes prefixMap
        -- TODO: find a better way to deal with this cyclic import
         $ Data.Map.adjust patchCyclicImports
            (ModelName "io.k8s.apiextensions-apiserver.pkg.apis.apiextensions.v1beta1.JSONSchemaProps")
@ -78,7 +140,7 @@ main = do
    writeDhall path expr

  -- Convert from Dhall types to defaults
-  let defaults = Data.Map.mapMaybeWithKey (Convert.toDefault definitions types) types
+  let defaults = Data.Map.mapMaybeWithKey (Convert.toDefault prefixMap definitions types) types

  -- Output to defaults
  Turtle.mktree "defaults"
@ -88,8 +150,8 @@ main = do

  let toSchema (ModelName key) _ _ =
        Dhall.RecordLit
-          [ ("Type", Dhall.Embed (Convert.mkImport ["types", ".."] (key <> ".dhall")))
-          , ("default", Dhall.Embed (Convert.mkImport ["defaults", ".."] (key <> ".dhall")))
+          [ ("Type", Dhall.Embed (Convert.mkImport prefixMap ["types", ".."] (key <> ".dhall")))
+          , ("default", Dhall.Embed (Convert.mkImport prefixMap ["defaults", ".."] (key <> ".dhall")))
          ]

  let schemas = Data.Map.intersectionWithKey toSchema types defaults
@ -101,10 +163,11 @@ main = do
    writeDhall path expr

  -- Output the types record, the defaults record, and the giant union type
-  let objectNames = Data.Map.keys types
-      typesMap = Convert.getImportsMap objectNames "types" $ Data.Map.keys types
-      defaultsMap = Convert.getImportsMap objectNames "defaults" $ Data.Map.keys defaults
-      schemasMap = Convert.getImportsMap objectNames "schemas" $ Data.Map.keys schemas
+  let getImportsMap = Convert.getImportsMap prefixMap duplicateHandler objectNames
+      objectNames = Data.Map.keys types
+      typesMap = getImportsMap "types" $ Data.Map.keys types
+      defaultsMap = getImportsMap "defaults" $ Data.Map.keys defaults
+      schemasMap = getImportsMap "schemas" $ Data.Map.keys schemas

      typesRecordPath = "./types.dhall"
      typesUnionPath = "./typesUnion.dhall"
--- a/dhall-kubernetes-generator/stack.yaml
+++ b/dhall-kubernetes-generator/stack.yaml
@ -2,5 +2,7 @@ resolver: lts-13.27
 packages:
 - .
 extra-deps:
- dhall-1.24.0
- dhall-json-1.3.0
+- dhall-1.27.0
+- dhall-json-1.5.0
+- th-lift-0.8.0.1
+- th-lift-instances-0.1.14
--- a/dhall-kubernetes-generator/stack.yaml.lock
+++ b/dhall-kubernetes-generator/stack.yaml.lock
@ -5,19 +5,33 @@

 packages:
 - completed:
-    hackage: dhall-1.24.0@sha256:326896b819e9c099ae5b1de5954e577e44e325c287aad6ac77006611d4c60fac,31232
+    hackage: dhall-1.27.0@sha256:b522d6b534949e65771ed0179afc1488e4de2b185af5ed38e4806a6720db51bf,30519
    pantry-tree:
-      size: 142551
-      sha256: 55b3d15eef3d919d4eed222d33fc6a29e13f5ba659691027290ba9f2ff83ec05
+      size: 232998
+      sha256: 3f79ba6a3eeb0f59c1cf41663d65eebe71f5780f5765169e3d52406789a6f286
  original:
-    hackage: dhall-1.24.0
+    hackage: dhall-1.27.0
 - completed:
-    hackage: dhall-json-1.3.0@sha256:7afae1a51b3081b2788497fada89004c2305616357dab9a2c727a6f7c7753d80,4887
+    hackage: dhall-json-1.5.0@sha256:cf5ba9c349539715ba3a9642fbd56e905b1a7675ac82ea48ee4a67bc34446872,5644
    pantry-tree:
-      size: 878
-      sha256: 2fa3f800d259b496a5abd78694ddbfa42b2efe75e1954aa9b7fcf9f9d12103e8
+      size: 3601
+      sha256: 109a2d85c440e3e0371da886ab1ddf004d51b0c20a1e61a8195e74bc0459802f
  original:
-    hackage: dhall-json-1.3.0
+    hackage: dhall-json-1.5.0
+- completed:
+    hackage: th-lift-0.8.0.1@sha256:cceb81b12c0580e02a7a3898b6d60cca5e1be080741f69ddde4f12210d8ba7ca,1960
+    pantry-tree:
+      size: 461
+      sha256: 7ed900048c8722069edb6063023d89343f056ca305be598f51f166bd389621df
+  original:
+    hackage: th-lift-0.8.0.1
+- completed:
+    hackage: th-lift-instances-0.1.14@sha256:351314ffad77a5ba49439accb50d3baf9de0186ab1d8d207e88ed698f1becc5e,2625
+    pantry-tree:
+      size: 526
+      sha256: ef2728ea6af150cf4514254b3ef74f16d8bf6f3c52f4c26a4f2625fceee6fd76
+  original:
+    hackage: th-lift-instances-0.1.14
 snapshots:
 - completed:
    size: 500539
--- a/nix/dhall-kubernetes-generator.nix
+++ b/nix/dhall-kubernetes-generator.nix
@ -1,5 +1,6 @@
-{ mkDerivation, aeson, base, containers, dhall, prettyprinter
-, stdenv, text, turtle, vector, lib
+{ mkDerivation, aeson, base, containers, dhall, megaparsec
+, optparse-applicative, parser-combinators, prettyprinter, sort
+, stdenv, text, turtle, vector
 }:
 mkDerivation {
  pname = "dhall-kubernetes-generator";
@ -8,7 +9,8 @@ mkDerivation {
  isLibrary = false;
  isExecutable = true;
  executableHaskellDepends = [
-    aeson base containers dhall prettyprinter text turtle vector
+    aeson base containers dhall megaparsec optparse-applicative
+    parser-combinators prettyprinter sort text turtle vector
  ];
  homepage = "https://github.com/dhall-lang/dhall-kubernetes#readme";
  license = stdenv.lib.licenses.bsd3;
--- a/nix/nixpkgs.nix
+++ b/nix/nixpkgs.nix
@ -33,7 +33,7 @@ let
          megaparsec = haskellPackagesNew.callPackage ./megaparsec-7.0.2.nix {};

          repline = haskellPackagesNew.callPackage ./repline-0.2.1.0.nix {};
-
+          sort = haskellPackagesNew.callPackage ./sort-1.0.0.0.nix {};
          th-lift = haskellPackagesNew.callPackage ./th-lift-0.8.0.1.nix {};

          th-lift-instances =
--- a/nix/sort-1.0.0.0.nix
+++ b/nix/sort-1.0.0.0.nix
@ -0,0 +1,10 @@
+{ mkDerivation, base, stdenv }:
+mkDerivation {
+  pname = "sort";
+  version = "1.0.0.0";
+  sha256 = "cee3894879cb4b2150331eca96d5d27f51a6114bcb082d1d8dded55881f5770d";
+  libraryHaskellDepends = [ base ];
+  homepage = "https://github.com/cdornan/sort";
+  description = "A Haskell sorting toolkit";
+  license = stdenv.lib.licenses.bsd3;
+}