ehmry/dhall-haskell
ehmry/dhall-haskell
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Another step in isolate yaml and prepare for HsYaml replacement (#993)

Browse Source
This commit is contained in:
Javier Neira 2019-06-08 05:26:05 +02:00 committed by Gabriel Gonzalez
parent dfee2fbbca
commit 56264270e4
6 changed files with 165 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
dhall-json/dhall-json.cabal
View File

@ -54,7 +54,10 @@ Library
Exposed-Modules:
Dhall.JSON
Dhall.JSONToDhall
Dhall.Yaml
Dhall.Yaml
Dhall.YamlToDhall
GHC-Options: -Wall
if flag(yaml-pre-0_11)
Build-Depends:

36
dhall-json/dhall-to-yaml/Main.hs
View File

@ -4,30 +4,19 @@
module Main where
import Control.Exception (SomeException)
import Data.Aeson (Value)
import Data.Monoid ((<>))
import Dhall.JSON (Conversion, SpecialDoubleMode(..))
import Dhall.JSON (parseOmission, parseConversion)
import Dhall.Yaml (Options(..), dhallToYaml, parseDocuments, parseQuoted)
import Options.Applicative (Parser, ParserInfo)
import qualified Control.Exception
import qualified Data.ByteString
import qualified Data.Text.IO
import qualified Dhall
import qualified Dhall.JSON
import qualified Dhall.Yaml
import qualified GHC.IO.Encoding
import qualified Options.Applicative
import qualified System.Exit
import qualified System.IO
data Options = Options
{ explain :: Bool
, omission :: Value -> Value
, documents :: Bool
, quoted :: Bool
, conversion :: Conversion
}
parseOptions :: Parser Options
parseOptions =
Options
@ -43,18 +32,6 @@ parseOptions =
<> Options.Applicative.help "Explain error messages in detail"
)
parseDocuments =
Options.Applicative.switch
( Options.Applicative.long "documents"
<> Options.Applicative.help "If given a Dhall list, output a document for every element"
)
parseQuoted =
Options.Applicative.switch
( Options.Applicative.long "quoted"
<> Options.Applicative.help "Prevent from generating not quoted scalars"
)
parserInfo :: ParserInfo Options
parserInfo =
Options.Applicative.info
@ -67,18 +44,13 @@ main :: IO ()
main = do
GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8
Options {..} <- Options.Applicative.execParser parserInfo
options <- Options.Applicative.execParser parserInfo
handle $ do
let explaining = if explain then Dhall.detailed else id
stdin <- Data.Text.IO.getContents
json <- omission <$> explaining (Dhall.JSON.codeToValue conversion UseYAMLEncoding "(stdin)" stdin)
let yaml = Dhall.Yaml.jsonToYaml json documents quoted
Data.ByteString.putStr yaml
Data.ByteString.putStr =<< dhallToYaml options "(stdin)" stdin
handle :: IO a -> IO a
handle = Control.Exception.handle handler

70
dhall-json/src/Dhall/Yaml.hs
View File

@ -1,19 +1,77 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Dhall.Yaml ( jsonToYaml, yamlToJson ) where
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Dhall.Yaml
( Options(..)
, parseDocuments
, parseQuoted
, defaultOptions
, dhallToYaml ) where
import Data.Bifunctor (bimap)
import Data.ByteString (ByteString)
import Data.Monoid ((<>))
import Data.Text (Text)
import Dhall.JSON (Conversion(..), SpecialDoubleMode(..),codeToValue)
import Options.Applicative (Parser)
import qualified Data.Aeson
import qualified Data.ByteString
import qualified Data.Vector
import qualified Data.Yaml
import qualified Dhall
import qualified Options.Applicative
#if MIN_VERSION_yaml(0,10,2)
import qualified Data.Text
import qualified Text.Libyaml
#endif
data Options = Options
{ explain :: Bool
, omission :: Data.Aeson.Value -> Data.Aeson.Value
, documents :: Bool
, quoted :: Bool
, conversion :: Conversion
}
defaultOptions :: Options
defaultOptions =
Options { explain = False
, omission = id
, documents = False
, quoted = False
, conversion = NoConversion
}
parseDocuments :: Parser Bool
parseDocuments =
Options.Applicative.switch
( Options.Applicative.long "documents"
<> Options.Applicative.help "If given a Dhall list, output a document for every element"
)
parseQuoted :: Parser Bool
parseQuoted =
Options.Applicative.switch
( Options.Applicative.long "quoted"
<> Options.Applicative.help "Prevent from generating not quoted scalars"
)
{-| Convert a piece of Text carrying a Dhall inscription to an equivalent YAML ByteString
-}
dhallToYaml
:: Options
-> Text -- ^ Describe the input for the sake of error location.
-> Text -- ^ Input text.
-> IO ByteString
dhallToYaml Options{..} name code = do
let explaining = if explain then Dhall.detailed else id
json <- omission <$> explaining (codeToValue conversion UseYAMLEncoding name code)
return $ jsonToYaml json documents quoted
-- | Transform json representation into yaml
jsonToYaml
:: Data.Aeson.Value
@ -48,9 +106,3 @@ jsonToYaml json documents quoted = case (documents, json) of
then quotedOptions
else Data.Yaml.defaultEncodeOptions
#endif
-- | Transform yaml representation into dhall
yamlToJson :: ByteString -> Either String Data.Aeson.Value
yamlToJson =
bimap Data.Yaml.prettyPrintParseException id . Data.Yaml.decodeEither'

