{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Dhall.Main
(
Options(..)
, Mode(..)
, parseOptions
, parserInfoOptions
, command
, main
) where
import Control.Applicative (optional, (<|>))
import Control.Exception (Handler(..), SomeException)
import Control.Monad (when)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Text.Prettyprint.Doc (Doc, Pretty)
import Data.Void (Void)
import Dhall.Core (Expr(Annot), Import, pretty)
import Dhall.Freeze (Intent(..), Scope(..))
import Dhall.Import (Imported(..), Depends(..), SemanticCacheMode(..), _semanticCacheMode)
import Dhall.Parser (Src)
import Dhall.Pretty (Ann, CharacterSet(..), annToAnsiStyle)
import Dhall.TypeCheck (Censored(..), DetailedTypeError(..), TypeError)
import Dhall.Util (Censor(..), Header (..), Input(..), Output(..))
import Dhall.Version (dhallVersionString)
import Options.Applicative (Parser, ParserInfo)
import System.Exit (ExitCode, exitFailure)
import System.IO (Handle)
import Text.Dot ((.->.))
import qualified Codec.CBOR.JSON
import qualified Codec.CBOR.Read
import qualified Codec.CBOR.Write
import qualified Control.Exception
import qualified Control.Monad.Trans.State.Strict as State
import qualified Data.Aeson
import qualified Data.Aeson.Encode.Pretty
import qualified Data.ByteString.Lazy
import qualified Data.ByteString.Lazy.Char8
import qualified Data.Map
import qualified Data.Text
import qualified Data.Text.IO
import qualified Data.Text.Prettyprint.Doc as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty
import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty.Text
import qualified Dhall
import qualified Dhall.Binary
import qualified Dhall.Core
import qualified Dhall.Diff
import qualified Dhall.Format
import qualified Dhall.Freeze
import qualified Dhall.Import
import qualified Dhall.Import.Types
import qualified Dhall.Lint
import qualified Dhall.Map
import qualified Dhall.Tags
import qualified Dhall.Pretty
import qualified Dhall.Repl
import qualified Dhall.TypeCheck
import qualified Dhall.Util
import qualified GHC.IO.Encoding
import qualified Options.Applicative
import qualified System.AtomicWrite.Writer.LazyText as AtomicWrite.LazyText
import qualified System.Console.ANSI
import qualified System.Exit as Exit
import qualified System.IO
import qualified System.FilePath
import qualified Text.Dot
import qualified Text.Pretty.Simple
data Options = Options
{ mode :: Mode
, explain :: Bool
, plain :: Bool
, ascii :: Bool
, censor :: Censor
}
ignoreSemanticCache :: Mode -> Bool
ignoreSemanticCache Default {..} = semanticCacheMode == IgnoreSemanticCache
ignoreSemanticCache Resolve {..} = semanticCacheMode == IgnoreSemanticCache
ignoreSemanticCache Type {..} = semanticCacheMode == IgnoreSemanticCache
ignoreSemanticCache _ = False
data Mode
= Default
{ file :: Input
, output :: Output
, annotate :: Bool
, alpha :: Bool
, semanticCacheMode :: SemanticCacheMode
, version :: Bool
}
| Version
| Resolve
{ file :: Input
, resolveMode :: Maybe ResolveMode
, semanticCacheMode :: SemanticCacheMode
}
| Type
{ file :: Input
, quiet :: Bool
, semanticCacheMode :: SemanticCacheMode
}
| Normalize { file :: Input , alpha :: Bool }
| Repl
| Format { formatMode :: Dhall.Format.FormatMode }
| Freeze { inplace :: Input, all_ :: Bool, cache :: Bool }
| Hash { file :: Input }
| Diff { expr1 :: Text, expr2 :: Text }
| Lint { inplace :: Input }
| Tags
{ input :: Input
, output :: Output
, suffixes :: Maybe [Text]
, followSymlinks :: Bool
}
| Encode { file :: Input, json :: Bool }
| Decode { file :: Input, json :: Bool }
| Text { file :: Input }
| SyntaxTree { file :: Input }
data ResolveMode
= Dot
| ListTransitiveDependencies
| ListImmediateDependencies
parseOptions :: Parser Options
parseOptions =
Options
<$> parseMode
<*> switch "explain" "Explain error messages in more detail"
<*> switch "plain" "Disable syntax highlighting"
<*> switch "ascii" "Format code using only ASCII syntax"
<*> parseCensor
where
switch name description =
Options.Applicative.switch
( Options.Applicative.long name
<> Options.Applicative.help description
)
parseCensor = fmap f (switch "censor" "Hide source code in error messages")
where
f True = Censor
f False = NoCensor
subcommand' :: Bool -> String -> String -> Parser a -> Parser a
subcommand' internal name description parser =
Options.Applicative.hsubparser
( Options.Applicative.command name parserInfo
<> Options.Applicative.metavar name
<> if internal then Options.Applicative.internal else mempty
)
where
parserInfo =
Options.Applicative.info parser
( Options.Applicative.fullDesc
<> Options.Applicative.progDesc description
)
subcommand :: String -> String -> Parser a -> Parser a
subcommand = subcommand' False
internalSubcommand :: String -> String -> Parser a -> Parser a
internalSubcommand = subcommand' True
parseMode :: Parser Mode
parseMode =
subcommand
"version"
"Display version"
(pure Version)
<|> subcommand
"resolve"
"Resolve an expression's imports"
(Resolve <$> parseFile <*> parseResolveMode <*> parseSemanticCacheMode)
<|> subcommand
"type"
"Infer an expression's type"
(Type <$> parseFile <*> parseQuiet <*> parseSemanticCacheMode)
<|> subcommand
"normalize"
"Normalize an expression"
(Normalize <$> parseFile <*> parseAlpha)
<|> subcommand
"repl"
"Interpret expressions in a REPL"
(pure Repl)
<|> subcommand
"diff"
"Render the difference between the normal form of two expressions"
(Diff <$> argument "expr1" <*> argument "expr2")
<|> subcommand
"hash"
"Compute semantic hashes for Dhall expressions"
(Hash <$> parseFile)
<|> subcommand
"lint"
"Improve Dhall code by using newer language features and removing dead code"
(Lint <$> parseInplace)
<|> subcommand
"tags"
"Generate etags file"
(Tags <$> parseInput <*> parseTagsOutput <*> parseSuffixes <*> parseFollowSymlinks)
<|> subcommand
"format"
"Standard code formatter for the Dhall language"
(Format <$> parseFormatMode)
<|> subcommand
"freeze"
"Add integrity checks to remote import statements of an expression"
(Freeze <$> parseInplace <*> parseAllFlag <*> parseCacheFlag)
<|> subcommand
"encode"
"Encode a Dhall expression to binary"
(Encode <$> parseFile <*> parseJSONFlag)
<|> subcommand
"decode"
"Decode a Dhall expression from binary"
(Decode <$> parseFile <*> parseJSONFlag)
<|> subcommand
"text"
"Render a Dhall expression that evaluates to a Text literal"
(Text <$> parseFile)
<|> internalSubcommand
"haskell-syntax-tree"
"Output the parsed syntax tree (for debugging)"
(SyntaxTree <$> parseFile)
<|> ( Default
<$> parseFile
<*> parseOutput
<*> parseAnnotate
<*> parseAlpha
<*> parseSemanticCacheMode
<*> parseVersion
)
where
argument =
fmap Data.Text.pack
. Options.Applicative.strArgument
. Options.Applicative.metavar
parseFile = fmap f (optional p)
where
f Nothing = StandardInput
f (Just file) = InputFile file
p = Options.Applicative.strOption
( Options.Applicative.long "file"
<> Options.Applicative.help "Read expression from a file instead of standard input"
<> Options.Applicative.metavar "FILE"
)
parseOutput = fmap f (optional p)
where
f Nothing = StandardOutput
f (Just file) = OutputFile file
p = Options.Applicative.strOption
( Options.Applicative.long "output"
<> Options.Applicative.help "Write result to a file instead of standard output"
<> Options.Applicative.metavar "FILE"
)
parseAlpha =
Options.Applicative.switch
( Options.Applicative.long "alpha"
<> Options.Applicative.help "α-normalize expression"
)
parseAnnotate =
Options.Applicative.switch
( Options.Applicative.long "annotate"
<> Options.Applicative.help "Add a type annotation to the output"
)
parseSemanticCacheMode =
Options.Applicative.flag
UseSemanticCache
IgnoreSemanticCache
( Options.Applicative.long "no-cache"
<> Options.Applicative.help
"Handle protected imports as if the cache was empty"
)
parseVersion =
Options.Applicative.switch
( Options.Applicative.long "version"
<> Options.Applicative.help "Display version"
)
parseResolveMode =
Options.Applicative.flag' (Just Dot)
( Options.Applicative.long "dot"
<> Options.Applicative.help
"Output import dependency graph in dot format"
)
<|>
Options.Applicative.flag' (Just ListImmediateDependencies)
( Options.Applicative.long "immediate-dependencies"
<> Options.Applicative.help
"List immediate import dependencies"
)
<|>
Options.Applicative.flag' (Just ListTransitiveDependencies)
( Options.Applicative.long "transitive-dependencies"
<> Options.Applicative.help
"List transitive import dependencies in post-order"
)
<|> pure Nothing
parseQuiet =
Options.Applicative.switch
( Options.Applicative.long "quiet"
<> Options.Applicative.help "Don't print the inferred type"
)
parseInplace = fmap f (optional p)
where
f Nothing = StandardInput
f (Just file) = InputFile file
p = Options.Applicative.strOption
( Options.Applicative.long "inplace"
<> Options.Applicative.help "Modify the specified file in-place"
<> Options.Applicative.metavar "FILE"
)
parseInput = fmap f (optional p)
where
f Nothing = StandardInput
f (Just path) = InputFile path
p = Options.Applicative.strOption
( Options.Applicative.long "path"
<> Options.Applicative.help "Index all files in path recursively. Will get list of files from STDIN if omitted."
<> Options.Applicative.metavar "PATH"
)
parseTagsOutput = fmap f (optional p)
where
f Nothing = OutputFile "tags"
f (Just file) = OutputFile file
p = Options.Applicative.strOption
( Options.Applicative.long "output"
<> Options.Applicative.help "The name of the file that the tags are written to. Defaults to \"tags\""
<> Options.Applicative.metavar "FILENAME"
)
parseSuffixes = fmap f (optional p)
where
f Nothing = Just [".dhall"]
f (Just "") = Nothing
f (Just line) = Just (Data.Text.splitOn " " line)
p = Options.Applicative.strOption
( Options.Applicative.long "suffixes"
<> Options.Applicative.help "Index only files with suffixes. \"\" to index all files."
<> Options.Applicative.metavar "SUFFIXES"
)
parseFollowSymlinks =
Options.Applicative.switch
( Options.Applicative.long "follow-symlinks"
<> Options.Applicative.help "Follow symlinks when recursing directories"
)
parseJSONFlag =
Options.Applicative.switch
( Options.Applicative.long "json"
<> Options.Applicative.help "Use JSON representation of CBOR"
)
parseAllFlag =
Options.Applicative.switch
( Options.Applicative.long "all"
<> Options.Applicative.help "Add integrity checks to all imports (not just remote imports)"
)
parseCacheFlag =
Options.Applicative.switch
( Options.Applicative.long "cache"
<> Options.Applicative.help "Add fallback unprotected imports when using integrity checks purely for caching purposes"
)
parseCheck =
Options.Applicative.switch
( Options.Applicative.long "check"
<> Options.Applicative.help "Only check if the input is formatted"
)
parseFormatMode = adapt <$> parseCheck <*> parseInplace
where
adapt True path = Dhall.Format.Check {..}
adapt False inplace = Dhall.Format.Modify {..}
parserInfoOptions :: ParserInfo Options
parserInfoOptions =
Options.Applicative.info
(Options.Applicative.helper <*> parseOptions)
( Options.Applicative.progDesc "Interpreter for the Dhall language"
<> Options.Applicative.fullDesc
)
command :: Options -> IO ()
command (Options {..}) = do
let characterSet = case ascii of
True -> ASCII
False -> Unicode
GHC.IO.Encoding.setLocaleEncoding System.IO.utf8
let rootDirectory = \case
InputFile f -> System.FilePath.takeDirectory f
StandardInput -> "."
let toStatus = Dhall.Import.emptyStatus . rootDirectory
let getExpression = Dhall.Util.getExpression censor
let getExpressionAndHeader = Dhall.Util.getExpressionAndHeader censor
let handle io =
Control.Exception.catches io
[ Handler handleTypeError
, Handler handleImported
, Handler handleExitCode
]
where
handleAll e = do
let string = show (e :: SomeException)
if not (null string)
then System.IO.hPutStrLn System.IO.stderr string
else return ()
System.Exit.exitFailure
handleTypeError e = Control.Exception.handle handleAll $ do
let _ = e :: TypeError Src Void
System.IO.hPutStrLn System.IO.stderr ""
if explain
then
case censor of
Censor -> Control.Exception.throwIO (CensoredDetailed (DetailedTypeError e))
NoCensor -> Control.Exception.throwIO (DetailedTypeError e)
else do
Data.Text.IO.hPutStrLn System.IO.stderr "\ESC[2mUse \"dhall --explain\" for detailed errors\ESC[0m"
case censor of
Censor -> Control.Exception.throwIO (Censored e)
NoCensor -> Control.Exception.throwIO e
handleImported (Imported ps e) = Control.Exception.handle handleAll $ do
let _ = e :: TypeError Src Void
System.IO.hPutStrLn System.IO.stderr ""
if explain
then Control.Exception.throwIO (Imported ps (DetailedTypeError e))
else do
Data.Text.IO.hPutStrLn System.IO.stderr "\ESC[2mUse \"dhall --explain\" for detailed errors\ESC[0m"
Control.Exception.throwIO (Imported ps e)
handleExitCode e = do
Control.Exception.throwIO (e :: ExitCode)
let renderDoc :: Handle -> Doc Ann -> IO ()
renderDoc h doc = do
let stream = Dhall.Pretty.layout doc
supportsANSI <- System.Console.ANSI.hSupportsANSI h
let ansiStream =
if supportsANSI && not plain
then fmap annToAnsiStyle stream
else Pretty.unAnnotateS stream
Pretty.renderIO h ansiStream
Data.Text.IO.hPutStrLn h ""
let render :: Pretty a => Handle -> Expr Src a -> IO ()
render h expression = do
let doc = Dhall.Pretty.prettyCharacterSet characterSet expression
renderDoc h doc
let writeDocToFile :: FilePath -> Doc ann -> IO ()
writeDocToFile file doc = do
let stream = Dhall.Pretty.layout (doc <> "\n")
AtomicWrite.LazyText.atomicWriteFile file (Pretty.Text.renderLazy stream)
when (not $ ignoreSemanticCache mode) Dhall.Import.warnAboutMissingCaches
handle $ case mode of
Version -> do
putStrLn dhallVersionString
Default {..} -> do
if version
then do
putStrLn dhallVersionString
Exit.exitSuccess
else return ()
expression <- getExpression file
resolvedExpression <-
Dhall.Import.loadRelativeTo (rootDirectory file) semanticCacheMode expression
inferredType <- Dhall.Core.throws (Dhall.TypeCheck.typeOf resolvedExpression)
let normalizedExpression = Dhall.Core.normalize resolvedExpression
let alphaNormalizedExpression =
if alpha
then Dhall.Core.alphaNormalize normalizedExpression
else normalizedExpression
let annotatedExpression =
if annotate
then Annot alphaNormalizedExpression inferredType
else alphaNormalizedExpression
case output of
StandardOutput -> render System.IO.stdout annotatedExpression
OutputFile file_ ->
writeDocToFile
file_
(Dhall.Pretty.prettyCharacterSet characterSet annotatedExpression)
Resolve { resolveMode = Just Dot, ..} -> do
expression <- getExpression file
(Dhall.Import.Types.Status { _graph, _stack }) <-
State.execStateT (Dhall.Import.loadWith expression) (toStatus file) { _semanticCacheMode = semanticCacheMode }
let (rootImport :| _) = _stack
imports = rootImport : map parent _graph ++ map child _graph
importIds = Data.Map.fromList (zip imports [Text.Dot.userNodeId i | i <- [0..]])
let dotNode (i, nodeId) =
Text.Dot.userNode
nodeId
[ ("label", Data.Text.unpack $ pretty i)
, ("shape", "box")
, ("style", "rounded")
]
let dotEdge (Depends parent child) =
case (Data.Map.lookup parent importIds, Data.Map.lookup child importIds) of
(Just from, Just to) -> from .->. to
_ -> pure ()
let dot = do Text.Dot.attribute ("rankdir", "LR")
mapM_ dotNode (Data.Map.assocs importIds)
mapM_ dotEdge _graph
putStr . ("strict " <>) . Text.Dot.showDot $ dot
Resolve { resolveMode = Just ListImmediateDependencies, ..} -> do
expression <- getExpression file
mapM_ (print
. Pretty.pretty
. Dhall.Core.importHashed) expression
Resolve { resolveMode = Just ListTransitiveDependencies, ..} -> do
expression <- getExpression file
(Dhall.Import.Types.Status { _cache }) <-
State.execStateT (Dhall.Import.loadWith expression) (toStatus file) { _semanticCacheMode = semanticCacheMode }
mapM_ print
. fmap ( Pretty.pretty
. Dhall.Core.importType
. Dhall.Core.importHashed
. Dhall.Import.chainedImport )
. reverse
. Dhall.Map.keys
$ _cache
Resolve { resolveMode = Nothing, ..} -> do
expression <- getExpression file
resolvedExpression <-
Dhall.Import.loadRelativeTo (rootDirectory file) semanticCacheMode expression
render System.IO.stdout resolvedExpression
Normalize {..} -> do
expression <- getExpression file
resolvedExpression <- Dhall.Import.assertNoImports expression
_ <- Dhall.Core.throws (Dhall.TypeCheck.typeOf resolvedExpression)
let normalizedExpression = Dhall.Core.normalize resolvedExpression
let alphaNormalizedExpression =
if alpha
then Dhall.Core.alphaNormalize normalizedExpression
else normalizedExpression
render System.IO.stdout alphaNormalizedExpression
Type {..} -> do
expression <- getExpression file
resolvedExpression <-
Dhall.Import.loadRelativeTo (rootDirectory file) semanticCacheMode expression
inferredType <- Dhall.Core.throws (Dhall.TypeCheck.typeOf resolvedExpression)
if quiet
then return ()
else render System.IO.stdout inferredType
Repl -> do
Dhall.Repl.repl characterSet explain
Diff {..} -> do
expression1 <- Dhall.inputExpr expr1
expression2 <- Dhall.inputExpr expr2
let diff = Dhall.Diff.diffNormalized expression1 expression2
renderDoc System.IO.stdout (Dhall.Diff.doc diff)
if Dhall.Diff.same diff
then return ()
else Exit.exitFailure
Format {..} -> do
Dhall.Format.format (Dhall.Format.Format {..})
Freeze {..} -> do
let scope = if all_ then AllImports else OnlyRemoteImports
let intent = if cache then Cache else Secure
Dhall.Freeze.freeze inplace scope intent characterSet censor
Hash {..} -> do
expression <- getExpression file
resolvedExpression <-
Dhall.Import.loadRelativeTo (rootDirectory file) UseSemanticCache expression
_ <- Dhall.Core.throws (Dhall.TypeCheck.typeOf resolvedExpression)
let normalizedExpression =
Dhall.Core.alphaNormalize (Dhall.Core.normalize resolvedExpression)
Data.Text.IO.putStrLn (Dhall.Import.hashExpressionToCode normalizedExpression)
Lint {..} -> do
(Header header, expression) <- getExpressionAndHeader inplace
let lintedExpression = Dhall.Lint.lint expression
let doc = Pretty.pretty header
<> Dhall.Pretty.prettyCharacterSet characterSet lintedExpression
case inplace of
InputFile file -> writeDocToFile file doc
StandardInput -> renderDoc System.IO.stdout doc
Encode {..} -> do
expression <- getExpression file
let bytes = Dhall.Binary.encodeExpression (Dhall.Core.denote expression)
if json
then do
let decoder = Codec.CBOR.JSON.decodeValue False
(_, value) <- Dhall.Core.throws (Codec.CBOR.Read.deserialiseFromBytes decoder bytes)
let jsonBytes = Data.Aeson.Encode.Pretty.encodePretty value
Data.ByteString.Lazy.Char8.putStrLn jsonBytes
else do
Data.ByteString.Lazy.putStr bytes
Decode {..} -> do
bytes <- do
case file of
InputFile f -> Data.ByteString.Lazy.readFile f
StandardInput -> Data.ByteString.Lazy.getContents
expression <- do
if json
then do
value <- case Data.Aeson.eitherDecode' bytes of
Left string -> fail string
Right value -> return value
let encoding = Codec.CBOR.JSON.encodeValue value
let cborgBytes = Codec.CBOR.Write.toLazyByteString encoding
Dhall.Core.throws (Dhall.Binary.decodeExpression cborgBytes)
else do
Dhall.Core.throws (Dhall.Binary.decodeExpression bytes)
let doc = Dhall.Pretty.prettyCharacterSet characterSet (Dhall.Core.renote expression :: Expr Src Import)
renderDoc System.IO.stdout doc
Text {..} -> do
expression <- getExpression file
resolvedExpression <-
Dhall.Import.loadRelativeTo (rootDirectory file) UseSemanticCache expression
_ <- Dhall.Core.throws (Dhall.TypeCheck.typeOf (Annot resolvedExpression Dhall.Core.Text))
let normalizedExpression = Dhall.Core.normalize resolvedExpression
case normalizedExpression of
Dhall.Core.TextLit (Dhall.Core.Chunks [] text) -> do
Data.Text.IO.putStr text
_ -> do
let invalidDecoderExpected :: Expr Void Void
invalidDecoderExpected = Dhall.Core.Text
let invalidDecoderExpression :: Expr Void Void
invalidDecoderExpression = normalizedExpression
Control.Exception.throwIO (Dhall.InvalidDecoder {..})
Tags {..} -> do
tags <- Dhall.Tags.generate input suffixes followSymlinks
case output of
OutputFile file ->
System.IO.withFile file System.IO.WriteMode (`Data.Text.IO.hPutStr` tags)
StandardOutput -> Data.Text.IO.putStrLn tags
SyntaxTree {..} -> do
expression <- getExpression file
let denoted :: Expr Void Import
denoted = Dhall.Core.denote expression
Text.Pretty.Simple.pPrintNoColor denoted
main :: IO ()
main = do
options <- Options.Applicative.execParser parserInfoOptions
command options