{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Dhall.CsvToDhall (
dhallFromCsv
, parseConversion
, defaultConversion
, resolveSchemaExpr
, typeCheckSchemaExpr
, Conversion(..)
, CompileError(..)
) where
import Control.Applicative ((<|>))
import Control.Exception (Exception, displayException, throwIO)
import Control.Monad.Catch (MonadCatch, throwM)
import Data.Csv (NamedRecord)
import Data.Either (lefts, rights)
import Data.Either.Combinators (mapRight)
import Data.Foldable (toList)
import Data.List ((\\))
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8, decodeUtf8', encodeUtf8)
import Data.Text.Encoding.Error (UnicodeException)
import Data.Text.Read (decimal, double, signed)
import Data.Void (Void)
import Dhall.Core (Expr)
import Dhall.Src (Src)
import Dhall.Util (_ERROR)
import Options.Applicative (Parser)
import Prettyprinter (Pretty)
import qualified Data.Csv
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Sequence as Sequence
import qualified Data.Text
import qualified Dhall.Core as Core
import qualified Dhall.Import
import qualified Dhall.Map as Map
import qualified Dhall.Parser
import qualified Dhall.Pretty
import qualified Dhall.TypeCheck as TypeCheck
import qualified Dhall.Util
import qualified Options.Applicative as O
import qualified Prettyprinter.Render.Text as Pretty
data Conversion = Conversion
{ Conversion -> Bool
strictRecs :: Bool
, Conversion -> UnionConv
unions :: UnionConv
} deriving Int -> Conversion -> ShowS
[Conversion] -> ShowS
Conversion -> String
(Int -> Conversion -> ShowS)
-> (Conversion -> String)
-> ([Conversion] -> ShowS)
-> Show Conversion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Conversion] -> ShowS
$cshowList :: [Conversion] -> ShowS
show :: Conversion -> String
$cshow :: Conversion -> String
showsPrec :: Int -> Conversion -> ShowS
$cshowsPrec :: Int -> Conversion -> ShowS
Show
data UnionConv = UFirst | UNone | UStrict deriving (Int -> UnionConv -> ShowS
[UnionConv] -> ShowS
UnionConv -> String
(Int -> UnionConv -> ShowS)
-> (UnionConv -> String)
-> ([UnionConv] -> ShowS)
-> Show UnionConv
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnionConv] -> ShowS
$cshowList :: [UnionConv] -> ShowS
show :: UnionConv -> String
$cshow :: UnionConv -> String
showsPrec :: Int -> UnionConv -> ShowS
$cshowsPrec :: Int -> UnionConv -> ShowS
Show, ReadPrec [UnionConv]
ReadPrec UnionConv
Int -> ReadS UnionConv
ReadS [UnionConv]
(Int -> ReadS UnionConv)
-> ReadS [UnionConv]
-> ReadPrec UnionConv
-> ReadPrec [UnionConv]
-> Read UnionConv
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [UnionConv]
$creadListPrec :: ReadPrec [UnionConv]
readPrec :: ReadPrec UnionConv
$creadPrec :: ReadPrec UnionConv
readList :: ReadS [UnionConv]
$creadList :: ReadS [UnionConv]
readsPrec :: Int -> ReadS UnionConv
$creadsPrec :: Int -> ReadS UnionConv
Read, UnionConv -> UnionConv -> Bool
(UnionConv -> UnionConv -> Bool)
-> (UnionConv -> UnionConv -> Bool) -> Eq UnionConv
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnionConv -> UnionConv -> Bool
$c/= :: UnionConv -> UnionConv -> Bool
== :: UnionConv -> UnionConv -> Bool
$c== :: UnionConv -> UnionConv -> Bool
Eq)
defaultConversion :: Conversion
defaultConversion :: Conversion
defaultConversion = Conversion :: Bool -> UnionConv -> Conversion
Conversion
{ strictRecs :: Bool
strictRecs = Bool
False
, unions :: UnionConv
unions = UnionConv
UFirst
}
parseConversion :: Parser Conversion
parseConversion :: Parser Conversion
parseConversion = Bool -> UnionConv -> Conversion
Conversion (Bool -> UnionConv -> Conversion)
-> Parser Bool -> Parser (UnionConv -> Conversion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Bool
parseStrict
Parser (UnionConv -> Conversion)
-> Parser UnionConv -> Parser Conversion
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser UnionConv
parseUnion
where
parseStrict :: Parser Bool
parseStrict =
Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> Mod FlagFields a -> Parser a
O.flag' Bool
True
( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"records-strict"
Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
O.help String
"Fail if any CSV fields are missing from the expected Dhall type"
)
Parser Bool -> Parser Bool -> Parser Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> Mod FlagFields a -> Parser a
O.flag' Bool
False
( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"records-loose"
Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
O.help String
"Tolerate CSV fields not present within the expected Dhall type"
)
Parser Bool -> Parser Bool -> Parser Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Parser Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
parseUnion :: Parser UnionConv
parseUnion :: Parser UnionConv
parseUnion =
Parser UnionConv
uFirst
Parser UnionConv -> Parser UnionConv -> Parser UnionConv
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser UnionConv
uNone
Parser UnionConv -> Parser UnionConv -> Parser UnionConv
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser UnionConv
uStrict
Parser UnionConv -> Parser UnionConv -> Parser UnionConv
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> UnionConv -> Parser UnionConv
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnionConv
UFirst
where
uFirst :: Parser UnionConv
uFirst = UnionConv -> Mod FlagFields UnionConv -> Parser UnionConv
forall a. a -> Mod FlagFields a -> Parser a
O.flag' UnionConv
UFirst
( String -> Mod FlagFields UnionConv
forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"unions-first"
Mod FlagFields UnionConv
-> Mod FlagFields UnionConv -> Mod FlagFields UnionConv
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields UnionConv
forall (f :: * -> *) a. String -> Mod f a
O.help String
"The first value with the matching type (successfully parsed all the way down the tree) is accepted, even if not the only possible match. (DEFAULT)"
)
uNone :: Parser UnionConv
uNone = UnionConv -> Mod FlagFields UnionConv -> Parser UnionConv
forall a. a -> Mod FlagFields a -> Parser a
O.flag' UnionConv
UNone
( String -> Mod FlagFields UnionConv
forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"unions-none"
Mod FlagFields UnionConv
-> Mod FlagFields UnionConv -> Mod FlagFields UnionConv
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields UnionConv
forall (f :: * -> *) a. String -> Mod f a
O.help String
"Unions not allowed"
)
uStrict :: Parser UnionConv
uStrict = UnionConv -> Mod FlagFields UnionConv -> Parser UnionConv
forall a. a -> Mod FlagFields a -> Parser a
O.flag' UnionConv
UStrict
( String -> Mod FlagFields UnionConv
forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"unions-strict"
Mod FlagFields UnionConv
-> Mod FlagFields UnionConv -> Mod FlagFields UnionConv
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields UnionConv
forall (f :: * -> *) a. String -> Mod f a
O.help String
"Error if more than one union values match the type (and parse successfully)"
)
type ExprX = Expr Src Void
resolveSchemaExpr :: Text
-> IO ExprX
resolveSchemaExpr :: Text -> IO ExprX
resolveSchemaExpr Text
code = do
Expr Src Import
parsedExpression <-
case String -> Text -> Either ParseError (Expr Src Import)
Dhall.Parser.exprFromText String
"\n\ESC[1;31m(schema)\ESC[0m" Text
code of
Left ParseError
err -> ParseError -> IO (Expr Src Import)
forall e a. Exception e => e -> IO a
throwIO ParseError
err
Right Expr Src Import
parsedExpression -> Expr Src Import -> IO (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
parsedExpression
Expr Src Import -> IO ExprX
Dhall.Import.load Expr Src Import
parsedExpression
typeCheckSchemaExpr :: (Exception e, MonadCatch m)
=> (CompileError -> e) -> ExprX -> m ExprX
typeCheckSchemaExpr :: (CompileError -> e) -> ExprX -> m ExprX
typeCheckSchemaExpr CompileError -> e
compileException ExprX
expr =
case ExprX -> Either (TypeError Src X) ExprX
forall s. Expr s X -> Either (TypeError s X) (Expr s X)
TypeCheck.typeOf ExprX
expr of
Left TypeError Src X
err -> e -> m ExprX
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (e -> m ExprX) -> (CompileError -> e) -> CompileError -> m ExprX
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileError -> e
compileException (CompileError -> m ExprX) -> CompileError -> m ExprX
forall a b. (a -> b) -> a -> b
$ TypeError Src X -> CompileError
TypeError TypeError Src X
err
Right ExprX
t -> case ExprX
t of
Core.Const Const
Core.Type -> ExprX -> m ExprX
forall (m :: * -> *) a. Monad m => a -> m a
return ExprX
expr
ExprX
_ -> e -> m ExprX
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (e -> m ExprX) -> (CompileError -> e) -> CompileError -> m ExprX
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileError -> e
compileException (CompileError -> m ExprX) -> CompileError -> m ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> ExprX -> CompileError
BadSchemaType ExprX
t ExprX
expr
dhallFromCsv :: Conversion -> ExprX -> [NamedRecord] -> Either CompileError ExprX
dhallFromCsv :: Conversion -> ExprX -> [NamedRecord] -> Either CompileError ExprX
dhallFromCsv Conversion{Bool
UnionConv
unions :: UnionConv
strictRecs :: Bool
unions :: Conversion -> UnionConv
strictRecs :: Conversion -> Bool
..} ExprX
typeExpr = ExprX -> [NamedRecord] -> Either CompileError ExprX
listConvert (ExprX -> ExprX
forall a s t. Eq a => Expr s a -> Expr t a
Core.normalize ExprX
typeExpr)
where
listConvert :: ExprX -> [NamedRecord] -> Either CompileError ExprX
listConvert :: ExprX -> [NamedRecord] -> Either CompileError ExprX
listConvert (Core.App ExprX
Core.List recordType :: ExprX
recordType@(Core.Record Map Text (RecordField Src X)
_)) [] = ExprX -> Either CompileError ExprX
forall (m :: * -> *) a. Monad m => a -> m a
return (ExprX -> Either CompileError ExprX)
-> ExprX -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ Maybe ExprX -> Seq ExprX -> ExprX
forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
Core.ListLit (ExprX -> Maybe ExprX
forall a. a -> Maybe a
Just ExprX
recordType) Seq ExprX
forall a. Seq a
Sequence.empty
listConvert (Core.App ExprX
Core.List ExprX
recordType) [] = CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> CompileError
NotARecord ExprX
recordType
listConvert (Core.App ExprX
Core.List ExprX
recordType) [NamedRecord]
csv = do
[ExprX]
a <- (NamedRecord -> Either CompileError ExprX)
-> [NamedRecord] -> Either CompileError [ExprX]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (ExprX -> NamedRecord -> Either CompileError ExprX
recordConvert ExprX
recordType) [NamedRecord]
csv
ExprX -> Either CompileError ExprX
forall (m :: * -> *) a. Monad m => a -> m a
return (ExprX -> Either CompileError ExprX)
-> ExprX -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ Maybe ExprX -> Seq ExprX -> ExprX
forall s a. Maybe (Expr s a) -> Seq (Expr s a) -> Expr s a
Core.ListLit Maybe ExprX
forall a. Maybe a
Nothing (Seq ExprX -> ExprX) -> Seq ExprX -> ExprX
forall a b. (a -> b) -> a -> b
$ [ExprX] -> Seq ExprX
forall a. [a] -> Seq a
Sequence.fromList [ExprX]
a
listConvert ExprX
e [NamedRecord]
_ = CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> CompileError
NotAList ExprX
e
recordConvert :: ExprX -> NamedRecord -> Either CompileError ExprX
recordConvert :: ExprX -> NamedRecord -> Either CompileError ExprX
recordConvert (Core.Record Map Text (RecordField Src X)
record) NamedRecord
csvRecord
| [UnicodeException]
badKeys <- [Either UnicodeException Text] -> [UnicodeException]
forall a b. [Either a b] -> [a]
lefts ((ByteString -> Either UnicodeException Text)
-> [ByteString] -> [Either UnicodeException Text]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Either UnicodeException Text
decodeUtf8' (NamedRecord -> [ByteString]
forall k v. HashMap k v -> [k]
HashMap.keys NamedRecord
csvRecord))
, Bool -> Bool
not ([UnicodeException] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnicodeException]
badKeys)
= CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ UnicodeException -> CompileError
UnicodeError ([UnicodeException] -> UnicodeException
forall a. [a] -> a
head [UnicodeException]
badKeys)
| [Text]
extraKeys <- ((ByteString -> Text) -> [ByteString] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Text
decodeUtf8 ([ByteString] -> [Text]) -> [ByteString] -> [Text]
forall a b. (a -> b) -> a -> b
$ NamedRecord -> [ByteString]
forall k v. HashMap k v -> [k]
HashMap.keys NamedRecord
csvRecord) [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
\\ Map Text (RecordField Src X) -> [Text]
forall k v. Map k v -> [k]
Map.keys Map Text (RecordField Src X)
record
, Bool
strictRecs Bool -> Bool -> Bool
&& Bool -> Bool
not ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
extraKeys)
= CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ [Text] -> CompileError
UnhandledFields [Text]
extraKeys
| Bool
otherwise
= do
let f :: Text -> RecordField Src X -> Either CompileError ExprX
f Text
k RecordField Src X
v = Text -> ExprX -> Maybe ByteString -> Either CompileError ExprX
fieldConvert Text
k (RecordField Src X -> ExprX
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue RecordField Src X
v) (ByteString -> NamedRecord -> Maybe ByteString
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup (Text -> ByteString
encodeUtf8 Text
k) NamedRecord
csvRecord)
Map Text (RecordField Src X)
a <- (Text
-> RecordField Src X -> Either CompileError (RecordField Src X))
-> Map Text (RecordField Src X)
-> Either CompileError (Map Text (RecordField Src X))
forall k (f :: * -> *) a b.
(Ord k, Applicative f) =>
(k -> a -> f b) -> Map k a -> f (Map k b)
Map.traverseWithKey (\Text
k RecordField Src X
v -> (ExprX -> RecordField Src X)
-> Either CompileError ExprX
-> Either CompileError (RecordField Src X)
forall b c a. (b -> c) -> Either a b -> Either a c
mapRight ExprX -> RecordField Src X
forall s a. Expr s a -> RecordField s a
Core.makeRecordField (Text -> RecordField Src X -> Either CompileError ExprX
f Text
k RecordField Src X
v)) Map Text (RecordField Src X)
record
ExprX -> Either CompileError ExprX
forall (m :: * -> *) a. Monad m => a -> m a
return (ExprX -> Either CompileError ExprX)
-> ExprX -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ Map Text (RecordField Src X) -> ExprX
forall s a. Map Text (RecordField s a) -> Expr s a
Core.RecordLit Map Text (RecordField Src X)
a
recordConvert ExprX
e NamedRecord
_ = CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> CompileError
NotARecord ExprX
e
fieldConvert :: Text -> ExprX -> Maybe Data.Csv.Field -> Either CompileError ExprX
fieldConvert :: Text -> ExprX -> Maybe ByteString -> Either CompileError ExprX
fieldConvert Text
recordKey t :: ExprX
t@(Core.Union Map Text (Maybe ExprX)
tm) Maybe ByteString
maybeField = do
let f :: Text -> Maybe ExprX -> Either CompileError ExprX
f Text
unionKey Maybe ExprX
Nothing =
case Maybe ByteString
maybeField of
Maybe ByteString
Nothing -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ Text -> CompileError
MissingField Text
recordKey
Just ByteString
field ->
case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
field of
Left UnicodeException
err -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ UnicodeException -> CompileError
UnicodeError UnicodeException
err
Right Text
_field ->
if Text
_field Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
unionKey
then ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right (ExprX -> Either CompileError ExprX)
-> ExprX -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> FieldSelection Src -> ExprX
forall s a. Expr s a -> FieldSelection s -> Expr s a
Core.Field ExprX
t (FieldSelection Src -> ExprX) -> FieldSelection Src -> ExprX
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection Src
forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
unionKey
else CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> Text -> Text -> CompileError
Mismatch ExprX
t Text
_field Text
recordKey
f Text
unionKey (Just ExprX
_type) = do
ExprX
expression <- Text -> ExprX -> Maybe ByteString -> Either CompileError ExprX
fieldConvert Text
recordKey ExprX
_type Maybe ByteString
maybeField
ExprX -> Either CompileError ExprX
forall (m :: * -> *) a. Monad m => a -> m a
return (ExprX -> ExprX -> ExprX
forall s a. Expr s a -> Expr s a -> Expr s a
Core.App (ExprX -> FieldSelection Src -> ExprX
forall s a. Expr s a -> FieldSelection s -> Expr s a
Core.Field ExprX
t (FieldSelection Src -> ExprX) -> FieldSelection Src -> ExprX
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection Src
forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
unionKey) ExprX
expression)
case (UnionConv
unions, [Either CompileError ExprX] -> [ExprX]
forall a b. [Either a b] -> [b]
rights (Map Text (Either CompileError ExprX) -> [Either CompileError ExprX]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((Text -> Maybe ExprX -> Either CompileError ExprX)
-> Map Text (Maybe ExprX) -> Map Text (Either CompileError ExprX)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Text -> Maybe ExprX -> Either CompileError ExprX
f Map Text (Maybe ExprX)
tm)), Maybe ByteString
maybeField) of
(UnionConv
UNone , [ExprX]
_ , Maybe ByteString
_ ) -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> CompileError
ContainsUnion ExprX
t
(UnionConv
UStrict, xs :: [ExprX]
xs@(ExprX
_:ExprX
_:[ExprX]
_), Just ByteString
field) -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> Text -> Text -> [ExprX] -> CompileError
UndecidableUnion ExprX
t (ByteString -> Text
decodeUtf8 ByteString
field) Text
recordKey [ExprX]
xs
(UnionConv
UStrict, xs :: [ExprX]
xs@(ExprX
_:ExprX
_:[ExprX]
_), Maybe ByteString
Nothing ) -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> Text -> [ExprX] -> CompileError
UndecidableMissingUnion ExprX
t Text
recordKey [ExprX]
xs
(UnionConv
_ , [] , Just ByteString
field) -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> Text -> Text -> CompileError
Mismatch ExprX
t (ByteString -> Text
decodeUtf8 ByteString
field) Text
recordKey
(UnionConv
_ , [] , Maybe ByteString
Nothing ) -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ Text -> CompileError
MissingField Text
recordKey
(UnionConv
UFirst , ExprX
x:[ExprX]
_ , Maybe ByteString
_ ) -> ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right (ExprX -> Either CompileError ExprX)
-> ExprX -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX
x
(UnionConv
UStrict, [ExprX
x] , Maybe ByteString
_ ) -> ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right (ExprX -> Either CompileError ExprX)
-> ExprX -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX
x
fieldConvert Text
_ (Core.App ExprX
Core.Optional ExprX
t) Maybe ByteString
Nothing = ExprX -> Either CompileError ExprX
forall (m :: * -> *) a. Monad m => a -> m a
return (ExprX -> Either CompileError ExprX)
-> ExprX -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> ExprX -> ExprX
forall s a. Expr s a -> Expr s a -> Expr s a
Core.App ExprX
forall s a. Expr s a
Core.None ExprX
t
fieldConvert Text
key ExprX
_ Maybe ByteString
Nothing = CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ Text -> CompileError
MissingField Text
key
fieldConvert Text
key ExprX
Core.Bool (Just ByteString
field) =
case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
field of
Left UnicodeException
err -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ UnicodeException -> CompileError
UnicodeError UnicodeException
err
Right Text
_field ->
case Text
_field of
Text
"true" -> ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right (Bool -> ExprX
forall s a. Bool -> Expr s a
Core.BoolLit Bool
True)
Text
"false" -> ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right (Bool -> ExprX
forall s a. Bool -> Expr s a
Core.BoolLit Bool
False)
Text
_ -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> Text -> Text -> CompileError
Mismatch ExprX
forall s a. Expr s a
Core.Bool Text
_field Text
key
fieldConvert Text
key ExprX
Core.Natural (Just ByteString
field) =
case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
field of
Left UnicodeException
err -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ UnicodeException -> CompileError
UnicodeError UnicodeException
err
Right Text
_field ->
case Reader Natural
forall a. Integral a => Reader a
decimal Text
_field of
Right (Natural
v, Text
"") -> ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right (ExprX -> Either CompileError ExprX)
-> ExprX -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ Natural -> ExprX
forall s a. Natural -> Expr s a
Core.NaturalLit Natural
v
Either String (Natural, Text)
_ -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> Text -> Text -> CompileError
Mismatch ExprX
forall s a. Expr s a
Core.Natural Text
_field Text
key
fieldConvert Text
key ExprX
Core.Integer (Just ByteString
field) =
case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
field of
Left UnicodeException
err -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ UnicodeException -> CompileError
UnicodeError UnicodeException
err
Right Text
_field ->
case (Reader Integer -> Reader Integer
forall a. Num a => Reader a -> Reader a
signed Reader Integer
forall a. Integral a => Reader a
decimal) Text
_field of
Right (Integer
v, Text
"") -> ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right (ExprX -> Either CompileError ExprX)
-> ExprX -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ Integer -> ExprX
forall s a. Integer -> Expr s a
Core.IntegerLit Integer
v
Either String (Integer, Text)
_ -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> Text -> Text -> CompileError
Mismatch ExprX
forall s a. Expr s a
Core.Integer Text
_field Text
key
fieldConvert Text
_ ExprX
Core.Double (Just ByteString
field) =
case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
field of
Left UnicodeException
err -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ UnicodeException -> CompileError
UnicodeError UnicodeException
err
Right Text
_field ->
case Reader Double
double Text
_field of
Right (Double
v, Text
"") -> ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right (ExprX -> Either CompileError ExprX)
-> ExprX -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ DhallDouble -> ExprX
forall s a. DhallDouble -> Expr s a
Core.DoubleLit (DhallDouble -> ExprX) -> DhallDouble -> ExprX
forall a b. (a -> b) -> a -> b
$ Double -> DhallDouble
Core.DhallDouble Double
v
Either String (Double, Text)
_ -> ExprX -> Either CompileError ExprX
forall a b. b -> Either a b
Right (ExprX -> Either CompileError ExprX)
-> ExprX -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ DhallDouble -> ExprX
forall s a. DhallDouble -> Expr s a
Core.DoubleLit (DhallDouble -> ExprX) -> DhallDouble -> ExprX
forall a b. (a -> b) -> a -> b
$ Double -> DhallDouble
Core.DhallDouble (String -> Double
forall a. Read a => String -> a
read String
"NaN")
fieldConvert Text
_ ExprX
Core.Text (Just ByteString
field) =
case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
field of
Left UnicodeException
err -> CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ UnicodeException -> CompileError
UnicodeError UnicodeException
err
Right Text
_field -> ExprX -> Either CompileError ExprX
forall (m :: * -> *) a. Monad m => a -> m a
return (ExprX -> Either CompileError ExprX)
-> ExprX -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ Chunks Src X -> ExprX
forall s a. Chunks s a -> Expr s a
Core.TextLit (Chunks Src X -> ExprX) -> Chunks Src X -> ExprX
forall a b. (a -> b) -> a -> b
$ [(Text, ExprX)] -> Text -> Chunks Src X
forall s a. [(Text, Expr s a)] -> Text -> Chunks s a
Core.Chunks [] (Text -> Chunks Src X) -> Text -> Chunks Src X
forall a b. (a -> b) -> a -> b
$ Text
_field
fieldConvert Text
_ (Core.App ExprX
Core.Optional ExprX
t) (Just ByteString
"") = ExprX -> Either CompileError ExprX
forall (m :: * -> *) a. Monad m => a -> m a
return (ExprX -> Either CompileError ExprX)
-> ExprX -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> ExprX -> ExprX
forall s a. Expr s a -> Expr s a -> Expr s a
Core.App ExprX
forall s a. Expr s a
Core.None ExprX
t
fieldConvert Text
key (Core.App ExprX
Core.Optional ExprX
t) Maybe ByteString
maybeField = do
ExprX
expression <- Text -> ExprX -> Maybe ByteString -> Either CompileError ExprX
fieldConvert Text
key ExprX
t Maybe ByteString
maybeField
ExprX -> Either CompileError ExprX
forall (m :: * -> *) a. Monad m => a -> m a
return (ExprX -> Either CompileError ExprX)
-> ExprX -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> ExprX
forall s a. Expr s a -> Expr s a
Core.Some ExprX
expression
fieldConvert Text
_ ExprX
t Maybe ByteString
_ = CompileError -> Either CompileError ExprX
forall a b. a -> Either a b
Left (CompileError -> Either CompileError ExprX)
-> CompileError -> Either CompileError ExprX
forall a b. (a -> b) -> a -> b
$ ExprX -> CompileError
Unsupported ExprX
t
data CompileError
= Unsupported ExprX
| NotAList ExprX
| NotARecord ExprX
| TypeError (TypeCheck.TypeError Src Void)
| BadSchemaType
ExprX
ExprX
| MissingField Text
| UnhandledFields [Text]
| Mismatch
ExprX
Text
Text
| ContainsUnion ExprX
| UndecidableUnion
ExprX
Text
Text
[ExprX]
| UndecidableMissingUnion
ExprX
Text
[ExprX]
| UnicodeError UnicodeException
deriving Int -> CompileError -> ShowS
[CompileError] -> ShowS
CompileError -> String
(Int -> CompileError -> ShowS)
-> (CompileError -> String)
-> ([CompileError] -> ShowS)
-> Show CompileError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompileError] -> ShowS
$cshowList :: [CompileError] -> ShowS
show :: CompileError -> String
$cshow :: CompileError -> String
showsPrec :: Int -> CompileError -> ShowS
$cshowsPrec :: Int -> CompileError -> ShowS
Show
instance Exception CompileError where
displayException :: CompileError -> String
displayException (Unsupported ExprX
e) =
Text -> String
Data.Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
Text
forall string. IsString string => string
_ERROR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": Invalid record field type \n\
\ \n\
\Explanation: Only the following types of record fields are valid: \n\
\ \n\
\● ❰Bool❱ \n\
\● ❰Natural❱ \n\
\● ❰Integer❱ \n\
\● ❰Double❱ \n\
\● ❰Text❱ \n\
\● ❰Optional❱ tp (where tp is a valid record field type) \n\
\● Unions * \n\
\ \n\
\* Unions can have empty alternatives or alternatives with valid \n\
\ record field types \n\
\ \n\
\Expected one of the previous types but instead got: \n\
\ \n\
\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExprX -> Text
forall a. Pretty a => a -> Text
insert ExprX
e
displayException (NotAList ExprX
e) =
Text -> String
Data.Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
Text
forall string. IsString string => string
_ERROR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": Top level object must be of type ❰List❱ \n\
\ \n\
\Explanation: Translation from CSV only returns ❰List❱s of records. \n\
\Other types can not be translated. \n\
\ \n\
\Expected type List {...} but instead got the following type: \n\
\ \n\
\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExprX -> Text
forall a. Pretty a => a -> Text
insert ExprX
e
displayException (NotARecord ExprX
e) =
Text -> String
Data.Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
Text
forall string. IsString string => string
_ERROR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": Elements of the top-level list must be records \n\
\ \n\
\Explanation: Translation from CSV only returns ❰List❱s of records. \n\
\Other types can not be translated. \n\
\ \n\
\Expected a record type but instead got the following type: \n\
\ \n\
\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExprX -> Text
forall a. Pretty a => a -> Text
insert ExprX
e
displayException (TypeError TypeError Src X
e) = TypeError Src X -> String
forall e. Exception e => e -> String
displayException TypeError Src X
e
displayException (BadSchemaType ExprX
t ExprX
e) =
Text -> String
Data.Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
Text
forall string. IsString string => string
_ERROR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": Schema expression parsed successfully but has wrong Dhall type. \n\
\ \n\
\Expected schema type: Type \n\
\ \n\
\Actual schema type: \n\
\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExprX -> Text
forall a. Pretty a => a -> Text
insert ExprX
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text
" \n\
\ \n\
\Schema Expression: \n\
\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExprX -> Text
forall a. Pretty a => a -> Text
insert ExprX
e
displayException (MissingField Text
key) =
Text -> String
Data.Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
Text
forall string. IsString string => string
_ERROR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": Missing field: \'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\'. \n\
\ \n\
\Explanation: Field present in Dhall type (and not optional) is not provided \n\
\in CSV. Please make sure every non-optional field of the schema is \n\
\present in CSV header. \n\
\ \n\
\If working with headerless CSVs, fields in schema should have the fields \n\
\_1, _2, _3, ... and so forth "
displayException (UnhandledFields [Text]
keys) =
Text -> String
Data.Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
Text
forall string. IsString string => string
_ERROR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": Following field(s): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> [Text] -> Text
Data.Text.intercalate Text
", " [Text]
keys) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\
\are not handled. \n\
\ \n\
\Explanation: Fields present in CSV header are not present in schema. \n\
\You may turn off the --strict-recs flag to ignore this error. "
displayException (Mismatch ExprX
t Text
field Text
key) =
Text -> String
Data.Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
Text
forall string. IsString string => string
_ERROR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": Type mismatch at field: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\
\ \n\
\Explanation: Could not parse CSV field " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\
\into the expected Dhall type: \n\
\ \n\
\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExprX -> Text
forall a. Pretty a => a -> Text
insert ExprX
t
displayException (ContainsUnion ExprX
e) =
Text -> String
Data.Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
Text
forall string. IsString string => string
_ERROR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": Dhall type contains a Union type. \n\
\ \n\
\Explanation: Dhall type contains a Union type for one of the record fields. \n\
\This error occurs because flag --unions-none is turned on. If it is desired to \n\
\have unions in the parsed expression, disable --unions-none flag. \n\
\ \n\
\Expected no unions but got the following type in schema: \n\
\ \n\
\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExprX -> Text
forall a. Pretty a => a -> Text
insert ExprX
e
displayException (UndecidableUnion ExprX
t Text
field Text
key [ExprX]
opts) =
Text -> String
Data.Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
Text
forall string. IsString string => string
_ERROR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": A union typed field can be parsed in more than one way. \n\
\ \n\
\Explanation: The CSV field " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\
\ with key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\
\can be converted in more than one of the expected union type alternatives. \n\
\This error occurs because flag --unions-strict is turned on. You may turn off \n\
\this flag to select the first valid alternative found. \n\
\ \n\
\Expected union type: \n\
\ \n\
\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExprX -> Text
forall a. Pretty a => a -> Text
insert ExprX
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\
\ \n\
\... field can be parsed as the following expressions: \n\
\ \n\
\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Data.Text.intercalate
Text
"\n------------------------------------------------------------------------------\n"
((ExprX -> Text) -> [ExprX] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ExprX -> Text
forall a. Pretty a => a -> Text
insert [ExprX]
opts)
displayException (UndecidableMissingUnion ExprX
t Text
key [ExprX]
opts) =
Text -> String
Data.Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
Text
forall string. IsString string => string
_ERROR Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": A union typed field can be parsed in more than one way. \n\
\ \n\
\Explanation: The record field key " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\
\ missing in CSV \n\
\can be converted in more than one of the expected union type alternatives. \n\
\That is to say, there are more than one alternatives with Optional types. \n\
\This error occurs because flag --unions-strict is turned on. You may turn off \n\
\this flag to select the first valid alternative found. \n\
\ \n\
\Expected union type: \n\
\ \n\
\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExprX -> Text
forall a. Pretty a => a -> Text
insert ExprX
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\
\ \n\
\... missing field can be parsed as the following expressions: \n\
\ \n\
\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Data.Text.intercalate
Text
"\n------------------------------------------------------------------------------\n"
((ExprX -> Text) -> [ExprX] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ExprX -> Text
forall a. Pretty a => a -> Text
insert [ExprX]
opts)
displayException (UnicodeError UnicodeException
e) = UnicodeException -> String
forall e. Exception e => e -> String
displayException UnicodeException
e
insert :: Pretty a => a -> Text
insert :: a -> Text
insert = SimpleDocStream Ann -> Text
forall ann. SimpleDocStream ann -> Text
Pretty.renderStrict (SimpleDocStream Ann -> Text)
-> (a -> SimpleDocStream Ann) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Ann -> SimpleDocStream Ann
forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout (Doc Ann -> SimpleDocStream Ann)
-> (a -> Doc Ann) -> a -> SimpleDocStream Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Ann
forall a. Pretty a => a -> Doc Ann
Dhall.Util.insert