68
dhall-json/src/Dhall/YamlToDhall.hs Normal file
View File

@ -0,0 +1,68 @@
{-# LANGUAGE RecordWildCards #-}
module Dhall.YamlToDhall
( Options(..)
, defaultOptions
, YAMLCompileError(..)
, dhallFromYaml
) where
import Data.Bifunctor (bimap)
import Data.ByteString.Lazy (ByteString, toStrict)
import Dhall.JSONToDhall
( CompileError(..)
, Conversion(..)
, defaultConversion
, dhallFromJSON
, resolveSchemaExpr
, showCompileError
, typeCheckSchemaExpr
)
import Control.Exception (Exception, throwIO)
import Data.Aeson (Value)
import Data.Text (Text)
import qualified Data.ByteString.Char8 as BS8
import qualified Data.Yaml
import qualified Dhall.Core as Dhall
-- | Options to parametrize conversion
data Options = Options
{ schema :: Text
, conversion :: Conversion
} deriving Show
defaultOptions :: Text -> Options
defaultOptions schema = Options {..}
where conversion = defaultConversion
data YAMLCompileError = YAMLCompileError CompileError
instance Show YAMLCompileError where
show (YAMLCompileError e) = showCompileError "YAML" showYaml e
instance Exception YAMLCompileError
showYaml :: Value -> String
showYaml value = BS8.unpack (Data.Yaml.encode value)
-- | Transform yaml representation into dhall
dhallFromYaml :: Options -> ByteString -> IO Text
dhallFromYaml Options{..} yaml = do
value <- either (throwIO . userError) pure (yamlToJson yaml)
expr <- typeCheckSchemaExpr YAMLCompileError =<< resolveSchemaExpr schema
let dhall = dhallFromJSON conversion expr value
either (throwIO . YAMLCompileError) (pure . Dhall.pretty) dhall
yamlToJson :: ByteString -> Either String Data.Aeson.Value
yamlToJson =
bimap Data.Yaml.prettyPrintParseException id . Data.Yaml.decodeEither' . toStrict

32
dhall-json/tasty/Main.hs
View File

@ -9,6 +9,7 @@ import Test.Tasty (TestTree)
import qualified Control.Exception
import qualified Data.Aeson
import qualified Data.ByteString.Lazy
import qualified Data.Text
import qualified Data.Text.IO
import qualified Dhall.Import
import qualified Dhall.JSON
@ -72,23 +73,18 @@ yamlQuotedStrings = Test.Tasty.HUnit.testCase "Yaml: quoted string style" assert
code <- Data.Text.IO.readFile file
parsedExpression <- case Dhall.Parser.exprFromText file code of
Left exception -> Control.Exception.throwIO exception
Right parsedExpression -> return parsedExpression
let options =
Dhall.Yaml.defaultOptions { Dhall.Yaml.quoted = True }
resolvedExpression <- Dhall.Import.load parsedExpression
jsonValue <- case Dhall.JSON.dhallToJSON resolvedExpression of
Left exception -> Control.Exception.throwIO exception
Right jsonValue -> return jsonValue
let actualValue = Dhall.Yaml.jsonToYaml jsonValue False True
actualValue <-
Dhall.Yaml.dhallToYaml options (Data.Text.pack file) code
bytes <- Data.ByteString.Lazy.readFile "./tasty/data/quoted.yaml"
let expectedValue = Data.ByteString.Lazy.toStrict bytes
let message =
"Conversion to quoted yaml did not generate the expected output"
"Conversion to quoted yaml did not generate the expected output"
Test.Tasty.HUnit.assertEqual message expectedValue actualValue
@ -100,19 +96,11 @@ yaml = Test.Tasty.HUnit.testCase "Yaml: normal string style" assertion
code <- Data.Text.IO.readFile file
parsedExpression <- case Dhall.Parser.exprFromText file code of
Left exception -> Control.Exception.throwIO exception
Right parsedExpression -> return parsedExpression
resolvedExpression <- Dhall.Import.load parsedExpression
jsonValue <- case Dhall.JSON.dhallToJSON resolvedExpression of
Left exception -> Control.Exception.throwIO exception
Right jsonValue -> return jsonValue
let actualValue = Dhall.Yaml.jsonToYaml jsonValue False False
actualValue <-
Dhall.Yaml.dhallToYaml Dhall.Yaml.defaultOptions (Data.Text.pack file) code
bytes <- Data.ByteString.Lazy.readFile "./tasty/data/normal.yaml"
let expectedValue = Data.ByteString.Lazy.toStrict bytes
let message =

57
dhall-json/yaml-to-dhall/Main.hs
View File

@ -9,10 +9,8 @@
module Main where
import qualified Control.Exception
import Control.Exception (Exception, SomeException, throwIO)
import Control.Exception (SomeException)
import Control.Monad (when)
import qualified Data.Aeson as A
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy.Char8 as BSL8
import Data.Monoid ((<>))
import Data.Text (Text)
@ -24,35 +22,36 @@ import Options.Applicative (Parser, ParserInfo)
import qualified System.Exit
import qualified System.IO
import qualified Dhall.Core as D
import Dhall.JSONToDhall
import Dhall.Yaml (yamlToJson, jsonToYaml)
import Dhall.JSONToDhall (Conversion, parseConversion)
import Dhall.YamlToDhall (Options(..), dhallFromYaml)
import qualified Paths_dhall_json as Meta
-- ---------------
-- Command options
-- ---------------
data CommandOptions = CommandOptions
{ version :: Bool
, schema :: Text
, conversion :: Conversion
} deriving Show
-- | Command info and description
parserInfo :: ParserInfo Options
parserInfo :: ParserInfo CommandOptions
parserInfo = O.info
( O.helper <*> parseOptions)
( O.fullDesc
<> O.progDesc "Populate Dhall value given its Dhall type (schema) from a YAML expression"
)
-- | All the command arguments and options
data Options = Options
{ version :: Bool
, schema :: Text
, conversion :: Conversion
} deriving Show
-- | Parser for all the command arguments and options
parseOptions :: Parser Options
parseOptions = Options <$> parseVersion
<*> parseSchema
<*> parseConversion
parseOptions :: Parser CommandOptions
parseOptions = CommandOptions <$> parseVersion
<*> parseSchema
<*> parseConversion
where
parseSchema = O.strArgument
( O.metavar "SCHEMA"
@ -64,20 +63,6 @@ parseOptions = Options <$> parseVersion
<> O.help "Display version"
)
-- ----------
-- YAML
-- ----------
showYAML :: A.Value -> String
showYAML value = BS8.unpack (jsonToYaml value False False)
data YAMLCompileError = YAMLCompileError CompileError
instance Show YAMLCompileError where
show (YAMLCompileError e) = showCompileError "YAML" showYAML e
instance Exception YAMLCompileError
-- ----------
-- Main
-- ----------
@ -86,7 +71,7 @@ main :: IO ()
main = do
GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8
Options {..} <- O.execParser parserInfo
CommandOptions{..} <- O.execParser parserInfo
when version $ do
putStrLn (showVersion Meta.version)
@ -95,14 +80,8 @@ main = do
handle $ do
stdin <- BSL8.getContents
value <- either (throwIO . userError) pure
(yamlToJson . BS8.concat $ BSL8.toChunks stdin)
Text.putStr =<< dhallFromYaml (Options schema conversion) stdin
expr <- typeCheckSchemaExpr YAMLCompileError =<< resolveSchemaExpr schema
case dhallFromJSON conversion expr value of
Left err -> throwIO $ YAMLCompileError err
Right res -> Text.putStr (D.pretty res)
handle :: IO a -> IO a
handle = Control.Exception.handle handler