{-# 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.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 Lens.Micro                         as Lens
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
chosenCharacterSet :: Schemas -> Maybe CharacterSet
censor :: Schemas -> Censor
input :: Schemas -> Input
outputMode :: Schemas -> OutputMode
schemas :: Schemas -> Text
chosenCharacterSet :: Maybe CharacterSet
censor :: Censor
input :: Input
outputMode :: OutputMode
schemas :: Text
..} = do
    (inputName, 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 header, expression) <- Util.getExpressionAndHeaderFromStdinText censor inputName originalText

    let 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

    schemasRecord <- Core.throws (Parser.exprFromText "(schemas)" schemas)

    schemasExpression <- rewriteWithSchemas schemasRecord expression

    let docStream =
            Doc Ann -> SimpleDocStream Ann
forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout
                (   Text -> Doc Ann
forall ann. 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 = SimpleDocStream Ann -> Text
forall ann. SimpleDocStream ann -> Text
Pretty.Text.renderStrict SimpleDocStream Ann
docStream

    case 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 a. a -> IO a
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
                    supportsANSI <- Handle -> IO Bool
ANSI.hSupportsANSI Handle
IO.stdout

                    Pretty.Terminal.renderIO
                        IO.stdout
                        (if supportsANSI
                            then fmap Dhall.Pretty.annToAnsiStyle docStream
                            else Pretty.unAnnotateS docStream)

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

                    MultipleCheckFailed -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
Exception.throwIO MultipleCheckFailed{NonEmpty Input
Text
command :: Text
modified :: Text
inputs :: NonEmpty Input
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               <- RecordField s X -> Expr s X
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue (RecordField s X -> Expr s X)
-> Maybe (RecordField s X) -> Maybe (Expr s X)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Map Text (RecordField s X) -> Maybe (RecordField s X)
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) <- RecordField s X -> Expr s X
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue (RecordField s X -> Expr s X)
-> Maybe (RecordField s X) -> Maybe (Expr s X)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Map Text (RecordField s X) -> Maybe (RecordField s X)
forall k v. Ord k => k -> Map k v -> Maybe v
Map.lookup Text
"default" Map Text (RecordField s X)
m =
            (Expr s X, Map Text (Expr s X))
-> Maybe (Expr s X, Map Text (Expr s X))
forall a. a -> Maybe a
Just (Expr s X
_Type, RecordField s X -> Expr s X
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue (RecordField s X -> Expr s X)
-> Map Text (RecordField s X) -> Map Text (Expr s X)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (RecordField s X)
_default)
decodeSchema Expr s X
_ =
    Maybe (Expr s X, Map Text (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
    m <- (RecordField s X -> Maybe (Expr s X, Map Text (Expr s X)))
-> Map Text (RecordField s X)
-> Maybe (Map Text (Expr s X, Map Text (Expr s X)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map Text a -> f (Map Text b)
traverse (Expr s X -> Maybe (Expr s X, Map Text (Expr s X))
forall s. Expr s X -> Maybe (Expr s X, Map Text (Expr s X))
decodeSchema (Expr s X -> Maybe (Expr s X, Map Text (Expr s X)))
-> (RecordField s X -> Expr s X)
-> RecordField s X
-> Maybe (Expr s X, Map Text (Expr s X))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordField s X -> Expr s X
forall s a. RecordField s a -> Expr s a
Core.recordFieldValue) Map Text (RecordField s X)
keyValues

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

            return (Import.hashExpression (Syntax.denote _Type), (name, _default))

    return typeMetadata
decodeSchemas  Expr s X
_ =
    Maybe (Map SHA256Digest (Text, Map Text (Expr s X)))
forall a. Maybe a
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
    resolvedSchemas    <- Expr Src Import -> IO (Expr Src X)
Import.load Expr Src Import
_schemas
    resolvedExpression <- Import.load expression

    _ <- Core.throws (TypeCheck.typeOf resolvedSchemas)
    _ <- Core.throws (TypeCheck.typeOf resolvedExpression)

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

    typeMetadata <- case decodeSchemas normalizedSchemas of
        Just Map SHA256Digest (Text, Map Text (Expr Src X))
typeMetadata -> Map SHA256Digest (Text, Map Text (Expr Src X))
-> IO (Map SHA256Digest (Text, Map Text (Expr Src X)))
forall a. a -> IO a
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           -> SchemasError -> IO (Map SHA256Digest (Text, Map Text (Expr Src X)))
forall e a. (HasCallStack, Exception e) => e -> IO a
Exception.throwIO SchemasError
NotASchemaRecord

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

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

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

                (name, _default) <- Data.Map.lookup hash typeMetadata

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

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

                return (RecordCompletion (Field "schemas" $ Core.makeFieldSelection name) defaultedRecord)
        schemasRewrite Expr Src X
subExpression =
            Expr Src X
subExpression

    let rewrittenExpression :: Expr Src Import
        rewrittenExpression =
            (X -> Import) -> Expr Src X -> Expr Src Import
forall a b. (a -> b) -> Expr Src a -> Expr Src b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap X -> Import
forall a. X -> a
Void.absurd (ASetter (Expr Src X) (Expr Src X) (Expr Src X) (Expr Src X)
-> (Expr Src X -> Expr Src X) -> Expr Src X -> Expr Src X
forall a b. ASetter a b a b -> (b -> b) -> a -> b
Lens.transformOf ASetter (Expr Src X) (Expr Src X) (Expr Src X) (Expr Src X)
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 Expr Src X
forall {t}. Expr t X
normalizedExpression)

    if Normalize.freeIn (V "schemas" 0) rewrittenExpression
        then return (Let (Syntax.makeBinding "schemas" _schemas) rewrittenExpression)
        else return expression

-- | Errors that can be thrown by `rewriteWithSchemas`
data SchemasError = NotASchemaRecord
    deriving (Show SchemasError
Typeable SchemasError
(Typeable SchemasError, Show SchemasError) =>
(SchemasError -> SomeException)
-> (SomeException -> Maybe SchemasError)
-> (SchemasError -> FilePath)
-> (SchemasError -> Bool)
-> Exception SchemasError
SomeException -> Maybe SchemasError
SchemasError -> Bool
SchemasError -> FilePath
SchemasError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> FilePath)
-> (e -> Bool)
-> Exception e
$ctoException :: SchemasError -> SomeException
toException :: SchemasError -> SomeException
$cfromException :: SomeException -> Maybe SchemasError
fromException :: SomeException -> Maybe SchemasError
$cdisplayException :: SchemasError -> FilePath
displayException :: SchemasError -> FilePath
$cbacktraceDesired :: SchemasError -> Bool
backtraceDesired :: SchemasError -> Bool
Exception)

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