{-# LANGUAGE RecordWildCards #-}

module Dhall.YamlToDhall
  ( Options(..)
  , defaultOptions
  , YAMLCompileError(..)
  , dhallFromYaml
  , schemaFromYaml
  ) where

import Control.Exception (Exception, throwIO)
import Data.Aeson        (Value)
import Data.ByteString   (ByteString)
import Data.Text         (Text)
import Data.Void         (Void)
import Dhall.Core        (Expr)
import Dhall.JSONToDhall
    ( CompileError (..)
    , Conversion (..)
    , defaultConversion
    , dhallFromJSON
    , inferSchema
    , resolveSchemaExpr
    , schemaToDhallType
    , showCompileError
    , typeCheckSchemaExpr
    )
import Dhall.Src         (Src)

import qualified Data.ByteString.Char8 as BS8
import qualified Data.YAML.Aeson

-- | Options to parametrize conversion
data Options = Options
    { Options -> Maybe Text
schema     :: Maybe Text
    , Options -> Conversion
conversion :: Conversion
    } deriving Int -> Options -> ShowS
[Options] -> ShowS
Options -> String
(Int -> Options -> ShowS)
-> (Options -> String) -> ([Options] -> ShowS) -> Show Options
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Options] -> ShowS
$cshowList :: [Options] -> ShowS
show :: Options -> String
$cshow :: Options -> String
showsPrec :: Int -> Options -> ShowS
$cshowsPrec :: Int -> Options -> ShowS
Show

defaultOptions :: Maybe Text -> Options
defaultOptions :: Maybe Text -> Options
defaultOptions Maybe Text
schema = Options :: Maybe Text -> Conversion -> Options
Options {Maybe Text
Conversion
conversion :: Conversion
schema :: Maybe Text
conversion :: Conversion
schema :: Maybe Text
..}
  where conversion :: Conversion
conversion = Conversion
defaultConversion

data YAMLCompileError = YAMLCompileError CompileError

instance Show YAMLCompileError where
    show :: YAMLCompileError -> String
show (YAMLCompileError CompileError
e) = String -> (Value -> String) -> CompileError -> String
showCompileError String
"YAML" Value -> String
showYaml CompileError
e

instance Exception YAMLCompileError


-- | Transform yaml representation into dhall
dhallFromYaml :: Options -> ByteString -> IO (Expr Src Void)
dhallFromYaml :: Options -> ByteString -> IO (Expr Src Void)
dhallFromYaml Options{Maybe Text
Conversion
conversion :: Conversion
schema :: Maybe Text
conversion :: Options -> Conversion
schema :: Options -> Maybe Text
..} ByteString
yaml = do
  Value
value <- (String -> IO Value)
-> (Value -> IO Value) -> Either String Value -> IO Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IOError -> IO Value
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO Value) -> (String -> IOError) -> String -> IO Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
userError) Value -> IO Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Either String Value
yamlToJson ByteString
yaml)

  Expr Src Void
finalSchema <-
      case Maybe Text
schema of
          Just Text
text -> Text -> IO (Expr Src Void)
resolveSchemaExpr Text
text
          Maybe Text
Nothing   -> Expr Src Void -> IO (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Schema -> Expr Src Void
forall s a. Schema -> Expr s a
schemaToDhallType (Value -> Schema
inferSchema Value
value))

  Expr Src Void
expr <- (CompileError -> YAMLCompileError)
-> Expr Src Void -> IO (Expr Src Void)
forall e (m :: * -> *).
(Exception e, MonadCatch m) =>
(CompileError -> e) -> Expr Src Void -> m (Expr Src Void)
typeCheckSchemaExpr CompileError -> YAMLCompileError
YAMLCompileError Expr Src Void
finalSchema

  let dhall :: Either CompileError (Expr Src Void)
dhall = Conversion
-> Expr Src Void -> Value -> Either CompileError (Expr Src Void)
dhallFromJSON Conversion
conversion Expr Src Void
expr Value
value

  (CompileError -> IO (Expr Src Void))
-> (Expr Src Void -> IO (Expr Src Void))
-> Either CompileError (Expr Src Void)
-> IO (Expr Src Void)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (YAMLCompileError -> IO (Expr Src Void)
forall e a. Exception e => e -> IO a
throwIO (YAMLCompileError -> IO (Expr Src Void))
-> (CompileError -> YAMLCompileError)
-> CompileError
-> IO (Expr Src Void)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileError -> YAMLCompileError
YAMLCompileError) Expr Src Void -> IO (Expr Src Void)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either CompileError (Expr Src Void)
dhall

-- | Infer the schema from YAML
schemaFromYaml :: ByteString -> IO (Expr Src Void)
schemaFromYaml :: ByteString -> IO (Expr Src Void)
schemaFromYaml ByteString
yaml = do
    Value
value <- (String -> IO Value)
-> (Value -> IO Value) -> Either String Value -> IO Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IOError -> IO Value
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO Value) -> (String -> IOError) -> String -> IO Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IOError
userError) Value -> IO Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Either String Value
yamlToJson ByteString
yaml)

    Expr Src Void -> IO (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Schema -> Expr Src Void
forall s a. Schema -> Expr s a
schemaToDhallType (Value -> Schema
inferSchema Value
value))

{-| Wrapper around `Data.YAML.Aeson.decode1Strict` that renders the error
    message
-}
yamlToJson :: ByteString -> Either String Data.Aeson.Value
yamlToJson :: ByteString -> Either String Value
yamlToJson ByteString
s = case ByteString -> Either (Pos, String) Value
forall v. FromJSON v => ByteString -> Either (Pos, String) v
Data.YAML.Aeson.decode1Strict ByteString
s of
    Right Value
v         -> Value -> Either String Value
forall a b. b -> Either a b
Right Value
v
    Left (Pos
pos, String
err) -> String -> Either String Value
forall a b. a -> Either a b
Left (Pos -> String
forall a. Show a => a -> String
show Pos
pos String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err)

showYaml :: Value -> String
showYaml :: Value -> String
showYaml Value
value = ByteString -> String
BS8.unpack (Value -> ByteString
forall v. ToJSON v => v -> ByteString
Data.YAML.Aeson.encode1Strict Value
value)