{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Dhall.Schemas
(
schemasCommand
, Schemas(..)
, rewriteWithSchemas
, SchemasError(..)
) where
import Control.Applicative (empty)
import Control.Exception (Exception)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Void (Void)
import Dhall.Crypto (SHA256Digest)
import Dhall.Map (Map)
import Dhall.Pretty (CharacterSet (..), detectCharacterSet)
import Dhall.Src (Src)
import Dhall.Syntax (Expr (..), Import, Var (..))
import Dhall.Util
( Censor (..)
, Header (..)
, Input (..)
, MultipleCheckFailed (..)
, OutputMode (..)
)
import qualified Control.Exception as Exception
import qualified Data.Map
import qualified Data.Maybe as Maybe
import qualified Data.Text.IO as Text.IO
import qualified Data.Void as Void
import qualified Dhall.Core as Core
import qualified Dhall.Import as Import
import qualified Dhall.Map as Map
import qualified Dhall.Normalize as Normalize
import qualified Dhall.Optics as Optics
import qualified Dhall.Parser as Parser
import qualified Dhall.Pretty
import qualified Dhall.Substitution as Substitution
import qualified Dhall.Syntax as Syntax
import qualified Dhall.TypeCheck as TypeCheck
import qualified Dhall.Util as Util
import qualified Prettyprinter as Pretty
import qualified Prettyprinter.Render.Terminal as Pretty.Terminal
import qualified Prettyprinter.Render.Text as Pretty.Text
import qualified System.AtomicWrite.Writer.LazyText as AtomicWrite
import qualified System.Console.ANSI as ANSI
import qualified System.IO as IO
data Schemas = Schemas
{ Schemas -> Maybe CharacterSet
chosenCharacterSet :: Maybe CharacterSet
, Schemas -> Censor
censor :: Censor
, Schemas -> Input
input :: Input
, Schemas -> OutputMode
outputMode :: OutputMode
, Schemas -> Text
schemas :: Text
}
schemasCommand :: Schemas -> IO ()
schemasCommand :: Schemas -> IO ()
schemasCommand Schemas{Maybe CharacterSet
Text
OutputMode
Input
Censor
schemas :: Text
outputMode :: OutputMode
input :: Input
censor :: Censor
chosenCharacterSet :: Maybe CharacterSet
schemas :: Schemas -> Text
outputMode :: Schemas -> OutputMode
input :: Schemas -> Input
censor :: Schemas -> Censor
chosenCharacterSet :: Schemas -> Maybe CharacterSet
..} = do
(FilePath
inputName, Text
originalText) <- case Input
input of
InputFile FilePath
file -> (,) FilePath
file (Text -> (FilePath, Text)) -> IO Text -> IO (FilePath, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
Text.IO.readFile FilePath
file
Input
StandardInput -> (,) FilePath
"(input)" (Text -> (FilePath, Text)) -> IO Text -> IO (FilePath, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
Text.IO.getContents
(Header Text
header, Expr Src Import
expression) <- Censor -> FilePath -> Text -> IO (Header, Expr Src Import)
Util.getExpressionAndHeaderFromStdinText Censor
censor FilePath
inputName Text
originalText
let characterSet :: CharacterSet
characterSet = CharacterSet -> Maybe CharacterSet -> CharacterSet
forall a. a -> Maybe a -> a
fromMaybe (Expr Src Import -> CharacterSet
forall a. Expr Src a -> CharacterSet
detectCharacterSet Expr Src Import
expression) Maybe CharacterSet
chosenCharacterSet
Expr Src Import
schemasRecord <- Either ParseError (Expr Src Import) -> IO (Expr Src Import)
forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
Core.throws (FilePath -> Text -> Either ParseError (Expr Src Import)
Parser.exprFromText FilePath
"(schemas)" Text
schemas)
Expr Src Import
schemasExpression <- Expr Src Import -> Expr Src Import -> IO (Expr Src Import)
rewriteWithSchemas Expr Src Import
schemasRecord Expr Src Import
expression
let docStream :: SimpleDocStream Ann
docStream =
Doc Ann -> SimpleDocStream Ann
forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout
( Text -> Doc Ann
forall a ann. Pretty a => a -> Doc ann
Pretty.pretty Text
header
Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<> CharacterSet -> Expr Src Import -> Doc Ann
forall a. Pretty a => CharacterSet -> Expr Src a -> Doc Ann
Dhall.Pretty.prettyCharacterSet CharacterSet
characterSet Expr Src Import
schemasExpression
Doc Ann -> Doc Ann -> Doc Ann
forall a. Semigroup a => a -> a -> a
<> Doc Ann
"\n"
)
let schemasText :: Text
schemasText = SimpleDocStream Ann -> Text
forall ann. SimpleDocStream ann -> Text
Pretty.Text.renderStrict SimpleDocStream Ann
docStream
case OutputMode
outputMode of
OutputMode
Write ->
case Input
input of
InputFile FilePath
file ->
if Text
originalText Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
schemasText
then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else FilePath -> Text -> IO ()
AtomicWrite.atomicWriteFile
FilePath
file
(SimpleDocStream Ann -> Text
forall ann. SimpleDocStream ann -> Text
Pretty.Text.renderLazy SimpleDocStream Ann
docStream)
Input
StandardInput -> do
Bool
supportsANSI <- Handle -> IO Bool
ANSI.hSupportsANSI Handle
IO.stdout
Handle -> SimpleDocStream AnsiStyle -> IO ()
Pretty.Terminal.renderIO
Handle
IO.stdout
(if Bool
supportsANSI
then (Ann -> AnsiStyle)
-> SimpleDocStream Ann -> SimpleDocStream AnsiStyle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ann -> AnsiStyle
Dhall.Pretty.annToAnsiStyle SimpleDocStream Ann
docStream
else SimpleDocStream Ann -> SimpleDocStream AnsiStyle
forall ann xxx. SimpleDocStream ann -> SimpleDocStream xxx
Pretty.unAnnotateS SimpleDocStream Ann
docStream)
OutputMode
Check ->
if Text
originalText Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
schemasText
then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
let command :: Text
command = Text
"rewrite-with-schemas"
let modified :: Text
modified = Text
"rewritten"
let inputs :: NonEmpty Input
inputs = Input -> NonEmpty Input
forall (f :: * -> *) a. Applicative f => a -> f a
pure Input
input
MultipleCheckFailed -> IO ()
forall e a. Exception e => e -> IO a
Exception.throwIO MultipleCheckFailed :: Text -> Text -> NonEmpty Input -> MultipleCheckFailed
MultipleCheckFailed{Text
NonEmpty Input
inputs :: NonEmpty Input
modified :: Text
command :: Text
inputs :: NonEmpty Input
modified :: Text
command :: Text
..}
decodeSchema :: Expr s Void -> Maybe (Expr s Void, Map Text (Expr s Void))
decodeSchema :: Expr s Void -> Maybe (Expr s Void, Map Text (Expr s Void))
decodeSchema (RecordLit Map Text (RecordField s Void)
m)
| Just Expr s Void
_Type <- RecordField s Void -> Expr s Void
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue (RecordField s Void -> Expr s Void)
-> Maybe (RecordField s Void) -> Maybe (Expr s Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Map Text (RecordField s Void) -> Maybe (RecordField s Void)
forall k v. Ord k => k -> Map k v -> Maybe v
Map.lookup Text
"Type" Map Text (RecordField s Void)
m
, Just (RecordLit Map Text (RecordField s Void)
_default) <- RecordField s Void -> Expr s Void
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue (RecordField s Void -> Expr s Void)
-> Maybe (RecordField s Void) -> Maybe (Expr s Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Map Text (RecordField s Void) -> Maybe (RecordField s Void)
forall k v. Ord k => k -> Map k v -> Maybe v
Map.lookup Text
"default" Map Text (RecordField s Void)
m =
(Expr s Void, Map Text (Expr s Void))
-> Maybe (Expr s Void, Map Text (Expr s Void))
forall a. a -> Maybe a
Just (Expr s Void
_Type, RecordField s Void -> Expr s Void
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue (RecordField s Void -> Expr s Void)
-> Map Text (RecordField s Void) -> Map Text (Expr s Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (RecordField s Void)
_default)
decodeSchema Expr s Void
_ =
Maybe (Expr s Void, Map Text (Expr s Void))
forall a. Maybe a
Nothing
decodeSchemas
:: Expr s Void
-> Maybe (Data.Map.Map SHA256Digest (Text, Map Text (Expr s Void)))
decodeSchemas :: Expr s Void
-> Maybe (Map SHA256Digest (Text, Map Text (Expr s Void)))
decodeSchemas (RecordLit Map Text (RecordField s Void)
keyValues) = do
Map Text (Expr s Void, Map Text (Expr s Void))
m <- (RecordField s Void -> Maybe (Expr s Void, Map Text (Expr s Void)))
-> Map Text (RecordField s Void)
-> Maybe (Map Text (Expr s Void, Map Text (Expr s Void)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Expr s Void -> Maybe (Expr s Void, Map Text (Expr s Void))
forall s.
Expr s Void -> Maybe (Expr s Void, Map Text (Expr s Void))
decodeSchema (Expr s Void -> Maybe (Expr s Void, Map Text (Expr s Void)))
-> (RecordField s Void -> Expr s Void)
-> RecordField s Void
-> Maybe (Expr s Void, Map Text (Expr s Void))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordField s Void -> Expr s Void
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue) Map Text (RecordField s Void)
keyValues
let typeMetadata :: Map SHA256Digest (Text, Map Text (Expr s Void))
typeMetadata = [(SHA256Digest, (Text, Map Text (Expr s Void)))]
-> Map SHA256Digest (Text, Map Text (Expr s Void))
forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList ([(SHA256Digest, (Text, Map Text (Expr s Void)))]
-> Map SHA256Digest (Text, Map Text (Expr s Void)))
-> [(SHA256Digest, (Text, Map Text (Expr s Void)))]
-> Map SHA256Digest (Text, Map Text (Expr s Void))
forall a b. (a -> b) -> a -> b
$ do
(Text
name, (Expr s Void
_Type, Map Text (Expr s Void)
_default)) <- Map Text (Expr s Void, Map Text (Expr s Void))
-> [(Text, (Expr s Void, Map Text (Expr s Void)))]
forall k v. Ord k => Map k v -> [(k, v)]
Map.toList Map Text (Expr s Void, Map Text (Expr s Void))
m
(SHA256Digest, (Text, Map Text (Expr s Void)))
-> [(SHA256Digest, (Text, Map Text (Expr s Void)))]
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Void Void -> SHA256Digest
Import.hashExpression (Expr s Void -> Expr Void Void
forall s a t. Expr s a -> Expr t a
Syntax.denote Expr s Void
_Type), (Text
name, Map Text (Expr s Void)
_default))
Map SHA256Digest (Text, Map Text (Expr s Void))
-> Maybe (Map SHA256Digest (Text, Map Text (Expr s Void)))
forall (m :: * -> *) a. Monad m => a -> m a
return Map SHA256Digest (Text, Map Text (Expr s Void))
typeMetadata
decodeSchemas Expr s Void
_ =
Maybe (Map SHA256Digest (Text, Map Text (Expr s Void)))
forall (f :: * -> *) a. Alternative f => f a
empty
rewriteWithSchemas
:: Expr Src Import
-> Expr Src Import
-> IO (Expr Src Import)
rewriteWithSchemas :: Expr Src Import -> Expr Src Import -> IO (Expr Src Import)
rewriteWithSchemas Expr Src Import
_schemas Expr Src Import
expression = do
Expr Src Void
resolvedSchemas <- Expr Src Import -> IO (Expr Src Void)
Import.load Expr Src Import
_schemas
Expr Src Void
resolvedExpression <- Expr Src Import -> IO (Expr Src Void)
Import.load Expr Src Import
expression
Expr Src Void
_ <- Either (TypeError Src Void) (Expr Src Void) -> IO (Expr Src Void)
forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
Core.throws (Expr Src Void -> Either (TypeError Src Void) (Expr Src Void)
forall s. Expr s Void -> Either (TypeError s Void) (Expr s Void)
TypeCheck.typeOf Expr Src Void
resolvedSchemas)
Expr Src Void
_ <- Either (TypeError Src Void) (Expr Src Void) -> IO (Expr Src Void)
forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
Core.throws (Expr Src Void -> Either (TypeError Src Void) (Expr Src Void)
forall s. Expr s Void -> Either (TypeError s Void) (Expr s Void)
TypeCheck.typeOf Expr Src Void
resolvedExpression)
let normalizedSchemas :: Expr t Void
normalizedSchemas = Expr Src Void -> Expr t Void
forall a s t. Eq a => Expr s a -> Expr t a
Normalize.normalize Expr Src Void
resolvedSchemas
let normalizedExpression :: Expr t Void
normalizedExpression = Expr Src Void -> Expr t Void
forall a s t. Eq a => Expr s a -> Expr t a
Normalize.normalize Expr Src Void
resolvedExpression
Map SHA256Digest (Text, Map Text (Expr Src Void))
typeMetadata <- case Expr Src Void
-> Maybe (Map SHA256Digest (Text, Map Text (Expr Src Void)))
forall s.
Expr s Void
-> Maybe (Map SHA256Digest (Text, Map Text (Expr s Void)))
decodeSchemas Expr Src Void
forall t. Expr t Void
normalizedSchemas of
Just Map SHA256Digest (Text, Map Text (Expr Src Void))
typeMetadata -> Map SHA256Digest (Text, Map Text (Expr Src Void))
-> IO (Map SHA256Digest (Text, Map Text (Expr Src Void)))
forall (m :: * -> *) a. Monad m => a -> m a
return Map SHA256Digest (Text, Map Text (Expr Src Void))
typeMetadata
Maybe (Map SHA256Digest (Text, Map Text (Expr Src Void)))
Nothing -> SchemasError
-> IO (Map SHA256Digest (Text, Map Text (Expr Src Void)))
forall e a. Exception e => e -> IO a
Exception.throwIO SchemasError
NotASchemaRecord
let schemasRewrite :: Expr Src Void -> Expr Src Void
schemasRewrite subExpression :: Expr Src Void
subExpression@(RecordLit Map Text (RecordField Src Void)
keyValues) =
Expr Src Void -> Maybe (Expr Src Void) -> Expr Src Void
forall a. a -> Maybe a -> a
Maybe.fromMaybe Expr Src Void
subExpression (Maybe (Expr Src Void) -> Expr Src Void)
-> Maybe (Expr Src Void) -> Expr Src Void
forall a b. (a -> b) -> a -> b
$ do
let substitutions :: Map Text (Expr t Void)
substitutions = Text -> Expr t Void -> Map Text (Expr t Void)
forall k v. k -> v -> Map k v
Map.singleton Text
"schemas" Expr t Void
forall t. Expr t Void
normalizedSchemas
let substitutedExpression :: Expr Src Void
substitutedExpression =
Expr Src Void -> Map Text (Expr Src Void) -> Expr Src Void
forall s a. Expr s a -> Substitutions s a -> Expr s a
Substitution.substitute Expr Src Void
subExpression Map Text (Expr Src Void)
forall t. Map Text (Expr t Void)
substitutions
SHA256Digest
hash <- case Expr Src Void -> Either (TypeError Src Void) (Expr Src Void)
forall s. Expr s Void -> Either (TypeError s Void) (Expr s Void)
TypeCheck.typeOf Expr Src Void
substitutedExpression of
Left TypeError Src Void
_ ->
Maybe SHA256Digest
forall (f :: * -> *) a. Alternative f => f a
empty
Right Expr Src Void
subExpressionType ->
SHA256Digest -> Maybe SHA256Digest
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Void Void -> SHA256Digest
Import.hashExpression (Expr Src Void -> Expr Void Void
forall s a t. Expr s a -> Expr t a
Syntax.denote Expr Src Void
subExpressionType))
(Text
name, Map Text (Expr Src Void)
_default) <- SHA256Digest
-> Map SHA256Digest (Text, Map Text (Expr Src Void))
-> Maybe (Text, Map Text (Expr Src Void))
forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup SHA256Digest
hash Map SHA256Digest (Text, Map Text (Expr Src Void))
typeMetadata
let diff :: a -> a -> Maybe a
diff a
a a
b | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b = Maybe a
forall a. Maybe a
Nothing
| Bool
otherwise = a -> Maybe a
forall a. a -> Maybe a
Just a
a
let defaultedKeyValues :: Map Text (RecordField Src Void)
defaultedKeyValues =
Expr Src Void -> RecordField Src Void
forall s a. Expr s a -> RecordField s a
Core.makeRecordField (Expr Src Void -> RecordField Src Void)
-> Map Text (Expr Src Void) -> Map Text (RecordField Src Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Map Text (Expr Src Void) -> Map Text (Expr Src Void)
forall k v. Map k v -> Map k v
Map.fromMap (
(Expr Src Void -> Expr Src Void -> Maybe (Expr Src Void))
-> Map Text (Expr Src Void)
-> Map Text (Expr Src Void)
-> Map Text (Expr Src Void)
forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Data.Map.differenceWith Expr Src Void -> Expr Src Void -> Maybe (Expr Src Void)
forall a. Eq a => a -> a -> Maybe a
diff
(Map Text (Expr Src Void) -> Map Text (Expr Src Void)
forall k v. Map k v -> Map k v
Map.toMap (Map Text (Expr Src Void) -> Map Text (Expr Src Void))
-> Map Text (Expr Src Void) -> Map Text (Expr Src Void)
forall a b. (a -> b) -> a -> b
$ RecordField Src Void -> Expr Src Void
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue (RecordField Src Void -> Expr Src Void)
-> Map Text (RecordField Src Void) -> Map Text (Expr Src Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (RecordField Src Void)
keyValues)
(Map Text (Expr Src Void) -> Map Text (Expr Src Void)
forall k v. Map k v -> Map k v
Map.toMap Map Text (Expr Src Void)
_default))
let defaultedRecord :: Expr Src Void
defaultedRecord = Map Text (RecordField Src Void) -> Expr Src Void
forall s a. Map Text (RecordField s a) -> Expr s a
RecordLit Map Text (RecordField Src Void)
defaultedKeyValues
Expr Src Void -> Maybe (Expr Src Void)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Src Void -> Expr Src Void -> Expr Src Void
forall s a. Expr s a -> Expr s a -> Expr s a
RecordCompletion (Expr Src Void -> FieldSelection Src -> Expr Src Void
forall s a. Expr s a -> FieldSelection s -> Expr s a
Field Expr Src Void
"schemas" (FieldSelection Src -> Expr Src Void)
-> FieldSelection Src -> Expr Src Void
forall a b. (a -> b) -> a -> b
$ Text -> FieldSelection Src
forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
name) Expr Src Void
defaultedRecord)
schemasRewrite Expr Src Void
subExpression =
Expr Src Void
subExpression
let rewrittenExpression :: Expr Src Import
rewrittenExpression :: Expr Src Import
rewrittenExpression =
(Void -> Import) -> Expr Src Void -> Expr Src Import
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Void -> Import
forall a. Void -> a
Void.absurd (ASetter
(Expr Src Void) (Expr Src Void) (Expr Src Void) (Expr Src Void)
-> (Expr Src Void -> Expr Src Void)
-> Expr Src Void
-> Expr Src Void
forall a b. ASetter a b a b -> (b -> b) -> a -> b
Optics.transformOf ASetter
(Expr Src Void) (Expr Src Void) (Expr Src Void) (Expr Src Void)
forall (f :: * -> *) s a.
Applicative f =>
(Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a)
Syntax.subExpressions Expr Src Void -> Expr Src Void
schemasRewrite Expr Src Void
forall t. Expr t Void
normalizedExpression)
if Var -> Expr Src Import -> Bool
forall a s. Eq a => Var -> Expr s a -> Bool
Normalize.freeIn (Text -> Int -> Var
V Text
"schemas" Int
0) Expr Src Import
rewrittenExpression
then Expr Src Import -> IO (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return (Binding Src Import -> Expr Src Import -> Expr Src Import
forall s a. Binding s a -> Expr s a -> Expr s a
Let (Text -> Expr Src Import -> Binding Src Import
forall s a. Text -> Expr s a -> Binding s a
Syntax.makeBinding Text
"schemas" Expr Src Import
_schemas) Expr Src Import
rewrittenExpression)
else Expr Src Import -> IO (Expr Src Import)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
expression
data SchemasError = NotASchemaRecord
deriving (Show SchemasError
Typeable SchemasError
Typeable SchemasError
-> Show SchemasError
-> (SchemasError -> SomeException)
-> (SomeException -> Maybe SchemasError)
-> (SchemasError -> FilePath)
-> Exception SchemasError
SomeException -> Maybe SchemasError
SchemasError -> FilePath
SchemasError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> FilePath)
-> Exception e
displayException :: SchemasError -> FilePath
$cdisplayException :: SchemasError -> FilePath
fromException :: SomeException -> Maybe SchemasError
$cfromException :: SomeException -> Maybe SchemasError
toException :: SchemasError -> SomeException
$ctoException :: SchemasError -> SomeException
$cp2Exception :: Show SchemasError
$cp1Exception :: Typeable SchemasError
Exception)
instance Show SchemasError where
show :: SchemasError -> FilePath
show SchemasError
NotASchemaRecord =
FilePath
forall string. IsString string => string
Util._ERROR FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
": The --schemas argument is not a record of schemas"