{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

{-| This module contains the implementation of the @dhall rewrite-with-schemas@
    subcommand
-}

module Dhall.Schemas
    ( -- | 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

-- | Arguments to the @rewrite-with-schemas@ subcommand
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
    }

-- | Implementation of the @dhall rewrite-with-schemas@ subcommand
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
Text.IO.readFile FilePath
file
        Input
StandardInput  -> (,) FilePath
"(input)" 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 = forall a. a -> Maybe a -> a
fromMaybe (forall a. Expr Src a -> CharacterSet
detectCharacterSet Expr Src Import
expression) Maybe CharacterSet
chosenCharacterSet

    Expr Src Import
schemasRecord <- 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 =
            forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout
                (   forall a ann. Pretty a => a -> Doc ann
Pretty.pretty Text
header
                forall a. Semigroup a => a -> a -> a
<>  forall a. Pretty a => CharacterSet -> Expr Src a -> Doc Ann
Dhall.Pretty.prettyCharacterSet CharacterSet
characterSet Expr Src Import
schemasExpression
                forall a. Semigroup a => a -> a -> a
<>  Doc Ann
"\n"
                )

    let schemasText :: Text
schemasText = 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 forall a. Eq a => a -> a -> Bool
== Text
schemasText
                        then forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        else FilePath -> Text -> IO ()
AtomicWrite.atomicWriteFile
                                FilePath
file
                                (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ann -> AnsiStyle
Dhall.Pretty.annToAnsiStyle SimpleDocStream Ann
docStream
                            else forall ann xxx. SimpleDocStream ann -> SimpleDocStream xxx
Pretty.unAnnotateS SimpleDocStream Ann
docStream)

        OutputMode
Check ->
            if Text
originalText forall a. Eq a => a -> a -> Bool
== Text
schemasText
                then 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Input
input

                    forall e a. Exception e => e -> IO a
Exception.throwIO MultipleCheckFailed{NonEmpty Input
Text
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 :: forall s. Expr s X -> Maybe (Expr s X, Map Text (Expr s X))
decodeSchema (RecordLit Map Text (RecordField s X)
m)
        | Just  Expr s X
_Type               <- forall s a. RecordField s a -> Expr s a
Core.recordFieldValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. Ord k => k -> Map k v -> Maybe v
Map.lookup Text
"Type" Map Text (RecordField s X)
m
        , Just (RecordLit Map Text (RecordField s X)
_default) <- forall s a. RecordField s a -> Expr s a
Core.recordFieldValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. Ord k => k -> Map k v -> Maybe v
Map.lookup Text
"default" Map Text (RecordField s X)
m =
            forall a. a -> Maybe a
Just (Expr s X
_Type, forall s a. RecordField s a -> Expr s a
Core.recordFieldValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (RecordField s X)
_default)
decodeSchema Expr s X
_ =
    forall a. Maybe a
Nothing

decodeSchemas
    :: Expr s Void
    -> Maybe (Data.Map.Map SHA256Digest (Text, Map Text (Expr s Void)))
decodeSchemas :: forall s.
Expr s X -> Maybe (Map SHA256Digest (Text, Map Text (Expr s X)))
decodeSchemas (RecordLit Map Text (RecordField s X)
keyValues) = do
    Map Text (Expr s X, Map Text (Expr s X))
m <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall s. Expr s X -> Maybe (Expr s X, Map Text (Expr s X))
decodeSchema forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. RecordField s a -> Expr s a
Core.recordFieldValue) Map Text (RecordField s X)
keyValues

    let typeMetadata :: Map SHA256Digest (Text, Map Text (Expr s X))
typeMetadata = forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList forall a b. (a -> b) -> a -> b
$ do
            (Text
name, (Expr s X
_Type, Map Text (Expr s X)
_default)) <- forall k v. Ord k => Map k v -> [(k, v)]
Map.toList Map Text (Expr s X, Map Text (Expr s X))
m

            forall (m :: * -> *) a. Monad m => a -> m a
return (Expr X X -> SHA256Digest
Import.hashExpression (forall s a t. Expr s a -> Expr t a
Syntax.denote Expr s X
_Type), (Text
name, Map Text (Expr s X)
_default))

    forall (m :: * -> *) a. Monad m => a -> m a
return Map SHA256Digest (Text, Map Text (Expr s X))
typeMetadata
decodeSchemas  Expr s X
_ =
    forall (f :: * -> *) a. Alternative f => f a
empty

-- | Simplify a Dhall expression using a record of schemas
rewriteWithSchemas
    :: Expr Src Import
    -- ^ Record of schemas
    -> Expr Src Import
    -- ^ Expression to simplify using the supplied schemas
    -> 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 X
resolvedSchemas    <- Expr Src Import -> IO (Expr Src X)
Import.load Expr Src Import
_schemas
    Expr Src X
resolvedExpression <- Expr Src Import -> IO (Expr Src X)
Import.load Expr Src Import
expression

    Expr Src X
_ <- forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
Core.throws (forall s. Expr s X -> Either (TypeError s X) (Expr s X)
TypeCheck.typeOf Expr Src X
resolvedSchemas)
    Expr Src X
_ <- forall e (io :: * -> *) a.
(Exception e, MonadIO io) =>
Either e a -> io a
Core.throws (forall s. Expr s X -> Either (TypeError s X) (Expr s X)
TypeCheck.typeOf Expr Src X
resolvedExpression)

    let normalizedSchemas :: Expr t X
normalizedSchemas    = forall a s t. Eq a => Expr s a -> Expr t a
Normalize.normalize Expr Src X
resolvedSchemas
    let normalizedExpression :: Expr t X
normalizedExpression = forall a s t. Eq a => Expr s a -> Expr t a
Normalize.normalize Expr Src X
resolvedExpression

    Map SHA256Digest (Text, Map Text (Expr Src X))
typeMetadata <- case forall s.
Expr s X -> Maybe (Map SHA256Digest (Text, Map Text (Expr s X)))
decodeSchemas forall {t}. Expr t X
normalizedSchemas of
        Just Map SHA256Digest (Text, Map Text (Expr Src X))
typeMetadata -> forall (m :: * -> *) a. Monad m => a -> m a
return Map SHA256Digest (Text, Map Text (Expr Src X))
typeMetadata
        Maybe (Map SHA256Digest (Text, Map Text (Expr Src X)))
Nothing           -> forall e a. Exception e => e -> IO a
Exception.throwIO SchemasError
NotASchemaRecord

    let schemasRewrite :: Expr Src X -> Expr Src X
schemasRewrite subExpression :: Expr Src X
subExpression@(RecordLit Map Text (RecordField Src X)
keyValues) =
            forall a. a -> Maybe a -> a
Maybe.fromMaybe Expr Src X
subExpression forall a b. (a -> b) -> a -> b
$ do
                let substitutions :: Map Text (Expr t X)
substitutions = forall k v. k -> v -> Map k v
Map.singleton Text
"schemas" forall {t}. Expr t X
normalizedSchemas

                let substitutedExpression :: Expr Src X
substitutedExpression =
                        forall s a. Expr s a -> Substitutions s a -> Expr s a
Substitution.substitute Expr Src X
subExpression forall {t}. Map Text (Expr t X)
substitutions

                SHA256Digest
hash <- case forall s. Expr s X -> Either (TypeError s X) (Expr s X)
TypeCheck.typeOf Expr Src X
substitutedExpression of
                    Left TypeError Src X
_ ->
                        forall (f :: * -> *) a. Alternative f => f a
empty
                    Right Expr Src X
subExpressionType ->
                        forall (m :: * -> *) a. Monad m => a -> m a
return (Expr X X -> SHA256Digest
Import.hashExpression (forall s a t. Expr s a -> Expr t a
Syntax.denote Expr Src X
subExpressionType))

                (Text
name, Map Text (Expr Src X)
_default) <- forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup SHA256Digest
hash Map SHA256Digest (Text, Map Text (Expr Src X))
typeMetadata

                let diff :: a -> a -> Maybe a
diff a
a a
b | a
a forall a. Eq a => a -> a -> Bool
== a
b    = forall a. Maybe a
Nothing
                             | Bool
otherwise = forall a. a -> Maybe a
Just a
a

                let defaultedKeyValues :: Map Text (RecordField Src X)
defaultedKeyValues =
                        forall s a. Expr s a -> RecordField s a
Core.makeRecordField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        forall k v. Map k v -> Map k v
Map.fromMap (
                            forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Data.Map.differenceWith forall {a}. Eq a => a -> a -> Maybe a
diff
                                (forall k v. Map k v -> Map k v
Map.toMap forall a b. (a -> b) -> a -> b
$ forall s a. RecordField s a -> Expr s a
Core.recordFieldValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (RecordField Src X)
keyValues)
                                (forall k v. Map k v -> Map k v
Map.toMap Map Text (Expr Src X)
_default))

                let defaultedRecord :: Expr Src X
defaultedRecord = forall s a. Map Text (RecordField s a) -> Expr s a
RecordLit Map Text (RecordField Src X)
defaultedKeyValues

                forall (m :: * -> *) a. Monad m => a -> m a
return (forall s a. Expr s a -> Expr s a -> Expr s a
RecordCompletion (forall s a. Expr s a -> FieldSelection s -> Expr s a
Field Expr Src X
"schemas" forall a b. (a -> b) -> a -> b
$ forall s. Text -> FieldSelection s
Core.makeFieldSelection Text
name) Expr Src X
defaultedRecord)
        schemasRewrite Expr Src X
subExpression =
            Expr Src X
subExpression

    let rewrittenExpression :: Expr Src Import
        rewrittenExpression :: Expr Src Import
rewrittenExpression =
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. X -> a
Void.absurd (forall a b. ASetter a b a b -> (b -> b) -> a -> b
Optics.transformOf forall (f :: * -> *) s a.
Applicative f =>
(Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a)
Syntax.subExpressions Expr Src X -> Expr Src X
schemasRewrite forall {t}. Expr t X
normalizedExpression)

    if 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 forall (m :: * -> *) a. Monad m => a -> m a
return (forall s a. Binding s a -> Expr s a -> Expr s a
Let (forall s a. Text -> Expr s a -> Binding s a
Syntax.makeBinding Text
"schemas" Expr Src Import
_schemas) Expr Src Import
rewrittenExpression)
        else forall (m :: * -> *) a. Monad m => a -> m a
return Expr Src Import
expression

-- | Errors that can be thrown by `rewriteWithSchemas`
data SchemasError = NotASchemaRecord
    deriving (Show SchemasError
Typeable 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
Exception)

instance Show SchemasError where
    show :: SchemasError -> FilePath
show SchemasError
NotASchemaRecord =
        forall string. IsString string => string
Util._ERROR forall a. Semigroup a => a -> a -> a
<> FilePath
": The --schemas argument is not a record of schemas"