diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,17 @@ +1.1.0 + +* BREAKING CHANGE: [Add `yaml-to-dhall` support for inferring the schema](https://github.com/dhall-lang/dhall-haskell/pull/1773) + * You no longer need to provide the command with an explicit schema. The + command will infer a reasonably close schema from the provided YAML + * This is a breaking change because the `schema` field of the `Options` type + now has type `Maybe Text` instead of `Text` +* [Add `yaml-to-dhall type` subcommand](https://github.com/dhall-lang/dhall-haskell/pull/1776) + * You can use this subcommand to print the inferred schema for a YAML value, + so that you can edit the schema and use it for subsequent invocations. +* [Add `yaml-to-dhall` support for using `toMap`](https://github.com/dhall-lang/dhall-haskell/pull/1745) + * Now if you specify a `Map` as the schema, the generated Dhall code will + use `toMap` to improve the appearance + 1.0.3 * [yaml: Single-quote date/bool string fields](https://github.com/dhall-lang/dhall-haskell/commits/master/dhall-json) diff --git a/dhall-yaml.cabal b/dhall-yaml.cabal --- a/dhall-yaml.cabal +++ b/dhall-yaml.cabal @@ -1,6 +1,6 @@ Name: dhall-yaml -Version: 1.0.3 -Cabal-Version: >=1.8.0.2 +Version: 1.1.0 +Cabal-Version: >=1.10 Build-Type: Simple Tested-With: GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1 License: GPL-3 @@ -37,7 +37,7 @@ base >= 4.8.0.0 && < 5 , aeson >= 1.0.0.0 && < 1.5 , bytestring < 0.11, - dhall >= 1.31.0 && < 1.32, + dhall >= 1.31.0 && < 1.33, dhall-json >= 1.6.0 && < 1.7 , optparse-applicative >= 0.14.0.0 && < 0.16, text >= 0.11.1.0 && < 1.3 , @@ -46,6 +46,7 @@ Dhall.Yaml Dhall.YamlToDhall GHC-Options: -Wall + Default-Language: Haskell2010 Executable dhall-to-yaml-ng Hs-Source-Dirs: dhall-to-yaml-ng @@ -57,6 +58,7 @@ Other-Modules: Paths_dhall_yaml GHC-Options: -Wall + Default-Language: Haskell2010 Executable yaml-to-dhall Hs-Source-Dirs: yaml-to-dhall @@ -79,6 +81,7 @@ Other-Modules: Paths_dhall_yaml GHC-Options: -Wall + Default-Language: Haskell2010 Test-Suite tasty Type: exitcode-stdio-1.0 @@ -95,3 +98,4 @@ text , tasty-hunit >= 0.2 GHC-Options: -Wall + Default-Language: Haskell2010 diff --git a/src/Dhall/YamlToDhall.hs b/src/Dhall/YamlToDhall.hs --- a/src/Dhall/YamlToDhall.hs +++ b/src/Dhall/YamlToDhall.hs @@ -5,6 +5,7 @@ , defaultOptions , YAMLCompileError(..) , dhallFromYaml + , schemaFromYaml ) where import Control.Exception (Exception, throwIO) @@ -20,7 +21,9 @@ , Conversion(..) , defaultConversion , dhallFromJSON + , inferSchema , resolveSchemaExpr + , schemaToDhallType , showCompileError , typeCheckSchemaExpr ) @@ -28,15 +31,14 @@ -- | Options to parametrize conversion data Options = Options - { schema :: Text + { schema :: Maybe Text , conversion :: Conversion } deriving Show -defaultOptions :: Text -> Options +defaultOptions :: Maybe Text -> Options defaultOptions schema = Options {..} where conversion = defaultConversion - data YAMLCompileError = YAMLCompileError CompileError instance Show YAMLCompileError where @@ -48,20 +50,33 @@ -- | Transform yaml representation into dhall dhallFromYaml :: Options -> ByteString -> IO (Expr Src Void) dhallFromYaml Options{..} yaml = do - value <- either (throwIO . userError) pure (yamlToJson yaml) - expr <- typeCheckSchemaExpr YAMLCompileError =<< resolveSchemaExpr schema + finalSchema <- do + case schema of + Just text -> resolveSchemaExpr text + Nothing -> return (schemaToDhallType (inferSchema value)) + expr <- typeCheckSchemaExpr YAMLCompileError finalSchema + let dhall = dhallFromJSON conversion expr value either (throwIO . YAMLCompileError) pure dhall +-- | Infer the schema from YAML +schemaFromYaml :: ByteString -> IO (Expr Src Void) +schemaFromYaml yaml = do + value <- either (throwIO . userError) pure (yamlToJson yaml) + return (schemaToDhallType (inferSchema value)) + +{-| Wrapper around `Data.YAML.Aeson.decode1Strict` that renders the error + message +-} yamlToJson :: ByteString -> Either String Data.Aeson.Value yamlToJson s = case Data.YAML.Aeson.decode1Strict s of - Right v -> Right v - Left (pos, err) -> Left (show pos ++ err) + Right v -> Right v + Left (pos, err) -> Left (show pos ++ err) showYaml :: Value -> String showYaml value = BS8.unpack (Data.YAML.Aeson.encode1Strict value) diff --git a/tasty/Main.hs b/tasty/Main.hs --- a/tasty/Main.hs +++ b/tasty/Main.hs @@ -10,8 +10,10 @@ import qualified Data.ByteString import qualified Data.Text.IO +import qualified Dhall.Core import qualified Dhall.JSON.Yaml import qualified Dhall.Yaml +import qualified Dhall.YamlToDhall as YamlToDhall import qualified GHC.IO.Encoding import qualified Test.Tasty import qualified Test.Tasty.HUnit @@ -40,6 +42,8 @@ , testDhallToYaml (Dhall.JSON.Yaml.defaultOptions { quoted = True }) "./tasty/data/quoted" + , testYamlToDhall + "./tasty/data/mergify" ] testDhallToYaml :: Options -> String -> TestTree @@ -60,5 +64,24 @@ expectedValue <- Data.ByteString.readFile outputFile let message = "Conversion to YAML did not generate the expected output" + + Test.Tasty.HUnit.assertEqual message expectedValue actualValue + +testYamlToDhall :: String -> TestTree +testYamlToDhall prefix = + Test.Tasty.HUnit.testCase prefix $ do + let inputFile = prefix <> ".yaml" + let outputFile = prefix <> ".dhall" + + bytes <- Data.ByteString.readFile inputFile + + expression <- YamlToDhall.dhallFromYaml (YamlToDhall.defaultOptions Nothing) bytes + + let actualValue = Dhall.Core.pretty expression <> "\n" + + expectedValue <- Data.Text.IO.readFile outputFile + + let message = + "Conversion from YAML did not generate the expected output" Test.Tasty.HUnit.assertEqual message expectedValue actualValue diff --git a/tasty/data/mergify.dhall b/tasty/data/mergify.dhall new file mode 100644 --- /dev/null +++ b/tasty/data/mergify.dhall @@ -0,0 +1,79 @@ +{ pull_request_rules = + [ { actions = + { backport = None { branches : List Text } + , delete_head_branch = None {} + , label = None { remove : List Text } + , merge = Some { method = "squash", strict = "smart" } + } + , conditions = + [ "status-success=continuous-integration/appveyor/pr" + , "label=merge me" + , "#approved-reviews-by>=1" + ] + , name = "Automatically merge pull requests" + } + , { actions = + { backport = None { branches : List Text } + , delete_head_branch = Some {=} + , label = None { remove : List Text } + , merge = None { method : Text, strict : Text } + } + , conditions = [ "merged" ] + , name = "Delete head branch after merge" + } + , { actions = + { backport = Some { branches = [ "1.0.x" ] } + , delete_head_branch = None {} + , label = Some { remove = [ "backport-1.0" ] } + , merge = None { method : Text, strict : Text } + } + , conditions = [ "merged", "label=backport-1.0" ] + , name = "backport patches to 1.0.x branch" + } + , { actions = + { backport = Some { branches = [ "1.1.x" ] } + , delete_head_branch = None {} + , label = Some { remove = [ "backport-1.1" ] } + , merge = None { method : Text, strict : Text } + } + , conditions = [ "merged", "label=backport-1.1" ] + , name = "backport patches to 1.1.x branch" + } + , { actions = + { backport = Some { branches = [ "1.2.x" ] } + , delete_head_branch = None {} + , label = Some { remove = [ "backport-1.2" ] } + , merge = None { method : Text, strict : Text } + } + , conditions = [ "merged", "label=backport-1.2" ] + , name = "backport patches to 1.2.x branch" + } + , { actions = + { backport = Some { branches = [ "1.3.x" ] } + , delete_head_branch = None {} + , label = Some { remove = [ "backport-1.3" ] } + , merge = None { method : Text, strict : Text } + } + , conditions = [ "merged", "label=backport-1.3" ] + , name = "backport patches to 1.3.x branch" + } + , { actions = + { backport = Some { branches = [ "1.4.x" ] } + , delete_head_branch = None {} + , label = Some { remove = [ "backport-1.4" ] } + , merge = None { method : Text, strict : Text } + } + , conditions = [ "merged", "label=backport-1.4" ] + , name = "backport patches to 1.4.x branch" + } + , { actions = + { backport = Some { branches = [ "1.5.x" ] } + , delete_head_branch = None {} + , label = Some { remove = [ "backport-1.5" ] } + , merge = None { method : Text, strict : Text } + } + , conditions = [ "merged", "label=backport" ] + , name = "backport patches to 1.5.x branch" + } + ] +} diff --git a/tasty/data/mergify.yaml b/tasty/data/mergify.yaml new file mode 100644 --- /dev/null +++ b/tasty/data/mergify.yaml @@ -0,0 +1,91 @@ +# ./.mergify.yml + +pull_request_rules: + + - name: Automatically merge pull requests + conditions: + - status-success=continuous-integration/appveyor/pr + - label=merge me + - ! '#approved-reviews-by>=1' + actions: + merge: + strict: smart + method: squash + + - name: Delete head branch after merge + conditions: + - merged + actions: + delete_head_branch: {} + + - name: backport patches to 1.0.x branch + conditions: + - merged + - label=backport-1.0 + actions: + backport: + branches: + - 1.0.x + label: + remove: + - "backport-1.0" + + - name: backport patches to 1.1.x branch + conditions: + - merged + - label=backport-1.1 + actions: + backport: + branches: + - 1.1.x + label: + remove: + - "backport-1.1" + + - name: backport patches to 1.2.x branch + conditions: + - merged + - label=backport-1.2 + actions: + backport: + branches: + - 1.2.x + label: + remove: + - "backport-1.2" + + - name: backport patches to 1.3.x branch + conditions: + - merged + - label=backport-1.3 + actions: + backport: + branches: + - 1.3.x + label: + remove: + - "backport-1.3" + + - name: backport patches to 1.4.x branch + conditions: + - merged + - label=backport-1.4 + actions: + backport: + branches: + - 1.4.x + label: + remove: + - "backport-1.4" + + - name: backport patches to 1.5.x branch + conditions: + - merged + - label=backport + actions: + backport: + branches: + - 1.5.x + label: + remove: + - "backport-1.5" diff --git a/yaml-to-dhall/Main.hs b/yaml-to-dhall/Main.hs --- a/yaml-to-dhall/Main.hs +++ b/yaml-to-dhall/Main.hs @@ -25,6 +25,7 @@ import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty.Terminal import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text import qualified Dhall.Pretty +import qualified Dhall.YamlToDhall as YamlToDhall import qualified GHC.IO.Encoding import qualified Options.Applicative as Options import qualified System.Console.ANSI as ANSI @@ -37,14 +38,20 @@ -- --------------- data CommandOptions - = CommandOptions - { schema :: Text + = Default + { schema :: Maybe Text , conversion :: Conversion , file :: Maybe FilePath , output :: Maybe FilePath , ascii :: Bool , plain :: Bool } + | Type + { file :: Maybe FilePath + , output :: Maybe FilePath + , ascii :: Bool + , plain :: Bool + } | Version deriving (Show) @@ -59,8 +66,9 @@ -- | Parser for all the command arguments and options parseOptions :: Parser CommandOptions parseOptions = - ( CommandOptions - <$> parseSchema + typeCommand + <|> ( Default + <$> optional parseSchema <*> parseConversion <*> optional parseFile <*> optional parseOutput @@ -69,6 +77,18 @@ ) <|> parseVersion where + typeCommand = + Options.hsubparser + (Options.command "type" info <> Options.metavar "type") + where + info = Options.info parser (Options.progDesc "Output the inferred Dhall type from a YAML value") + parser = + Type + <$> optional parseFile + <*> optional parseOutput + <*> parseASCII + <*> parsePlain + parseSchema = Options.strArgument ( Options.metavar "SCHEMA" @@ -119,44 +139,61 @@ options <- Options.execParser parserInfo + let toCharacterSet ascii = case ascii of + True -> ASCII + False -> Unicode + + let toBytes file = case file of + Nothing -> BSL8.getContents + Just path -> BSL8.readFile path + + let renderExpression characterSet plain output expression = do + let document = Dhall.Pretty.prettyCharacterSet characterSet expression + + let stream = Dhall.Pretty.layout document + + case output of + Nothing -> do + supportsANSI <- ANSI.hSupportsANSI IO.stdout + + let ansiStream = + if supportsANSI && not plain + then fmap Dhall.Pretty.annToAnsiStyle stream + else Pretty.unAnnotateS stream + + Pretty.Terminal.renderIO IO.stdout ansiStream + + Text.IO.putStrLn "" + + Just file_ -> + IO.withFile file_ IO.WriteMode $ \h -> do + Pretty.Text.renderIO h stream + + Text.IO.hPutStrLn h "" + case options of Version -> do putStrLn (showVersion Meta.version) - CommandOptions {..} -> do - let characterSet = case ascii of - True -> ASCII - False -> Unicode + Default{..} -> do + let characterSet = toCharacterSet ascii handle $ do - bytes <- case file of - Nothing -> BSL8.getContents - Just path -> BSL8.readFile path - - result <- dhallFromYaml (Options schema conversion) bytes - - let document = Dhall.Pretty.prettyCharacterSet characterSet result - - let stream = Dhall.Pretty.layout document + yaml <- toBytes file - case output of - Nothing -> do - supportsANSI <- ANSI.hSupportsANSI IO.stdout + expression <- dhallFromYaml (Options schema conversion) yaml - let ansiStream = - if supportsANSI && not plain - then fmap Dhall.Pretty.annToAnsiStyle stream - else Pretty.unAnnotateS stream + renderExpression characterSet plain output expression - Pretty.Terminal.renderIO IO.stdout ansiStream + Type{..} -> do + let characterSet = toCharacterSet ascii - Text.IO.putStrLn "" + handle $ do + yaml <- toBytes file - Just file_ -> - IO.withFile file_ IO.WriteMode $ \h -> do - Pretty.Text.renderIO h stream + schema <- YamlToDhall.schemaFromYaml yaml - Text.IO.hPutStrLn h "" + renderExpression characterSet plain output schema handle :: IO a -> IO a handle = Control.Exception.handle handler