diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,54 @@ +1.15.0 + +* BREAKING CHANGE TO THE API: Support alternative imports using new `?` operator + * This adds a new constructor which affects exhaustive pattern matches + * See: https://github.com/dhall-lang/dhall-haskell/pull/473 +* BREAKING CHANGE TO THE API: Add `Integer/toDouble` built-in function + * This adds a new constructor which affects exhaustive pattern matches + * See: https://github.com/dhall-lang/dhall-haskell/pull/434 +* BREAKING CHANGE TO THE API: Use strict `Text` instead of lazy `Text` + * See: https://github.com/dhall-lang/dhall-haskell/pull/455 +* BREAKING CHANGE TO THE API: Remove `Buildable` in favor of `Pretty` + * See: https://github.com/dhall-lang/dhall-haskell/pull/459 +* BREAKING CHANGE TO THE API: Removed the `Parent` constructor from `FilePrefix` + * Instead, use `Here` with a `".."` prefix. + * See: https://github.com/dhall-lang/dhall-haskell/pull/407 +* BUG FIX: Disallow duplicate fields in records + * See: https://github.com/dhall-lang/dhall-haskell/pull/430 +* BUG FIX: Fix stripping of leading whitespace in multi-line strings + * See: https://github.com/dhall-lang/dhall-haskell/pull/469 +* BUG FIX: Fix formatting field access of an import + * See: https://github.com/dhall-lang/dhall-haskell/pull/471 +* Add `dhall freeze` command + * See: https://github.com/dhall-lang/dhall-haskell/pull/486 +* Add `dhall diff` command + * See: https://github.com/dhall-lang/dhall-haskell/pull/442 +* Add `dhall lint` command + * See: https://github.com/dhall-lang/dhall-haskell/pull/484 +* Change `dhall-repl`/`dhall-hash`/`dhall-format` to `dhall` subcommands + * i.e. `dhall repl`/`dhall hash`/`dhall format` + * See: https://github.com/dhall-lang/dhall-haskell/pull/435 + * See: https://github.com/dhall-lang/dhall-haskell/pull/452 +* Add `with-http` cabal flag to disable support for remote imports + * See: https://github.com/dhall-lang/dhall-haskell/pull/482 +* Added `inputFrom` and `inputFromWith` + * These allow naming the file that the expression is coming from for better + error messages + * See: https://github.com/dhall-lang/dhall-haskell/pull/464 +* Performance improvements + * See: https://github.com/dhall-lang/dhall-haskell/pull/420 +* Tutorial recommends GitHub for Prelude instead of IPFS + * See: https://github.com/dhall-lang/dhall-haskell/pull/479 +* Pretty-print expressions in type errors + * See: https://github.com/dhall-lang/dhall-haskell/pull/429 +* Formatting improvements + * See: https://github.com/dhall-lang/dhall-haskell/pull/398 + * See: https://github.com/dhall-lang/dhall-haskell/pull/458 +* Diff improvements + * See: https://github.com/dhall-lang/dhall-haskell/pull/455 + * See: https://github.com/dhall-lang/dhall-haskell/pull/470 + * See: https://github.com/dhall-lang/dhall-haskell/pull/478 + 1.14.0 * BREAKING CHANGE TO THE LANGUAGE: Switch grammar of `Natural` and `Integer` diff --git a/Prelude/Integer/toDouble b/Prelude/Integer/toDouble new file mode 100644 --- /dev/null +++ b/Prelude/Integer/toDouble @@ -0,0 +1,12 @@ +{- +Convert an `Integer` to the corresponding `Double` + +Examples: + +``` +./toDouble -3 = -3.0 + +./toDouble +2 = 2.0 +``` +-} +let toDouble : Integer → Double = Integer/toDouble in toDouble diff --git a/Prelude/Natural/toDouble b/Prelude/Natural/toDouble new file mode 100644 --- /dev/null +++ b/Prelude/Natural/toDouble @@ -0,0 +1,16 @@ +{- +Convert a `Natural` number to the corresponding `Double` + +Examples: + +``` +./toDouble 3 = 3.0 + +./toDouble 0 = 0.0 +``` +-} + let toDouble + : Natural → Double + = λ(n : Natural) → Integer/toDouble (Natural/toInteger n) + +in toDouble diff --git a/benchmark/deep-nested-large-record/BigEnum.dhall b/benchmark/deep-nested-large-record/BigEnum.dhall new file mode 100644 --- /dev/null +++ b/benchmark/deep-nested-large-record/BigEnum.dhall @@ -0,0 +1,302 @@ +< A0 : {} +| A1 : {} +| A2 : {} +| A3 : {} +| A4 : {} +| A5 : {} +| A6 : {} +| A7 : {} +| A8 : {} +| A9 : {} +| A10 : {} +| A11 : {} +| A12 : {} +| A13 : {} +| A14 : {} +| A15 : {} +| A16 : {} +| A17 : {} +| A18 : {} +| A19 : {} +| A20 : {} +| A21 : {} +| A22 : {} +| A23 : {} +| A24 : {} +| A25 : {} +| A26 : {} +| A27 : {} +| A28 : {} +| A29 : {} +| A30 : {} +| A31 : {} +| A32 : {} +| A33 : {} +| A34 : {} +| A35 : {} +| A36 : {} +| A37 : {} +| A38 : {} +| A39 : {} +| A40 : {} +| A41 : {} +| A42 : {} +| A43 : {} +| A44 : {} +| A45 : {} +| A46 : {} +| A47 : {} +| A48 : {} +| A49 : {} +| A50 : {} +| A51 : {} +| A52 : {} +| A53 : {} +| A54 : {} +| A55 : {} +| A56 : {} +| A57 : {} +| A58 : {} +| A59 : {} +| A60 : {} +| A61 : {} +| A62 : {} +| A63 : {} +| A64 : {} +| A65 : {} +| A66 : {} +| A67 : {} +| A68 : {} +| A69 : {} +| A70 : {} +| A71 : {} +| A72 : {} +| A73 : {} +| A74 : {} +| A75 : {} +| A76 : {} +| A77 : {} +| A78 : {} +| A79 : {} +| A80 : {} +| A81 : {} +| A82 : {} +| A83 : {} +| A84 : {} +| A85 : {} +| A86 : {} +| A87 : {} +| A88 : {} +| A89 : {} +| A90 : {} +| A91 : {} +| A92 : {} +| A93 : {} +| A94 : {} +| A95 : {} +| A96 : {} +| A97 : {} +| A98 : {} +| A99 : {} +| A100 : {} +| A101 : {} +| A102 : {} +| A103 : {} +| A104 : {} +| A105 : {} +| A106 : {} +| A107 : {} +| A108 : {} +| A109 : {} +| A110 : {} +| A111 : {} +| A112 : {} +| A113 : {} +| A114 : {} +| A115 : {} +| A116 : {} +| A117 : {} +| A118 : {} +| A119 : {} +| A120 : {} +| A121 : {} +| A122 : {} +| A123 : {} +| A124 : {} +| A125 : {} +| A126 : {} +| A127 : {} +| A128 : {} +| A129 : {} +| A130 : {} +| A131 : {} +| A132 : {} +| A133 : {} +| A134 : {} +| A135 : {} +| A136 : {} +| A137 : {} +| A138 : {} +| A139 : {} +| A140 : {} +| A141 : {} +| A142 : {} +| A143 : {} +| A144 : {} +| A145 : {} +| A146 : {} +| A147 : {} +| A148 : {} +| A149 : {} +| A150 : {} +| A151 : {} +| A152 : {} +| A153 : {} +| A154 : {} +| A155 : {} +| A156 : {} +| A157 : {} +| A158 : {} +| A159 : {} +| A160 : {} +| A161 : {} +| A162 : {} +| A163 : {} +| A164 : {} +| A165 : {} +| A166 : {} +| A167 : {} +| A168 : {} +| A169 : {} +| A170 : {} +| A171 : {} +| A172 : {} +| A173 : {} +| A174 : {} +| A175 : {} +| A176 : {} +| A177 : {} +| A178 : {} +| A179 : {} +| A180 : {} +| A181 : {} +| A182 : {} +| A183 : {} +| A184 : {} +| A185 : {} +| A186 : {} +| A187 : {} +| A188 : {} +| A189 : {} +| A190 : {} +| A191 : {} +| A192 : {} +| A193 : {} +| A194 : {} +| A195 : {} +| A196 : {} +| A197 : {} +| A198 : {} +| A199 : {} +| A200 : {} +| A201 : {} +| A202 : {} +| A203 : {} +| A204 : {} +| A205 : {} +| A206 : {} +| A207 : {} +| A208 : {} +| A209 : {} +| A210 : {} +| A211 : {} +| A212 : {} +| A213 : {} +| A214 : {} +| A215 : {} +| A216 : {} +| A217 : {} +| A218 : {} +| A219 : {} +| A220 : {} +| A221 : {} +| A222 : {} +| A223 : {} +| A224 : {} +| A225 : {} +| A226 : {} +| A227 : {} +| A228 : {} +| A229 : {} +| A230 : {} +| A231 : {} +| A232 : {} +| A233 : {} +| A234 : {} +| A235 : {} +| A236 : {} +| A237 : {} +| A238 : {} +| A239 : {} +| A240 : {} +| A241 : {} +| A242 : {} +| A243 : {} +| A244 : {} +| A245 : {} +| A246 : {} +| A247 : {} +| A248 : {} +| A249 : {} +| A250 : {} +| A251 : {} +| A252 : {} +| A253 : {} +| A254 : {} +| A255 : {} +| A256 : {} +| A257 : {} +| A258 : {} +| A259 : {} +| A260 : {} +| A261 : {} +| A262 : {} +| A263 : {} +| A264 : {} +| A265 : {} +| A266 : {} +| A267 : {} +| A268 : {} +| A269 : {} +| A270 : {} +| A271 : {} +| A272 : {} +| A273 : {} +| A274 : {} +| A275 : {} +| A276 : {} +| A277 : {} +| A278 : {} +| A279 : {} +| A280 : {} +| A281 : {} +| A282 : {} +| A283 : {} +| A284 : {} +| A285 : {} +| A286 : {} +| A287 : {} +| A288 : {} +| A289 : {} +| A290 : {} +| A291 : {} +| A292 : {} +| A293 : {} +| A294 : {} +| A295 : {} +| A296 : {} +| A297 : {} +| A298 : {} +| A299 : {} +| A300 : {} +> diff --git a/benchmark/deep-nested-large-record/LittleEnum.dhall b/benchmark/deep-nested-large-record/LittleEnum.dhall new file mode 100644 --- /dev/null +++ b/benchmark/deep-nested-large-record/LittleEnum.dhall @@ -0,0 +1,4 @@ +< Foo : {} +| Bar : {} +| Baz : {} +> diff --git a/benchmark/deep-nested-large-record/Main.hs b/benchmark/deep-nested-large-record/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/deep-nested-large-record/Main.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import qualified Criterion as Criterion +import Criterion.Main (defaultMain) +import qualified Data.Sequence as Seq +import qualified Dhall.Core as Core +import qualified Dhall.Import as Import +import qualified Dhall.TypeCheck as TypeCheck + +dhallPreludeImport :: Core.Import +dhallPreludeImport = Core.Import + { Core.importMode = Core.Code + , Core.importHashed = Core.ImportHashed + { Core.hash = Nothing + , Core.importType = Core.Local Core.Here $ Core.File + { Core.directory = Core.Directory ["deep-nested-large-record", "benchmark"] + , Core.file = "prelude.dhall" + } + } + } + +issue412 :: Core.Expr s TypeCheck.X -> Criterion.Benchmarkable +issue412 prelude = Criterion.whnf TypeCheck.typeOf expr + where + expr + = Core.Let "prelude" Nothing prelude + $ Core.ListLit Nothing + $ Seq.replicate 5 + $ Core.Var (Core.V "prelude" 0) `Core.Field` "types" `Core.Field` "Little" `Core.Field` "Foo" + +main :: IO () +main = do + prelude <- Import.load (Core.Embed dhallPreludeImport) + defaultMain + [ Criterion.bench "issue 412" (issue412 prelude) + ] diff --git a/benchmark/deep-nested-large-record/prelude.dhall b/benchmark/deep-nested-large-record/prelude.dhall new file mode 100644 --- /dev/null +++ b/benchmark/deep-nested-large-record/prelude.dhall @@ -0,0 +1,5 @@ +{ types = + { Big = constructors ./BigEnum.dhall + , Little = constructors ./LittleEnum.dhall + } +} diff --git a/benchmark/examples/issue108.dhall b/benchmark/examples/issue108.dhall new file mode 100644 --- /dev/null +++ b/benchmark/examples/issue108.dhall @@ -0,0 +1,61 @@ +λ(xs : List { cores : Natural, host : Text, key : Text, mandatoryFeatures : +List Text, platforms : List < AArch64_Linux : {} | ARMv5tel_Linux : {} | +ARMv7l_Linux : {} | I686_Cygwin : {} | I686_Linux : {} | MIPS64el_Linux : {} | +PowerPC_Linux : {} | X86_64_Cygwin : {} | X86_64_Darwin : {} | X86_64_FreeBSD : +{} | X86_64_Linux : {} | X86_64_Solaris : {} >, speedFactor : Natural, +supportedFeatures : List Text, user : Optional Text }) → List/fold { cores : +Natural, host : Text, key : Text, mandatoryFeatures : List Text, platforms : +List < AArch64_Linux : {} | ARMv5tel_Linux : {} | ARMv7l_Linux : {} | +I686_Cygwin : {} | I686_Linux : {} | MIPS64el_Linux : {} | PowerPC_Linux : {} | +X86_64_Cygwin : {} | X86_64_Darwin : {} | X86_64_FreeBSD : {} | X86_64_Linux : +{} | X86_64_Solaris : {} >, speedFactor : Natural, supportedFeatures : List +Text, user : Optional Text } xs Text (λ(x : { cores : Natural, host : Text, +key : Text, mandatoryFeatures : List Text, platforms : List < AArch64_Linux : +{} | ARMv5tel_Linux : {} | ARMv7l_Linux : {} | I686_Cygwin : {} | I686_Linux : +{} | MIPS64el_Linux : {} | PowerPC_Linux : {} | X86_64_Cygwin : {} | +X86_64_Darwin : {} | X86_64_FreeBSD : {} | X86_64_Linux : {} | X86_64_Solaris : +{} >, speedFactor : Natural, supportedFeatures : List Text, user : Optional +Text }) → λ(y : Text) → (Optional/fold Text x.user Text (λ(user : Text) +→ user ++ "@" ++ x.host ++ "") x.host ++ " " ++ (merge { Empty = λ(_ : {}) +→ "", NonEmpty = λ(result : Text) → result } (List/fold < AArch64_Linux : +{} | ARMv5tel_Linux : {} | ARMv7l_Linux : {} | I686_Cygwin : {} | I686_Linux : +{} | MIPS64el_Linux : {} | PowerPC_Linux : {} | X86_64_Cygwin : {} | +X86_64_Darwin : {} | X86_64_FreeBSD : {} | X86_64_Linux : {} | X86_64_Solaris : +{} > x.platforms < Empty : {} | NonEmpty : Text > (λ(element : < AArch64_Linux +: {} | ARMv5tel_Linux : {} | ARMv7l_Linux : {} | I686_Cygwin : {} | I686_Linux +: {} | MIPS64el_Linux : {} | PowerPC_Linux : {} | X86_64_Cygwin : {} | +X86_64_Darwin : {} | X86_64_FreeBSD : {} | X86_64_Linux : {} | X86_64_Solaris : +{} >) → λ(status : < Empty : {} | NonEmpty : Text >) → merge { Empty = +λ(_ : {}) → < NonEmpty = merge { AArch64_Linux = λ(_ : {}) → +"aarch64-linux", ARMv5tel_Linux = λ(_ : {}) → "armv5tel-linux", ARMv7l_Linux += λ(_ : {}) → "armv7l-linux", I686_Cygwin = λ(_ : {}) → "i686-cygwin", +I686_Linux = λ(_ : {}) → "i686-linux", MIPS64el_Linux = λ(_ : {}) → +"mips64el-linux", PowerPC_Linux = λ(_ : {}) → "powerpc-linux", X86_64_Cygwin += λ(_ : {}) → "x86_64-cygwin", X86_64_Darwin = λ(_ : {}) → +"x86_64-darwin", X86_64_FreeBSD = λ(_ : {}) → "x86_64-freebsd", X86_64_Linux += λ(_ : {}) → "x86_64-linux", X86_64_Solaris = λ(_ : {}) → +"x86_64-solaris" } element | Empty : {} >, NonEmpty = λ(result : Text) → < +NonEmpty = (merge { AArch64_Linux = λ(_ : {}) → "aarch64-linux", +ARMv5tel_Linux = λ(_ : {}) → "armv5tel-linux", ARMv7l_Linux = λ(_ : {}) → +"armv7l-linux", I686_Cygwin = λ(_ : {}) → "i686-cygwin", I686_Linux = λ(_ : +{}) → "i686-linux", MIPS64el_Linux = λ(_ : {}) → "mips64el-linux", +PowerPC_Linux = λ(_ : {}) → "powerpc-linux", X86_64_Cygwin = λ(_ : {}) → +"x86_64-cygwin", X86_64_Darwin = λ(_ : {}) → "x86_64-darwin", X86_64_FreeBSD += λ(_ : {}) → "x86_64-freebsd", X86_64_Linux = λ(_ : {}) → +"x86_64-linux", X86_64_Solaris = λ(_ : {}) → "x86_64-solaris" } element) ++ +"," ++ result | Empty : {} > } status : < Empty : {} | NonEmpty : Text >) < +Empty = {=} | NonEmpty : Text >) : Text) ++ " " ++ x.key ++ " " ++ Integer/show +(Natural/toInteger x.cores) ++ " " ++ Integer/show (Natural/toInteger +x.speedFactor) ++ " " ++ (merge { Empty = λ(_ : {}) → "", NonEmpty = +λ(result : Text) → result } (List/fold Text x.supportedFeatures < Empty : {} +| NonEmpty : Text > (λ(element : Text) → λ(status : < Empty : {} | NonEmpty +: Text >) → merge { Empty = λ(_ : {}) → < NonEmpty = element | Empty : {} +>, NonEmpty = λ(result : Text) → < NonEmpty = element ++ "," ++ result | +Empty : {} > } status : < Empty : {} | NonEmpty : Text >) < Empty = {=} | +NonEmpty : Text >) : Text) ++ " " ++ (merge { Empty = λ(_ : {}) → "", +NonEmpty = λ(result : Text) → result } (List/fold Text x.mandatoryFeatures < +Empty : {} | NonEmpty : Text > (λ(element : Text) → λ(status : < Empty : {} +| NonEmpty : Text >) → merge { Empty = λ(_ : {}) → < NonEmpty = element | +Empty : {} >, NonEmpty = λ(result : Text) → < NonEmpty = element ++ "," ++ +result | Empty : {} > } status : < Empty : {} | NonEmpty : Text >) < Empty = +{=} | NonEmpty : Text >) : Text) ++ "\n") ++ y) "" diff --git a/benchmark/parser/Main.hs b/benchmark/parser/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/parser/Main.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Monad (forM) +import Criterion.Main (defaultMain, bgroup, bench, whnf, nfIO) +import Data.Map (Map, foldrWithKey, singleton, unions) + +import System.Directory + +import qualified Criterion.Main as Criterion +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified Dhall.Parser as Dhall + +type PreludeFiles = Map FilePath T.Text + +loadPreludeFiles :: IO PreludeFiles +loadPreludeFiles = loadDirectory "Prelude" + where + loadDirectory :: FilePath -> IO PreludeFiles + loadDirectory dir = + withCurrentDirectory dir $ do + files <- getCurrentDirectory >>= listDirectory + results <- forM files $ \file -> do + file' <- makeAbsolute file + doesExist <- doesFileExist file' + if doesExist + then loadFile file' + else loadDirectory file' + pure $ unions results + + loadFile :: FilePath -> IO PreludeFiles + loadFile path = singleton path <$> TIO.readFile path + +benchParser :: PreludeFiles -> Criterion.Benchmark +benchParser = + bgroup "exprFromText" + . foldrWithKey (\name expr -> (benchExprFromText name expr :)) [] + +benchExprFromText :: String -> T.Text -> Criterion.Benchmark +benchExprFromText name expr = + bench name $ whnf (Dhall.exprFromText "(input)") expr + +main :: IO () +main = do + prelude <- loadPreludeFiles + issue108 <- TIO.readFile "benchmark/examples/issue108.dhall" + defaultMain + [ benchParser prelude + , bgroup "Issue #108" $ + [ benchExprFromText "108" issue108 ] + ] diff --git a/dhall-format/Main.hs b/dhall-format/Main.hs deleted file mode 100644 --- a/dhall-format/Main.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -{-| Utility executable for pretty-printing Dhall code - - You typically want to use this to either: - - * improve the readability of Dhall code (either written or generated) - * automatically format your Dhall code to avoid stylistic debates - - Note that this does not yet support: - - * Preserving all comments - * Currently, this only preserves all leading comments and whitespace - up until the last newline preceding the code - * This lets you preserve a comment header but if you want to document - subexpressions then you will need to split them into a separate - file for now - * Preserving multi-line strings (this reduces them to ordinary strings) - - See the @Dhall.Tutorial@ module for example usage --} -module Main where - -import Control.Applicative (optional) -import Control.Exception (SomeException) -import Control.Monad (when) -import Data.Monoid ((<>)) -import Data.Version (showVersion) -import Dhall.Parser (exprAndHeaderFromText) -import Dhall.Pretty (annToAnsiStyle, prettyExpr) -import Options.Applicative (Parser, ParserInfo) -import System.IO (stderr) -import System.Exit (exitFailure, exitSuccess) - -import qualified Paths_dhall as Meta - -import qualified Control.Exception -import qualified Data.Text.IO -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.IO -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty -import qualified Options.Applicative -import qualified System.Console.ANSI -import qualified System.IO - -data Options = Options - { version :: Bool - , inplace :: Maybe FilePath - } - -parseOptions :: Parser Options -parseOptions = Options <$> parseVersion <*> optional parseInplace - where - parseVersion = - Options.Applicative.switch - ( Options.Applicative.long "version" - <> Options.Applicative.help "Display version and exit" - ) - - parseInplace = - Options.Applicative.strOption - ( Options.Applicative.long "inplace" - <> Options.Applicative.help "Modify the specified file in-place" - <> Options.Applicative.metavar "FILE" - ) - -opts :: Pretty.LayoutOptions -opts = - Pretty.defaultLayoutOptions - { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 } - -parserInfo :: ParserInfo Options -parserInfo = - Options.Applicative.info - (Options.Applicative.helper <*> parseOptions) - ( Options.Applicative.progDesc "Formatter for the Dhall language" - <> Options.Applicative.fullDesc - ) - -main :: IO () -main = do - Options {..} <- Options.Applicative.execParser parserInfo - - when version $ do - putStrLn (showVersion Meta.version) - exitSuccess - - let handler e = do - let _ = e :: SomeException - System.IO.hSetEncoding System.IO.stderr System.IO.utf8 - System.IO.hPrint stderr e - System.Exit.exitFailure - - Control.Exception.handle handler (do - case inplace of - Just file -> do - strictText <- Data.Text.IO.readFile file - let lazyText = Data.Text.Lazy.fromStrict strictText - (header, expr) <- case exprAndHeaderFromText "(stdin)" lazyText of - Left err -> Control.Exception.throwIO err - Right x -> return x - - let doc = Pretty.pretty header <> Pretty.pretty expr - System.IO.withFile file System.IO.WriteMode (\handle -> do - Pretty.renderIO handle (Pretty.layoutSmart opts doc) - Data.Text.IO.hPutStrLn handle "" ) - Nothing -> do - System.IO.hSetEncoding System.IO.stdin System.IO.utf8 - inText <- Data.Text.Lazy.IO.getContents - - (header, expr) <- case exprAndHeaderFromText "(stdin)" inText of - Left err -> Control.Exception.throwIO err - Right x -> return x - - let doc = Pretty.pretty header <> prettyExpr expr - - supportsANSI <- System.Console.ANSI.hSupportsANSI System.IO.stdout - - if supportsANSI - then - Pretty.renderIO - System.IO.stdout - (fmap annToAnsiStyle (Pretty.layoutSmart opts doc)) - else - Pretty.renderIO - System.IO.stdout - (Pretty.layoutSmart opts (Pretty.unAnnotate doc)) - Data.Text.IO.putStrLn "") diff --git a/dhall-hash/Main.hs b/dhall-hash/Main.hs deleted file mode 100644 --- a/dhall-hash/Main.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Main where - -import Control.Exception (SomeException) -import Control.Monad (when) -import Data.Monoid ((<>)) -import Data.Version (showVersion) -import Dhall.Core (normalize) -import Dhall.Import (Imported(..), hashExpressionToCode, load) -import Dhall.Parser (Src, exprFromText) -import Dhall.TypeCheck (DetailedTypeError(..), TypeError, X) -import Options.Applicative (Parser, ParserInfo) -import System.IO (stderr) -import System.Exit (exitFailure, exitSuccess) - -import qualified Paths_dhall as Meta - -import qualified Control.Exception -import qualified Data.Text.Lazy.IO -import qualified Dhall.TypeCheck -import qualified Options.Applicative -import qualified System.IO - -data Options = Options - { explain :: Bool - , version :: Bool - } - -parseOptions :: Parser Options -parseOptions = Options <$> parseExplain <*> parseVersion - where - parseExplain = - Options.Applicative.switch - ( Options.Applicative.long "explain" - <> Options.Applicative.help "Explain error messages in more detail" - ) - - parseVersion = - Options.Applicative.switch - ( Options.Applicative.long "version" - <> Options.Applicative.help "Display version and exit" - ) - -parserInfo :: ParserInfo Options -parserInfo = - Options.Applicative.info - (Options.Applicative.helper <*> parseOptions) - ( Options.Applicative.progDesc "Compute semantic hashes for Dhall expressions" - <> Options.Applicative.fullDesc - ) - -main :: IO () -main = do - Options {..} <- Options.Applicative.execParser parserInfo - - when version $ do - putStrLn (showVersion Meta.version) - exitSuccess - let handle = - Control.Exception.handle handler2 - . Control.Exception.handle handler1 - . Control.Exception.handle handler0 - where - handler0 e = do - let _ = e :: TypeError Src X - System.IO.hPutStrLn stderr "" - if explain - then Control.Exception.throwIO (DetailedTypeError e) - else do - Data.Text.Lazy.IO.hPutStrLn stderr "\ESC[2mUse \"dhall --explain\" for detailed errors\ESC[0m" - Control.Exception.throwIO e - - handler1 (Imported ps e) = do - let _ = e :: TypeError Src X - System.IO.hPutStrLn stderr "" - if explain - then Control.Exception.throwIO (Imported ps (DetailedTypeError e)) - else do - Data.Text.Lazy.IO.hPutStrLn stderr "\ESC[2mUse \"dhall --explain\" for detailed errors\ESC[0m" - Control.Exception.throwIO (Imported ps e) - - handler2 e = do - let _ = e :: SomeException - System.IO.hSetEncoding System.IO.stderr System.IO.utf8 - System.IO.hPrint stderr e - System.Exit.exitFailure - - handle (do - System.IO.hSetEncoding System.IO.stdin System.IO.utf8 - inText <- Data.Text.Lazy.IO.getContents - - expr <- case exprFromText "(stdin)" inText of - Left err -> Control.Exception.throwIO err - Right expr -> return expr - - expr' <- load expr - - _ <- case Dhall.TypeCheck.typeOf expr' of - Left err -> Control.Exception.throwIO err - Right _ -> return () - - Data.Text.Lazy.IO.putStrLn (hashExpressionToCode (normalize expr')) ) diff --git a/dhall-repl/Main.hs b/dhall-repl/Main.hs deleted file mode 100644 --- a/dhall-repl/Main.hs +++ /dev/null @@ -1,251 +0,0 @@ -{-# language FlexibleContexts #-} -{-# language NamedFieldPuns #-} -{-# language OverloadedStrings #-} - -module Main ( main ) where - -import Control.Exception ( SomeException(SomeException), displayException, throwIO ) -import Control.Monad.IO.Class ( MonadIO, liftIO ) -import Control.Monad.State.Class ( MonadState, get, modify ) -import Control.Monad.State.Strict ( evalStateT ) -import Data.List ( foldl' ) - -import qualified Data.Text.Lazy as LazyText -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty ( renderIO ) -import qualified Dhall.Context -import qualified Dhall.Core as Dhall ( Var(V), Expr, normalize ) -import qualified Dhall.Pretty -import qualified Dhall.Core as Expr ( Expr(..) ) -import qualified Dhall.Import as Dhall -import qualified Dhall.Parser as Dhall -import qualified Dhall.TypeCheck as Dhall -import qualified System.Console.ANSI -import qualified System.Console.Haskeline.MonadException as Haskeline -import qualified System.Console.Repline as Repline -import qualified System.IO - - -main :: IO () -main = - evalStateT - ( Repline.evalRepl - "⊢ " - ( dontCrash . eval ) - options - ( Repline.Word completer ) - greeter - ) - emptyEnv - - -data Env = Env - { envBindings :: Dhall.Context.Context Binding - , envIt :: Maybe Binding - } - - -emptyEnv :: Env -emptyEnv = - Env - { envBindings = Dhall.Context.empty - , envIt = Nothing - } - - -data Binding = Binding - { bindingExpr :: Dhall.Expr Dhall.Src Dhall.X - , bindingType :: Dhall.Expr Dhall.Src Dhall.X - } - - -envToContext :: Env -> Dhall.Context.Context Binding -envToContext Env{ envBindings, envIt } = - case envIt of - Nothing -> - envBindings - - Just it -> - Dhall.Context.insert "it" it envBindings - - -parseAndLoad - :: ( MonadIO m, MonadState Env m ) - => String -> m ( Dhall.Expr Dhall.Src Dhall.X ) -parseAndLoad src = do - parsed <- - case Dhall.exprFromText "(stdin)" ( LazyText.pack src ) of - Left e -> - liftIO ( throwIO e ) - - Right a -> - return a - - liftIO ( Dhall.load parsed ) - - -eval :: ( MonadIO m, MonadState Env m ) => String -> m () -eval src = do - loaded <- - parseAndLoad src - - exprType <- - typeCheck loaded - - expr <- - normalize loaded - - modify ( \e -> e { envIt = Just ( Binding expr exprType ) } ) - - output System.IO.stdout expr - - - -typeOf :: ( MonadIO m, MonadState Env m ) => [String] -> m () -typeOf [] = - liftIO ( putStrLn ":type requires an argument to check the type of" ) - - -typeOf srcs = do - loaded <- - parseAndLoad ( unwords srcs ) - - exprType <- - typeCheck loaded - - exprType' <- - normalize exprType - - output System.IO.stdout exprType' - - - -normalize - :: MonadState Env m - => Dhall.Expr Dhall.Src Dhall.X -> m ( Dhall.Expr t Dhall.X ) -normalize e = do - env <- - get - - return - ( Dhall.normalize - ( foldl' - ( \a (k, Binding { bindingType, bindingExpr }) -> - Expr.Let k ( Just bindingType ) bindingExpr a - ) - e - ( Dhall.Context.toList ( envToContext env ) ) - ) - ) - - -typeCheck - :: ( MonadIO m, MonadState Env m ) - => Dhall.Expr Dhall.Src Dhall.X -> m ( Dhall.Expr Dhall.Src Dhall.X ) -typeCheck expr = do - env <- - get - - case Dhall.typeWith ( bindingType <$> envToContext env ) expr of - Left e -> - liftIO ( throwIO e ) - - Right a -> - return a - - -addBinding :: ( MonadIO m, MonadState Env m ) => [String] -> m () -addBinding (k : "=" : srcs) = do - let - varName = - LazyText.pack k - - loaded <- - parseAndLoad ( unwords srcs ) - - t <- - typeCheck loaded - - expr <- - normalize loaded - - modify - ( \e -> - e - { envBindings = - Dhall.Context.insert - varName - Binding { bindingType = t, bindingExpr = expr } - ( envBindings e ) - } - ) - - output - System.IO.stdout - ( Expr.Annot ( Expr.Var ( Dhall.V varName 0 ) ) t ) - -addBinding _ = - liftIO ( fail ":let should be of the form `:let x = y`" ) - -saveBinding :: ( MonadIO m, MonadState Env m ) => [String] -> m () -saveBinding (file : "=" : tokens) = do - loadedExpression <- parseAndLoad (unwords tokens) - - _ <- typeCheck loadedExpression - - normalizedExpression <- normalize loadedExpression - - let handler handle = output handle normalizedExpression - - liftIO (System.IO.withFile file System.IO.WriteMode handler) -saveBinding _ = fail ":save should be of the form `:save x = y`" - - -options - :: ( Haskeline.MonadException m, MonadIO m, MonadState Env m ) - => Repline.Options m -options = - [ ( "type", dontCrash . typeOf ) - , ( "let", dontCrash . addBinding ) - , ( "save", dontCrash . saveBinding ) - ] - - -completer :: Monad m => Repline.WordCompleter m -completer _ = - return [] - - -greeter :: MonadIO m => m () -greeter = - return () - - -dontCrash :: ( MonadIO m, Haskeline.MonadException m ) => m () -> m () -dontCrash m = - Haskeline.catch - m - ( \ e@SomeException{} -> liftIO ( putStrLn ( displayException e ) ) ) - - -output - :: (Pretty.Pretty a, MonadIO m) - => System.IO.Handle -> Dhall.Expr s a -> m () -output handle expr = do - liftIO (System.IO.hPutStrLn handle "") -- Visual spacing - - let opts = - Pretty.defaultLayoutOptions - { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 } - - let stream = Pretty.layoutSmart opts (Dhall.Pretty.prettyExpr expr) - supportsANSI <- liftIO (System.Console.ANSI.hSupportsANSI handle) - let ansiStream = - if supportsANSI - then fmap Dhall.Pretty.annToAnsiStyle stream - else Pretty.unAnnotateS stream - - liftIO (Pretty.renderIO handle ansiStream) - liftIO (System.IO.hPutStrLn handle "") -- Pretty printing doesn't end with a new line - - liftIO (System.IO.hPutStrLn handle "") -- Visual spacing diff --git a/dhall.cabal b/dhall.cabal --- a/dhall.cabal +++ b/dhall.cabal @@ -1,6 +1,6 @@ Name: dhall -Version: 1.14.0 -Cabal-Version: >=1.8.0.2 +Version: 1.15.0 +Cabal-Version: >=1.10 Build-Type: Simple Tested-With: GHC == 8.0.1 License: BSD3 @@ -34,6 +34,7 @@ Prelude/Bool/show Prelude/Double/show Prelude/Integer/show + Prelude/Integer/toDouble Prelude/List/all Prelude/List/any Prelude/List/build @@ -63,6 +64,7 @@ Prelude/Natural/product Prelude/Natural/show Prelude/Natural/sum + Prelude/Natural/toDouble Prelude/Natural/toInteger Prelude/Optional/all Prelude/Optional/any @@ -95,6 +97,7 @@ tests/normalization/examples/Bool/show/*.dhall tests/normalization/examples/Double/show/*.dhall tests/normalization/examples/Integer/show/*.dhall + tests/normalization/examples/Integer/toDouble/*.dhall tests/normalization/examples/List/all/*.dhall tests/normalization/examples/List/any/*.dhall tests/normalization/examples/List/build/*.dhall @@ -123,6 +126,7 @@ tests/normalization/examples/Natural/product/*.dhall tests/normalization/examples/Natural/show/*.dhall tests/normalization/examples/Natural/sum/*.dhall + tests/normalization/examples/Natural/toDouble/*.dhall tests/normalization/examples/Natural/toInteger/*.dhall tests/normalization/examples/Optional/all/*.dhall tests/normalization/examples/Optional/any/*.dhall @@ -143,15 +147,24 @@ tests/normalization/examples/Text/concatSep/*.dhall tests/normalization/simplifications/*.dhall tests/parser/*.dhall + tests/parser/failure/*.dhall tests/regression/*.dhall tests/tutorial/*.dhall tests/typecheck/*.dhall tests/typecheck/examples/Monoid/*.dhall + tests/import/*.dhall + benchmark/examples/*.dhall + benchmark/deep-nested-large-record/*.dhall Source-Repository head Type: git Location: https://github.com/dhall-lang/dhall-haskell +Flag with-http + Description: Include support for importing dhall modules from HTTP URLs + Default: True + Manual: True + Library Hs-Source-Dirs: src Build-Depends: @@ -162,101 +175,72 @@ containers >= 0.5.0.0 && < 0.6 , contravariant < 1.5 , cryptonite >= 0.23 && < 1.0 , - exceptions >= 0.8.3 && < 0.11, + Diff >= 0.2 && < 0.4 , directory >= 1.3 && < 1.4 , + exceptions >= 0.8.3 && < 0.11, filepath >= 1.4 && < 1.5 , - formatting >= 6.3 && < 6.4 , - http-client >= 0.4.30 && < 0.6 , - http-client-tls >= 0.2.0 && < 0.4 , + haskeline >= 0.7.3.0 && < 0.8 , insert-ordered-containers >= 0.2.1.0 && < 0.3 , lens-family-core >= 1.0.0 && < 1.3 , megaparsec >= 6.1.1 && < 6.6 , memory >= 0.14 && < 0.15, + mtl >= 2.2.1 && < 2.3 , + optparse-applicative < 0.15, parsers >= 0.12.4 && < 0.13, prettyprinter >= 1.2.0.1 && < 1.3 , prettyprinter-ansi-terminal >= 1.1.1 && < 1.2 , + repline >= 0.1.6.0 && < 0.2 , scientific >= 0.3.0.0 && < 0.4 , + template-haskell < 2.14, text >= 0.11.1.0 && < 1.3 , transformers >= 0.2.0.0 && < 0.6 , unordered-containers >= 0.1.3.0 && < 0.3 , vector >= 0.11.0.0 && < 0.13 + if flag(with-http) + Build-Depends: + http-client >= 0.4.30 && < 0.6 , + http-client-tls >= 0.2.0 && < 0.4 if !impl(ghc >= 8.0) Build-Depends: semigroups == 0.18.* + Build-Depends: transformers == 0.4.2.* Exposed-Modules: Dhall, Dhall.Context, Dhall.Core, - Dhall.Diff + Dhall.Diff, + Dhall.Format, + Dhall.Freeze, + Dhall.Hash, Dhall.Import, + Dhall.Lint, + Dhall.Main Dhall.Parser, Dhall.Pretty, + Dhall.Repl + Dhall.TH, Dhall.Tutorial, Dhall.TypeCheck Other-Modules: - Dhall.Pretty.Internal - GHC-Options: -Wall - -Executable dhall - Hs-Source-Dirs: dhall - Main-Is: Main.hs - Build-Depends: - ansi-terminal , - base >= 4 && < 5 , - dhall , - optparse-applicative < 0.15, - prettyprinter , - prettyprinter-ansi-terminal >= 1.1.1 && < 1.2 , - megaparsec , - text >= 0.11.1.0 && < 1.3 - GHC-Options: -Wall - Other-Modules: + Dhall.Pretty.Internal, + Dhall.Parser.Expression, + Dhall.Parser.Combinators, + Dhall.Parser.Token, + Dhall.Import.Types, Paths_dhall + if flag(with-http) + Other-Modules: + Dhall.Import.HTTP -Executable dhall-repl - Hs-Source-Dirs: dhall-repl - Main-Is: Main.hs - Build-Depends: - base >= 4 && < 5 , - ansi-terminal , - dhall , - haskeline >= 0.7.3.0 && < 0.8 , - mtl >= 2.2.1 && < 2.3 , - repline >= 0.1.6.0 && < 0.2 , - prettyprinter , - prettyprinter-ansi-terminal , - text - if !impl(ghc >= 8.0) - Build-Depends: transformers == 0.4.2.* GHC-Options: -Wall + Default-Language: Haskell2010 -Executable dhall-format - Hs-Source-Dirs: dhall-format +Executable dhall + Hs-Source-Dirs: dhall Main-Is: Main.hs - Build-Depends: - base >= 4 && < 5 , - ansi-terminal , - dhall , - megaparsec , - optparse-applicative < 0.15, - prettyprinter >= 1.2.0.1 && < 1.3 , - prettyprinter-ansi-terminal >= 1.1.1 && < 1.2 , - text >= 0.11.1.0 && < 1.3 + Build-Depends: base, dhall GHC-Options: -Wall - Other-Modules: - Paths_dhall - -Executable dhall-hash - Hs-Source-Dirs: dhall-hash - Main-Is: Main.hs - Build-Depends: - base >= 4 && < 5 , - dhall , - optparse-applicative < 0.15, - megaparsec , - text >= 0.11.1.0 && < 1.3 - Other-Modules: - Paths_dhall + Default-Language: Haskell2010 Test-Suite tasty Type: exitcode-stdio-1.0 @@ -265,6 +249,7 @@ GHC-Options: -Wall Other-Modules: Format + Import Normalization Parser Regression @@ -281,6 +266,7 @@ tasty-hunit >= 0.9.2 && < 0.11, text >= 0.11.1.0 && < 1.3 , vector >= 0.11.0.0 && < 0.13 + Default-Language: Haskell2010 Test-Suite doctest Type: exitcode-stdio-1.0 @@ -289,4 +275,28 @@ GHC-Options: -Wall Build-Depends: base , + Diff >= 0.2 && < 0.4 , doctest >= 0.7.0 && < 0.16 + Default-Language: Haskell2010 + +Benchmark dhall-parser + Type: exitcode-stdio-1.0 + Main-Is: benchmark/parser/Main.hs + Build-Depends: + base >= 4 && < 5 , + containers >= 0.5.0.0 && < 0.6, + criterion >= 1.1 && < 1.5, + dhall , + directory >= 1.3 && < 1.4, + text >= 0.11.1.0 && < 1.3 + Default-Language: Haskell2010 + +Benchmark deep-nested-large-record + Type: exitcode-stdio-1.0 + Main-Is: benchmark/deep-nested-large-record/Main.hs + Build-Depends: + base >= 4 && < 5 , + containers >= 0.5.0.0 && < 0.6, + criterion >= 1.1 && < 1.5, + dhall + Default-Language: Haskell2010 diff --git a/dhall/Main.hs b/dhall/Main.hs --- a/dhall/Main.hs +++ b/dhall/Main.hs @@ -1,206 +1,6 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - module Main where -import Control.Applicative ((<|>)) -import Control.Exception (Exception, SomeException) -import Data.Monoid (mempty, (<>)) -import Data.Text.Prettyprint.Doc (Pretty) -import Data.Typeable (Typeable) -import Data.Version (showVersion) -import Dhall.Core (Expr, Import) -import Dhall.Import (Imported(..), load) -import Dhall.Parser (Src) -import Dhall.Pretty (annToAnsiStyle, prettyExpr) -import Dhall.TypeCheck (DetailedTypeError(..), TypeError, X) -import Options.Applicative (Parser) -import System.Exit (exitFailure) -import System.IO (Handle) - -import qualified Paths_dhall as Meta - -import qualified Control.Exception -import qualified Data.Text.Lazy.IO -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty -import qualified Dhall.Core -import qualified Dhall.Parser -import qualified Dhall.TypeCheck -import qualified Options.Applicative -import qualified System.Console.ANSI -import qualified System.IO - -data Options = Options - { mode :: Mode - , explain :: Bool - , plain :: Bool - } - -data Mode = Default | Version | Resolve | Type | Normalize - -parseOptions :: Parser Options -parseOptions = Options <$> parseMode <*> parseExplain <*> parsePlain - where - parseExplain = - Options.Applicative.switch - ( Options.Applicative.long "explain" - <> Options.Applicative.help "Explain error messages in more detail" - ) - - parsePlain = - Options.Applicative.switch - ( Options.Applicative.long "plain" - <> Options.Applicative.help "Disable syntax highlighting" - ) - -parseMode :: Parser Mode -parseMode = - subcommand "version" "Display version" Version - <|> subcommand "resolve" "Resolve an expression's imports" Resolve - <|> subcommand "type" "Infer an expression's type" Type - <|> subcommand "normalize" "Normalize an expression" Normalize - <|> pure Default - where - subcommand name description mode = - Options.Applicative.subparser - ( Options.Applicative.command name parserInfo - <> Options.Applicative.metavar name - ) - where - parserInfo = - Options.Applicative.info parser - ( Options.Applicative.fullDesc - <> Options.Applicative.progDesc description - ) - - parser = - Options.Applicative.helper <*> pure mode - -opts :: Pretty.LayoutOptions -opts = - Pretty.defaultLayoutOptions - { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 } - -data ImportResolutionDisabled = - ImportResolutionDisabled deriving (Exception, Typeable) - -instance Show ImportResolutionDisabled where - show _ = "\nImport resolution is disabled" - -throws :: Exception e => Either e a -> IO a -throws (Left e) = Control.Exception.throwIO e -throws (Right a) = return a - -getExpression :: IO (Expr Src Import) -getExpression = do - inText <- Data.Text.Lazy.IO.getContents - - throws (Dhall.Parser.exprFromText "(stdin)" inText) - -assertNoImports :: Expr Src Import -> IO (Expr Src X) -assertNoImports expression = - throws (traverse (\_ -> Left ImportResolutionDisabled) expression) +import qualified Dhall.Main main :: IO () -main = do - let parserInfo = - Options.Applicative.info - (Options.Applicative.helper <*> parseOptions) - ( Options.Applicative.progDesc "Interpreter for the Dhall language" - <> Options.Applicative.fullDesc - ) - - Options {..} <- Options.Applicative.execParser parserInfo - - System.IO.hSetEncoding System.IO.stdin System.IO.utf8 - - let handle = - Control.Exception.handle handler2 - . Control.Exception.handle handler1 - . Control.Exception.handle handler0 - where - handler0 e = do - let _ = e :: TypeError Src X - System.IO.hPutStrLn System.IO.stderr "" - if explain - then Control.Exception.throwIO (DetailedTypeError e) - else do - Data.Text.Lazy.IO.hPutStrLn System.IO.stderr "\ESC[2mUse \"dhall --explain\" for detailed errors\ESC[0m" - Control.Exception.throwIO e - - handler1 (Imported ps e) = do - let _ = e :: TypeError Src X - System.IO.hPutStrLn System.IO.stderr "" - if explain - then Control.Exception.throwIO (Imported ps (DetailedTypeError e)) - else do - Data.Text.Lazy.IO.hPutStrLn System.IO.stderr "\ESC[2mUse \"dhall --explain\" for detailed errors\ESC[0m" - Control.Exception.throwIO (Imported ps e) - - handler2 e = do - let _ = e :: SomeException - System.IO.hSetEncoding System.IO.stderr System.IO.utf8 - System.IO.hPrint System.IO.stderr e - System.Exit.exitFailure - - let render :: Pretty a => Handle -> Expr s a -> IO () - render h e = do - let doc = prettyExpr e - - let layoutOptions = opts - - let stream = Pretty.layoutSmart layoutOptions 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.Lazy.IO.hPutStrLn h "" - - handle $ case mode of - Version -> do - putStrLn (showVersion Meta.version) - - Default -> do - expression <- getExpression - - resolvedExpression <- load expression - - inferredType <- throws (Dhall.TypeCheck.typeOf resolvedExpression) - - render System.IO.stderr (Dhall.Core.normalize inferredType) - - Data.Text.Lazy.IO.hPutStrLn System.IO.stderr mempty - - render System.IO.stdout (Dhall.Core.normalize resolvedExpression) - - Resolve -> do - expression <- getExpression - - resolvedExpression <- load expression - - render System.IO.stdout resolvedExpression - - Normalize -> do - expression <- getExpression - - resolvedExpression <- assertNoImports expression - - _ <- throws (Dhall.TypeCheck.typeOf resolvedExpression) - - render System.IO.stdout (Dhall.Core.normalize resolvedExpression) - - Type -> do - expression <- getExpression - - resolvedExpression <- assertNoImports expression - - inferredType <- throws (Dhall.TypeCheck.typeOf resolvedExpression) - - render System.IO.stdout (Dhall.Core.normalize inferredType) +main = Dhall.Main.main diff --git a/doctest/Main.hs b/doctest/Main.hs --- a/doctest/Main.hs +++ b/doctest/Main.hs @@ -3,4 +3,4 @@ import qualified Test.DocTest main :: IO () -main = Test.DocTest.doctest [ "-isrc", "src/Dhall.hs" ] +main = Test.DocTest.doctest [ "-isrc", "src/Dhall.hs", "src/Dhall/Import.hs" ] diff --git a/src/Dhall.hs b/src/Dhall.hs --- a/src/Dhall.hs +++ b/src/Dhall.hs @@ -19,7 +19,11 @@ ( -- * Input input + , inputFrom , inputWith + , inputFromWith + , inputExpr + , inputExprWith , detailed -- * Types @@ -72,7 +76,7 @@ import Data.Monoid ((<>)) import Data.Scientific (Scientific) import Data.Sequence (Seq) -import Data.Text.Lazy (Text) +import Data.Text (Text) import Data.Typeable (Typeable) import Data.Vector (Vector) import Data.Word (Word8, Word16, Word32, Word64) @@ -80,7 +84,6 @@ import Dhall.Import (Imported(..)) import Dhall.Parser (Src(..)) import Dhall.TypeCheck (DetailedTypeError(..), TypeError, X) -import Formatting.Buildable (Buildable(..)) import GHC.Generics import Numeric.Natural (Natural) import Prelude hiding (maybe, sequence) @@ -96,12 +99,12 @@ import qualified Data.Set import qualified Data.Text import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Builder import qualified Data.Vector import qualified Dhall.Context import qualified Dhall.Core import qualified Dhall.Import import qualified Dhall.Parser +import qualified Dhall.Pretty.Internal import qualified Dhall.TypeCheck -- $setup @@ -154,9 +157,21 @@ -- ^ The Dhall program -> IO a -- ^ The decoded value in Haskell -input ty txt = - inputWith ty Dhall.Context.empty (const Nothing) txt +input = + inputFrom "(input)" +inputFrom + :: FilePath + -- ^ The source file to report locations from; only used in error messages + -> Type a + -- ^ The type of value to decode from Dhall to Haskell + -> Text + -- ^ The Dhall program + -> IO a + -- ^ The decoded value in Haskell +inputFrom filename ty txt = + inputFromWith filename ty Dhall.Context.empty (const Nothing) txt + {-| Extend 'input' with a custom typing context and normalization process. -} @@ -170,13 +185,28 @@ -- ^ The Dhall program -> IO a -- ^ The decoded value in Haskell -inputWith (Type {..}) ctx n txt = do - expr <- throws (Dhall.Parser.exprFromText "(input)" txt) +inputWith = + inputFromWith "(input)" + +{-| Extend 'inputFrom' with a custom typing context and normalization process. + +-} +inputFromWith + :: FilePath + -- ^ The source file to report locations from; only used in error messages + -> Type a + -- ^ The type of value to decode from Dhall to Haskell + -> Dhall.Context.Context (Expr Src X) + -- ^ The starting context for type-checking + -> Dhall.Core.Normalizer X + -> Text + -- ^ The Dhall program + -> IO a + -- ^ The decoded value in Haskell +inputFromWith filename (Type {..}) ctx n txt = do + expr <- throws (Dhall.Parser.exprFromText filename txt) expr' <- Dhall.Import.loadWithContext ctx n expr - let suffix = - ( Data.Text.Lazy.Builder.toLazyText - . build - ) expected + let suffix = Dhall.Pretty.Internal.prettyToStrictText expected let annot = case expr' of Note (Src begin end bytes) _ -> Note (Src begin end bytes') (Annot expr' expected) @@ -189,6 +219,32 @@ Just x -> return x Nothing -> Control.Exception.throwIO InvalidType +{-| Similar to `input`, but without interpreting the Dhall `Expr` into a Haskell + type. +-} +inputExpr + :: Text + -- ^ The Dhall program + -> IO (Expr Src X) + -- ^ The fully normalized AST +inputExpr = inputExprWith Dhall.Context.empty (const Nothing) + +{-| Extend `inputExpr` with a custom typing context and normalization process. +-} +inputExprWith + :: Dhall.Context.Context (Expr Src X) + -- ^ The starting context for type-checking + -> Dhall.Core.Normalizer X + -> Text + -- ^ The Dhall program + -> IO (Expr Src X) + -- ^ The fully normalized AST +inputExprWith ctx n txt = do + expr <- throws (Dhall.Parser.exprFromText "(input)" txt) + expr' <- Dhall.Import.loadWithContext ctx n expr + _ <- throws (Dhall.TypeCheck.typeWith ctx expr') + pure (Dhall.Core.normalizeWith n expr') + -- | Use this function to extract Haskell values directly from Dhall AST. -- The intended use case is to allow easy extraction of Dhall values for -- making the function `Dhall.Core.normalizeWith` easier to use. @@ -415,10 +471,10 @@ >>> input lazyText "\"Test\"" "Test" -} -lazyText :: Type Text +lazyText :: Type Data.Text.Lazy.Text lazyText = Type {..} where - extract (TextLit (Chunks [] t)) = pure (Data.Text.Lazy.Builder.toLazyText t) + extract (TextLit (Chunks [] t)) = pure (Data.Text.Lazy.fromStrict t) extract _ = empty expected = Text @@ -428,7 +484,7 @@ >>> input strictText "\"Test\"" "Test" -} -strictText :: Type Data.Text.Text +strictText :: Type Text strictText = fmap Data.Text.Lazy.toStrict lazyText {-| Decode a `Maybe` @@ -551,10 +607,10 @@ instance {-# OVERLAPS #-} Interpret [Char] where autoWith _ = string -instance Interpret Text where +instance Interpret Data.Text.Lazy.Text where autoWith _ = lazyText -instance Interpret Data.Text.Text where +instance Interpret Text where autoWith _ = strictText instance Interpret a => Interpret (Maybe a) where @@ -649,8 +705,8 @@ nR :: M1 i c2 f2 a nR = undefined - nameL = constructorModifier (Data.Text.Lazy.pack (conName nL)) - nameR = constructorModifier (Data.Text.Lazy.pack (conName nR)) + nameL = constructorModifier (Data.Text.pack (conName nL)) + nameR = constructorModifier (Data.Text.pack (conName nR)) extract (UnionLit name e _) | name == nameL = fmap (L1 . M1) (extractL e) @@ -670,7 +726,7 @@ n :: M1 i c h a n = undefined - name = constructorModifier (Data.Text.Lazy.pack (conName n)) + name = constructorModifier (Data.Text.pack (conName n)) extract u@(UnionLit name' e _) | name == name' = fmap (R1 . M1) (extractR e) @@ -689,7 +745,7 @@ n :: M1 i c f a n = undefined - name = constructorModifier (Data.Text.Lazy.pack (conName n)) + name = constructorModifier (Data.Text.pack (conName n)) extract u@(UnionLit name' e _) | name == name' = fmap (L1 . M1) (extractL e) @@ -748,14 +804,14 @@ genericAutoWith opts@(InterpretOptions {..}) = do name <- getSelName n let extract (RecordLit m) = do - let name' = fieldModifier (Data.Text.Lazy.pack name) + let name' = fieldModifier (Data.Text.pack name) e <- Data.HashMap.Strict.InsOrd.lookup name' m fmap (M1 . K1) (extract' e) extract _ = Nothing let expected = Record (Data.HashMap.Strict.InsOrd.fromList [(key, expected')]) where - key = fieldModifier (Data.Text.Lazy.pack name) + key = fieldModifier (Data.Text.pack name) pure (Type {..}) where n :: M1 i s f a @@ -813,18 +869,18 @@ declared = Bool -instance Inject Text where +instance Inject Data.Text.Lazy.Text where injectWith _ = InputType {..} where embed text = - TextLit (Chunks [] (Data.Text.Lazy.Builder.fromLazyText text)) + TextLit (Chunks [] (Data.Text.Lazy.toStrict text)) declared = Text -instance Inject Data.Text.Text where +instance Inject Text where injectWith _ = InputType {..} where - embed text = TextLit (Chunks [] (Data.Text.Lazy.Builder.fromText text)) + embed text = TextLit (Chunks [] text) declared = Text @@ -961,8 +1017,8 @@ nR :: M1 i c2 f2 a nR = undefined - keyL = constructorModifier (Data.Text.Lazy.pack (conName nL)) - keyR = constructorModifier (Data.Text.Lazy.pack (conName nR)) + keyL = constructorModifier (Data.Text.pack (conName nL)) + keyR = constructorModifier (Data.Text.pack (conName nR)) InputType embedL declaredL = evalState (genericInjectWith options) 1 InputType embedR declaredR = evalState (genericInjectWith options) 1 @@ -979,7 +1035,7 @@ nR :: M1 i c h a nR = undefined - keyR = constructorModifier (Data.Text.Lazy.pack (conName nR)) + keyR = constructorModifier (Data.Text.pack (conName nR)) declared = Union (Data.HashMap.Strict.InsOrd.insert keyR declaredR ktsL) @@ -998,7 +1054,7 @@ nL :: M1 i c f a nL = undefined - keyL = constructorModifier (Data.Text.Lazy.pack (conName nL)) + keyL = constructorModifier (Data.Text.pack (conName nL)) declared = Union (Data.HashMap.Strict.InsOrd.insert keyL declaredL ktsR) @@ -1049,7 +1105,7 @@ instance (Selector s, Inject a) => GenericInject (M1 S s (K1 i a)) where genericInjectWith opts@(InterpretOptions {..}) = do - name <- fieldModifier . Data.Text.Lazy.pack <$> getSelName n + name <- fieldModifier . Data.Text.pack <$> getSelName n let embed (M1 (K1 x)) = RecordLit (Data.HashMap.Strict.InsOrd.singleton name (embedIn x)) let declared = @@ -1102,7 +1158,7 @@ ( Data.Functor.Product.Product ( Control.Applicative.Const ( Data.HashMap.Strict.InsOrd.InsOrdHashMap - Data.Text.Lazy.Text + Text ( Expr Src X ) ) ) @@ -1127,7 +1183,7 @@ -- | Parse a single field of a record. -field :: Data.Text.Lazy.Text -> Type a -> RecordType a +field :: Text -> Type a -> RecordType a field key valueType = let extractBody expr = do diff --git a/src/Dhall/Context.hs b/src/Dhall/Context.hs --- a/src/Dhall/Context.hs +++ b/src/Dhall/Context.hs @@ -12,7 +12,7 @@ , toList ) where -import Data.Text.Lazy (Text) +import Data.Text (Text) import Prelude hiding (lookup) {-| A @(Context a)@ associates `Text` labels with values of type @a@. Each diff --git a/src/Dhall/Core.hs b/src/Dhall/Core.hs --- a/src/Dhall/Core.hs +++ b/src/Dhall/Core.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UnicodeSyntax #-} {-# OPTIONS_GHC -Wall #-} {-| This module contains the core calculus for the Dhall language. @@ -41,6 +42,7 @@ , isNormalized , isNormalizedWith , denote + , freeIn -- * Pretty-printing , pretty @@ -58,6 +60,7 @@ import Control.Applicative (empty) import Crypto.Hash (SHA256) import Data.Bifunctor (Bifunctor(..)) +import Data.Data (Data) import Data.Foldable import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import Data.HashSet (HashSet) @@ -66,12 +69,10 @@ import Data.Semigroup (Semigroup(..)) import Data.Sequence (Seq, ViewL(..), ViewR(..)) import Data.Set (Set) -import Data.Text.Lazy (Text) -import Data.Text.Lazy.Builder (Builder) +import Data.Text (Text) import Data.Text.Prettyprint.Doc (Pretty) import Data.Traversable import {-# SOURCE #-} Dhall.Pretty.Internal -import Formatting.Buildable (Buildable(..)) import Numeric.Natural (Natural) import Prelude hiding (succ) @@ -82,7 +83,6 @@ import qualified Data.Sequence import qualified Data.Set import qualified Data.Text -import qualified Data.Text.Lazy.Builder as Builder import qualified Data.Text.Prettyprint.Doc as Pretty {-| Constants for a pure type system @@ -102,15 +102,15 @@ Note that Dhall does not support functions from terms to types and therefore Dhall is not a dependently typed language -} -data Const = Type | Kind deriving (Show, Eq, Bounded, Enum) +data Const = Type | Kind deriving (Show, Eq, Data, Bounded, Enum) -instance Buildable Const where - build = buildConst +instance Pretty Const where + pretty = Pretty.unAnnotate . prettyConst {-| Internal representation of a directory that stores the path components in reverse order - In other words, the directory @/foo/bar/baz@ is encoded as + In other words, the directory @\/foo\/bar\/baz@ is encoded as @Directory { components = [ "baz", "bar", "foo" ] }@ -} newtype Directory = Directory { components :: [Text] } @@ -120,11 +120,11 @@ Directory components₀ <> Directory components₁ = Directory (components₁ <> components₀) -instance Buildable Directory where - build (Directory {..}) = - foldMap buildComponent (reverse components) +instance Pretty Directory where + pretty (Directory {..}) = + foldMap prettyComponent (reverse components) where - buildComponent text = "/" <> build text + prettyComponent text = "/" <> Pretty.pretty text {-| A `File` is a `directory` followed by one additional path component representing the `file` name @@ -134,8 +134,8 @@ , file :: Text } deriving (Eq, Ord, Show) -instance Buildable File where - build (File {..}) = build directory <> "/" <> build file +instance Pretty File where + pretty (File {..}) = Pretty.pretty directory <> "/" <> Pretty.pretty file instance Semigroup File where File directory₀ _ <> File directory₁ file = @@ -146,17 +146,14 @@ -- ^ Absolute path | Here -- ^ Path relative to @.@ - | Parent - -- ^ Path relative to @..@ | Home -- ^ Path relative to @~@ deriving (Eq, Ord, Show) -instance Buildable FilePrefix where - build Absolute = "" - build Here = "." - build Parent = ".." - build Home = "~" +instance Pretty FilePrefix where + pretty Absolute = "" + pretty Here = "." + pretty Home = "~" -- | The type of import (i.e. local vs. remote vs. environment) data ImportType @@ -166,42 +163,34 @@ -- ^ URL of remote resource and optional headers stored in an import | Env Text -- ^ Environment variable + | Missing deriving (Eq, Ord, Show) -parent :: File -parent = File { directory = Directory { components = [ ".." ] }, file = "" } - instance Semigroup ImportType where Local prefix file₀ <> Local Here file₁ = Local prefix (file₀ <> file₁) URL prefix file₀ suffix headers <> Local Here file₁ = URL prefix (file₀ <> file₁) suffix headers - Local prefix file₀ <> Local Parent file₁ = - Local prefix (file₀ <> parent <> file₁) - - URL prefix file₀ suffix headers <> Local Parent file₁ = - URL prefix (file₀ <> parent <> file₁) suffix headers - _ <> import₁ = import₁ -instance Buildable ImportType where - build (Local prefix file) = - build prefix <> build file <> " " +instance Pretty ImportType where + pretty (Local prefix file) = + Pretty.pretty prefix <> Pretty.pretty file - build (URL prefix file suffix headers) = - build prefix - <> build file - <> build suffix - <> foldMap buildHeaders headers - <> " " + pretty (URL prefix file suffix headers) = + Pretty.pretty prefix + <> Pretty.pretty file + <> Pretty.pretty suffix + <> foldMap prettyHeaders headers where - buildHeaders h = " using " <> build h + prettyHeaders h = " using " <> Pretty.pretty h - build (Env env) = - "env:" <> build env <> " " + pretty (Env env) = "env:" <> Pretty.pretty env + pretty Missing = "missing" + -- | How to interpret the import's contents (i.e. as Dhall code or raw text) data ImportMode = Code | RawText deriving (Eq, Ord, Show) @@ -215,11 +204,11 @@ ImportHashed _ importType₀ <> ImportHashed hash importType₁ = ImportHashed hash (importType₀ <> importType₁) -instance Buildable ImportHashed where - build (ImportHashed Nothing p) = - build p - build (ImportHashed (Just h) p) = - build p <> "sha256:" <> build (show h) <> " " +instance Pretty ImportHashed where + pretty (ImportHashed Nothing p) = + Pretty.pretty p + pretty (ImportHashed (Just h) p) = + Pretty.pretty p <> " sha256:" <> Pretty.pretty (show h) -- | Reference to an external resource data Import = Import @@ -231,16 +220,14 @@ Import importHashed₀ _ <> Import importHashed₁ code = Import (importHashed₀ <> importHashed₁) code -instance Buildable Import where - build (Import {..}) = build importHashed <> suffix +instance Pretty Import where + pretty (Import {..}) = Pretty.pretty importHashed <> Pretty.pretty suffix where + suffix :: Text suffix = case importMode of - RawText -> "as Text" + RawText -> " as Text" Code -> "" -instance Pretty Import where - pretty import_ = Pretty.pretty (Builder.toLazyText (build import_)) - -- | Type synonym for `Import`, provided for backwards compatibility type Path = Import @@ -279,13 +266,13 @@ appear as a numeric suffix. -} data Var = V Text !Integer - deriving (Eq, Show) + deriving (Data, Eq, Show) instance IsString Var where fromString str = V (fromString str) 0 -instance Buildable Var where - build = buildVar +instance Pretty Var where + pretty = Pretty.unAnnotate . prettyVar -- | Syntax tree for expressions data Expr s a @@ -348,6 +335,8 @@ | IntegerLit Integer -- | > IntegerShow ~ Integer/show | IntegerShow + -- | > IntegerToDouble ~ Integer/toDouble + | IntegerToDouble -- | > Double ~ Double | Double -- | > DoubleLit n ~ n @@ -415,9 +404,11 @@ | Project (Expr s a) (Set Text) -- | > Note s x ~ e | Note s (Expr s a) + -- | > ImportAlt ~ e1 ? e2 + | ImportAlt (Expr s a) (Expr s a) -- | > Embed import ~ import | Embed a - deriving (Functor, Foldable, Traversable, Show, Eq) + deriving (Functor, Foldable, Traversable, Show, Eq, Data) instance Applicative (Expr s) where pure = Embed @@ -455,6 +446,7 @@ Integer >>= _ = Integer IntegerLit a >>= _ = IntegerLit a IntegerShow >>= _ = IntegerShow + IntegerToDouble >>= _ = IntegerToDouble Double >>= _ = Double DoubleLit a >>= _ = DoubleLit a DoubleShow >>= _ = DoubleShow @@ -487,6 +479,7 @@ Field a b >>= k = Field (a >>= k) b Project a b >>= k = Project (a >>= k) b Note a b >>= k = Note a (b >>= k) + ImportAlt a b >>= k = ImportAlt (a >>= k) (b >>= k) Embed a >>= k = k a instance Bifunctor Expr where @@ -518,6 +511,7 @@ first _ Integer = Integer first _ (IntegerLit a ) = IntegerLit a first _ IntegerShow = IntegerShow + first _ IntegerToDouble = IntegerToDouble first _ Double = Double first _ (DoubleLit a ) = DoubleLit a first _ DoubleShow = DoubleShow @@ -550,6 +544,7 @@ first k (Field a b ) = Field (first k a) b first k (Project a b ) = Project (first k a) b first k (Note a b ) = Note (k a) (first k b) + first k (ImportAlt a b ) = ImportAlt (first k a) (first k b) first _ (Embed a ) = Embed a second = fmap @@ -558,8 +553,8 @@ fromString str = Var (fromString str) -- | The body of an interpolated @Text@ literal -data Chunks s a = Chunks [(Builder, Expr s a)] Builder - deriving (Functor, Foldable, Traversable, Show, Eq) +data Chunks s a = Chunks [(Text, Expr s a)] Text + deriving (Functor, Foldable, Traversable, Show, Eq, Data) instance Data.Semigroup.Semigroup (Chunks s a) where Chunks xysL zL <> Chunks [] zR = @@ -589,9 +584,6 @@ -} -- | Generates a syntactically valid Dhall program -instance Buildable a => Buildable (Expr s a) where - build = buildExpr - instance Pretty a => Pretty (Expr s a) where pretty = Pretty.unAnnotate . prettyExpr @@ -732,6 +724,7 @@ shift _ _ Integer = Integer shift _ _ (IntegerLit a) = IntegerLit a shift _ _ IntegerShow = IntegerShow +shift _ _ IntegerToDouble = IntegerToDouble shift _ _ Double = Double shift _ _ (DoubleLit a) = DoubleLit a shift _ _ DoubleShow = DoubleShow @@ -808,6 +801,10 @@ shift d v (Note a b) = Note a b' where b' = shift d v b +shift d v (ImportAlt a b) = ImportAlt a' b' + where + a' = shift d v a + b' = shift d v b -- The Dhall compiler enforces that all embedded values are closed expressions -- and `shift` does nothing to a closed expression shift _ _ (Embed p) = Embed p @@ -888,6 +885,7 @@ subst _ _ Integer = Integer subst _ _ (IntegerLit a) = IntegerLit a subst _ _ IntegerShow = IntegerShow +subst _ _ IntegerToDouble = IntegerToDouble subst _ _ Double = Double subst _ _ (DoubleLit a) = DoubleLit a subst _ _ DoubleShow = DoubleShow @@ -955,6 +953,10 @@ subst x e (Note a b) = Note a b' where b' = subst x e b +subst x e (ImportAlt a b) = ImportAlt a' b' + where + a' = subst x e a + b' = subst x e b -- The Dhall compiler enforces that all embedded values are closed expressions -- and `subst` does nothing to a closed expression subst _ _ (Embed p) = Embed p @@ -1093,6 +1095,8 @@ IntegerLit n alphaNormalize IntegerShow = IntegerShow +alphaNormalize IntegerToDouble = + IntegerToDouble alphaNormalize Double = Double alphaNormalize (DoubleLit n) = @@ -1218,6 +1222,11 @@ Note s e₁ where e₁ = alphaNormalize e₀ +alphaNormalize (ImportAlt l₀ r₀) = + ImportAlt l₁ r₁ + where + l₁ = alphaNormalize l₀ + r₁ = alphaNormalize r₀ alphaNormalize (Embed a) = Embed a @@ -1286,6 +1295,7 @@ denote Integer = Integer denote (IntegerLit a ) = IntegerLit a denote IntegerShow = IntegerShow +denote IntegerToDouble = IntegerToDouble denote Double = Double denote (DoubleLit a ) = DoubleLit a denote DoubleShow = DoubleShow @@ -1317,6 +1327,7 @@ denote (Constructors a ) = Constructors (denote a) denote (Field a b ) = Field (denote a) b denote (Project a b ) = Project (denote a) b +denote (ImportAlt a b ) = ImportAlt (denote a) (denote b) denote (Embed a ) = Embed a {-| Reduce an expression to its normal form, performing beta reduction and applying @@ -1385,12 +1396,13 @@ App NaturalOdd (NaturalLit n) -> BoolLit (odd n) App NaturalToInteger (NaturalLit n) -> IntegerLit (toInteger n) App NaturalShow (NaturalLit n) -> - TextLit (Chunks [] (buildNatural n)) + TextLit (Chunks [] (Data.Text.pack (show n))) App IntegerShow (IntegerLit n) - | 0 <= n -> TextLit (Chunks [] ("+" <> buildNumber n)) - | otherwise -> TextLit (Chunks [] (buildNumber n)) + | 0 <= n -> TextLit (Chunks [] ("+" <> Data.Text.pack (show n))) + | otherwise -> TextLit (Chunks [] (Data.Text.pack (show n))) + App IntegerToDouble (IntegerLit n) -> DoubleLit (fromInteger n) App DoubleShow (DoubleLit n) -> - TextLit (Chunks [] (buildScientific n)) + TextLit (Chunks [] (Data.Text.pack (show n))) App (App OptionalBuild _A₀) g -> loop (App (App (App g optional) just) nothing) where @@ -1438,8 +1450,7 @@ m = case Data.Sequence.viewr ys of _ :> y -> Just y _ -> Nothing - App (App ListIndexed _A₀) (ListLit _A₁ as₀) -> - loop (ListLit (Just _A₂) as₁) + App (App ListIndexed _A₀) (ListLit _A₁ as₀) -> loop (ListLit t as₁) where as₁ = Data.Sequence.mapWithIndex adapt as₀ @@ -1449,6 +1460,9 @@ , ("value", _A₀) ] + t | null as₀ = Just _A₂ + | otherwise = Nothing + adapt n a_ = RecordLit (Data.HashMap.Strict.InsOrd.fromList kvs) where @@ -1542,6 +1556,7 @@ Integer -> Integer IntegerLit n -> IntegerLit n IntegerShow -> IntegerShow + IntegerToDouble -> IntegerToDouble Double -> Double DoubleLit n -> DoubleLit n DoubleShow -> DoubleShow @@ -1683,6 +1698,7 @@ return (x, v) r' -> Project r' xs Note _ e' -> loop e' + ImportAlt l _r -> loop l Embed a -> Embed a {-| Returns `True` if two expressions are α-equivalent and β-equivalent and @@ -1733,6 +1749,7 @@ App NaturalShow (NaturalLit _) -> False App NaturalToInteger (NaturalLit _) -> False App IntegerShow (IntegerLit _) -> False + App IntegerToDouble (IntegerLit _) -> False App DoubleShow (DoubleLit _) -> False App (App OptionalBuild _) _ -> False App (App ListBuild _) _ -> False @@ -1807,6 +1824,7 @@ Integer -> True IntegerLit _ -> True IntegerShow -> True + IntegerToDouble -> True Double -> True DoubleLit _ -> True DoubleShow -> True @@ -1894,8 +1912,27 @@ else True _ -> True Note _ e' -> isNormalized e' + ImportAlt l _r -> isNormalized l Embed _ -> True +{-| Detect if the given variable is free within the given expression + +>>> "x" `freeIn` "x" +True +>>> "x" `freeIn` "y" +False +>>> "x" `freeIn` Lam "x" (Const Type) "x" +False +-} +freeIn :: Eq a => Var -> Expr s a -> Bool +variable `freeIn` expression = + Dhall.Core.shift 1 variable strippedExpression /= strippedExpression + where + denote' :: Expr t b -> Expr () b + denote' = denote + + strippedExpression = denote' expression + _ERROR :: String _ERROR = "\ESC[1;31mError\ESC[0m" @@ -1948,6 +1985,7 @@ , "Natural/show" , "Integer" , "Integer/show" + , "Integer/toDouble" , "Double" , "Double/show" , "Text" diff --git a/src/Dhall/Diff.hs b/src/Dhall/Diff.hs --- a/src/Dhall/Diff.hs +++ b/src/Dhall/Diff.hs @@ -15,23 +15,27 @@ , Dhall.Diff.diff ) where -import Data.Foldable (fold) +import Data.Foldable (fold, toList) +import Data.Function (on) import Data.HashMap.Strict.InsOrd (InsOrdHashMap) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid (Any(..)) import Data.Scientific (Scientific) import Data.Semigroup +import Data.Sequence (Seq) import Data.Set (Set) import Data.String (IsString(..)) -import Data.Text.Lazy (Text) +import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty) -import Data.List.NonEmpty (NonEmpty(..)) -import Dhall.Core (Const(..), Expr(..), Var(..)) +import Dhall.Core (Chunks (..), Const(..), Expr(..), Var(..)) import Dhall.Pretty.Internal (Ann) import Numeric.Natural (Natural) +import qualified Data.Algorithm.Diff as Algo.Diff import qualified Data.HashMap.Strict.InsOrd as HashMap import qualified Data.List.NonEmpty import qualified Data.Set +import qualified Data.Text import qualified Data.Text.Prettyprint.Doc as Pretty import qualified Dhall.Core import qualified Dhall.Pretty.Internal as Internal @@ -157,7 +161,7 @@ diff :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Doc Ann diff l0 r0 = doc where - Diff {..} = diffExprA l0 r0 + Diff {..} = diffExpression l0 r0 <> hardline diffPrimitive :: Eq a => (a -> Diff) -> a -> a -> Diff diffPrimitive f l r @@ -205,6 +209,9 @@ natural = diffInteger nL nR +diffPretty :: (Eq a, Pretty a) => a -> a -> Diff +diffPretty = diffPrimitive (token . Pretty.pretty) + diffMaybe :: Diff -> (a -> a -> Diff) -> (Maybe a -> Maybe a -> Diff) diffMaybe _ _ Nothing Nothing = mempty @@ -239,7 +246,7 @@ prefixes = l :| repeat (hardline <> m) diffKeyVals - :: Pretty a + :: (Eq a, Pretty a) => Diff -> InsOrdHashMap Text (Expr s a) -> InsOrdHashMap Text (Expr s a) @@ -263,7 +270,7 @@ <> ignore ] - shared = HashMap.intersectionWith diffExprA kvsL kvsR + shared = HashMap.intersectionWith diffExpression kvsL kvsR diffFieldValues = filter (not . same) (HashMap.foldMapWithKey adapt shared) @@ -285,23 +292,120 @@ angled :: [Diff] -> Diff angled = enclosed (langle <> " ") (pipe <> " ") rangle +bracketed :: [Diff] -> Diff +bracketed = enclosed (lbracket <> " ") (comma <> " ") rbracket + +diffText :: Text -> Text -> Diff +diffText l r + | null parts = "\"\"" + | allDifferent parts = difference textSkeleton textSkeleton + | allSame parts = textSkeleton + | otherwise = "\"" <> foldMap prettyPart parts <> "\"" + where + allDifferent = not . any isBoth + allSame = all isBoth + + -- TODO: check for color support from the TTY + colorDiff colorCode chars = + "\ESC[" + <> colorCode + <> "m" + <> fromString chars + <> "\ESC[0m" + + prettyPart part = + case part of + -- Only present in left + Algo.Diff.First chars -> + -- Red background + (colorDiff "41" chars) { same = False } + + -- Only present in right + Algo.Diff.Second chars -> + -- Green background + (colorDiff "42" chars) { same = False } + + -- Present in both + Algo.Diff.Both _ chars -> + -- Dim foreground + colorDiff "2" chars + + parts = Algo.Diff.getGroupedDiff (Data.Text.unpack l) (Data.Text.unpack r) + +diffChunks + :: (Eq a, Pretty a) + => Chunks s a -> Chunks s a -> Diff +diffChunks cL cR + | null chunks = "\"\"" + | [c] <- chunks = c + | otherwise = align (enclosed " " "++ " "" chunks) + where + toEitherList (Chunks te t) = + concatMap (\(a, b) -> [Left a, Right b]) te ++ [Left t] + + diffTextSkeleton = difference textSkeleton textSkeleton + + chunks = zipWith chunkDiff (toEitherList cL) (toEitherList cR) + + chunkDiff a b = + case (a, b) of + (Left x, Left y ) -> diffText x y + (Right x, Right y) -> diffExpression x y + _ -> diffTextSkeleton + +diffList + :: (Eq a, Pretty a) + => Seq (Expr s a) -> Seq (Expr s a) -> Diff +diffList l r + | allDifferent parts = difference listSkeleton listSkeleton + | otherwise = bracketed (foldMap diffPart parts) + where + allDifferent = not . any isBoth + + -- Sections of the list that are only in left, only in right, or in both + parts = + Algo.Diff.getGroupedDiffBy ((same .) . diffExpression) (toList l) (toList r) + + -- Render each element of a list using an extra rendering function f + prettyElems f = map (f . token . Internal.prettyExpr) + + diffPart part = + case part of + -- Only present in left + Algo.Diff.First elements -> + prettyElems minus elements + + -- Only present in right + Algo.Diff.Second elements -> + prettyElems plus elements + + -- Present in both + Algo.Diff.Both _ _ -> + pure ignore + +-- Helper function to check when a diff part is present on both sides +isBoth :: Algo.Diff.Diff a -> Bool +isBoth p + | Algo.Diff.Both _ _ <- p = True + | otherwise = False + diffRecord - :: Pretty a + :: (Eq a, Pretty a) => InsOrdHashMap Text (Expr s a) -> InsOrdHashMap Text (Expr s a) -> Diff diffRecord kvsL kvsR = braced (diffKeyVals colon kvsL kvsR) diffRecordLit - :: Pretty a + :: (Eq a, Pretty a) => InsOrdHashMap Text (Expr s a) -> InsOrdHashMap Text (Expr s a) -> Diff diffRecordLit kvsL kvsR = braced (diffKeyVals equals kvsL kvsR) diffUnion - :: Pretty a + :: (Eq a, Pretty a) => InsOrdHashMap Text (Expr s a) -> InsOrdHashMap Text (Expr s a) -> Diff diffUnion kvsL kvsR = angled (diffKeyVals colon kvsL kvsR) diffUnionLit - :: Pretty a + :: (Eq a, Pretty a) => Text -> Text -> Expr s a @@ -315,11 +419,25 @@ <> format " " (diffLabel kL kR) <> equals <> " " - <> format " " (diffExprA vL vR) + <> format " " (diffExpression vL vR) <> halfAngled (diffKeyVals equals kvsL kvsR) where halfAngled = enclosed (pipe <> " ") (pipe <> " ") rangle +listSkeleton :: Diff +listSkeleton = + lbracket + <> " " + <> ignore + <> " " + <> rbracket + +textSkeleton :: Diff +textSkeleton = + "\"" + <> ignore + <> "\"" + skeleton :: Pretty a => Expr s a -> Diff skeleton (Lam {}) = lambda @@ -347,6 +465,12 @@ <> rarrow <> " " <> ignore +skeleton (App Optional _) = + "Optional " + <> ignore +skeleton (App List _) = + "List " + <> ignore skeleton (App {}) = ignore <> " " @@ -418,9 +542,7 @@ <> " " <> ignore skeleton (TextLit {}) = - "\"" - <> ignore - <> "\"" + textSkeleton skeleton (TextAppend {}) = ignore <> " " @@ -428,11 +550,7 @@ <> " " <> ignore skeleton (ListLit {}) = - lbracket - <> " " - <> ignore - <> " " - <> rbracket + listSkeleton <> " " <> colon <> " " @@ -542,25 +660,8 @@ mismatch :: Pretty a => Expr s a -> Expr s a -> Diff mismatch l r = difference (skeleton l) (skeleton r) -diffExprA :: Pretty a => Expr s a -> Expr s a -> Diff -diffExprA l@(Annot {}) r@(Annot {}) = - enclosed' " " (colon <> " ") (docs l r) - where - docs (Annot aL bL) (Annot aR bR) = - Data.List.NonEmpty.cons (align doc) (docs bL bR) - where - doc = diffExprB aL aR - docs aL aR = - diffExprB aL aR :| [] -diffExprA l@(Annot {}) r = - mismatch l r -diffExprA l r@(Annot {}) = - mismatch l r -diffExprA l r = - diffExprB l r - -diffExprB :: Pretty a => Expr s a -> Expr s a -> Diff -diffExprB l@(Lam {}) r@(Lam {}) = +diffExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffExpression l@(Lam {}) r@(Lam {}) = enclosed' " " (rarrow <> " ") (docs l r) where docs (Lam aL bL cL) (Lam aR bR cR) = @@ -571,16 +672,16 @@ <> format " " (diffLabel aL aR) <> colon <> " " - <> format mempty (diffExprA bL bR) + <> format mempty (diffExpression bL bR) <> rparen docs aL aR = - pure (diffExprC aL aR) -diffExprB l@(Lam {}) r = + pure (diffExpression aL aR) +diffExpression l@(Lam {}) r = mismatch l r -diffExprB l r@(Lam {}) = +diffExpression l r@(Lam {}) = mismatch l r -diffExprB l@(BoolIf {}) r@(BoolIf {}) = +diffExpression l@(BoolIf {}) r@(BoolIf {}) = enclosed' " " (keyword "else" <> " ") (docs l r) where docs (BoolIf aL bL cL) (BoolIf aR bR cR) = @@ -588,17 +689,35 @@ where doc = keyword "if" <> " " - <> format " " (diffExprA aL aR) + <> format " " (diffExpression aL aR) <> keyword "then" <> " " - <> diffExprA bL bR + <> diffExpression bL bR docs aL aR = - pure (diffExprB aL aR) -diffExprB l@(BoolIf {}) r = + pure (diffExpression aL aR) +diffExpression l@(BoolIf {}) r = mismatch l r -diffExprB l r@(BoolIf {}) = +diffExpression l r@(BoolIf {}) = mismatch l r -diffExprB l@(Pi {}) r@(Pi {}) = +diffExpression l@(Let {}) r@(Let {}) = + enclosed' " " (keyword "in" <> " ") (docs l r) + where + docs (Let aL bL cL dL) (Let aR bR cR dR) = + Data.List.NonEmpty.cons (align doc) (docs dL dR) + where + doc = keyword "let" + <> " " + <> format " " (diffLabel aL aR) + <> format " " (diffMaybe (colon <> " ") diffExpression bL bR) + <> equals + <> " " + <> diffExpression cL cR + docs aL aR = pure (diffExpression aL aR) +diffExpression l@(Let {}) r = + mismatch l r +diffExpression l r@(Let {}) = + mismatch l r +diffExpression l@(Pi {}) r@(Pi {}) = enclosed' " " (rarrow <> " ") (docs l r) where docs (Pi aL bL cL) (Pi aR bR cR) = @@ -609,263 +728,274 @@ <> format " " (diffLabel aL aR) <> colon <> " " - <> format mempty (diffExprA bL bR) + <> format mempty (diffExpression bL bR) <> rparen - docs aL aR = pure (diffExprB aL aR) -diffExprB l@(Pi {}) r = + docs aL aR = pure (diffExpression aL aR) +diffExpression l@(Pi {}) r = mismatch l r -diffExprB l r@(Pi {}) = +diffExpression l r@(Pi {}) = mismatch l r -diffExprB l@(Let {}) r@(Let {}) = - enclosed' " " (keyword "in" <> " ") (docs l r) +diffExpression l r = + diffAnnotatedExpression l r + +diffAnnotatedExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffAnnotatedExpression (Merge aL bL cL) (Merge aR bR cR) = align doc where - docs (Let aL bL cL dL) (Let aR bR cR dR) = - Data.List.NonEmpty.cons (align doc) (docs dL dR) - where - doc = keyword "let" - <> " " - <> format " " (diffLabel aL aR) - <> format " " (diffMaybe (colon <> " ") diffExprA bL bR) - <> equals - <> " " - <> diffExprA cL cR - docs aL aR = pure (diffExprB aL aR) -diffExprB l@(Let {}) r = - mismatch l r -diffExprB l r@(Let {}) = - mismatch l r --- TODO: Implement proper list diff -diffExprB l@(ListLit {}) r@(ListLit {}) = - mismatch l r -diffExprB l@(ListLit {}) r = + doc = keyword "merge" + <> " " + <> format " " (diffImportExpression aL aR) + <> format " " (diffImportExpression bL bR) + <> diffMaybe (colon <> " ") diffApplicationExpression cL cR +diffAnnotatedExpression l@(Merge {}) r = mismatch l r -diffExprB l r@(ListLit {}) = +diffAnnotatedExpression l r@(Merge {}) = mismatch l r -diffExprB (OptionalLit aL bL) (OptionalLit aR bR) = align doc +diffAnnotatedExpression (ListLit aL@(Just _) bL) (ListLit aR bR) = align doc where + doc = format " " (diffList bL bR) + <> format " " (diffMaybe (colon <> " ") (diffApplicationExpression `on` App List) aL aR) +diffAnnotatedExpression (ListLit aL bL) (ListLit aR@(Just _) bR) = align doc + where + doc = format " " (diffList bL bR) + <> format " " (diffMaybe (colon <> " ") (diffApplicationExpression `on` App List) aL aR) +diffAnnotatedExpression (OptionalLit aL bL) (OptionalLit aR bR) = + align doc + where doc = lbracket <> " " - <> format " " (diffMaybe mempty diffExprA bL bR) + <> format " " (diffMaybe mempty diffExpression bL bR) <> rbracket <> " " <> colon <> " " - <> diffExprD (App Optional aL) (App Optional aR) -diffExprB l@(OptionalLit {}) r = + <> diffApplicationExpression (App Optional aL) (App Optional aR) +diffAnnotatedExpression l@(OptionalLit {}) r = mismatch l r -diffExprB l r@(OptionalLit {}) = +diffAnnotatedExpression l r@(OptionalLit {}) = mismatch l r -diffExprB (Merge aL bL cL) (Merge aR bR cR) = align doc +diffAnnotatedExpression l@(Annot {}) r@(Annot {}) = + enclosed' " " (colon <> " ") (docs l r) where - doc = keyword "merge" - <> " " - <> format " " (diffExprE aL aR) - <> format " " (diffExprE bL bR) - <> diffMaybe (colon <> " ") diffExprE cL cR -diffExprB l@(Merge {}) r = + docs (Annot aL bL) (Annot aR bR) = + Data.List.NonEmpty.cons (align doc) (docs bL bR) + where + doc = diffOperatorExpression aL aR + docs aL aR = + diffExpression aL aR :| [] +diffAnnotatedExpression l@(Annot {}) r = mismatch l r -diffExprB l r@(Merge {}) = +diffAnnotatedExpression l r@(Annot {}) = mismatch l r -diffExprB l r = - diffExprC l r +diffAnnotatedExpression l r = + diffOperatorExpression l r -diffExprC :: Pretty a => Expr s a -> Expr s a -> Diff -diffExprC = diffBoolOr +diffOperatorExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffOperatorExpression = diffOrExpression -diffBoolOr :: Pretty a => Expr s a -> Expr s a -> Diff -diffBoolOr l@(BoolOr {}) r@(BoolOr {}) = +diffOrExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffOrExpression l@(BoolOr {}) r@(BoolOr {}) = enclosed' " " (operator "||" <> " ") (docs l r) where docs (BoolOr aL bL) (BoolOr aR bR) = - Data.List.NonEmpty.cons (diffTextAppend aL aR) (docs bL bR) + Data.List.NonEmpty.cons (diffTextAppendExpression aL aR) (docs bL bR) docs aL aR = - pure (diffTextAppend aL aR) -diffBoolOr l@(BoolOr {}) r = + pure (diffTextAppendExpression aL aR) +diffOrExpression l@(BoolOr {}) r = mismatch l r -diffBoolOr l r@(BoolOr {}) = +diffOrExpression l r@(BoolOr {}) = mismatch l r -diffBoolOr l r = - diffTextAppend l r +diffOrExpression l r = + diffPlusExpression l r -diffTextAppend :: Pretty a => Expr s a -> Expr s a -> Diff -diffTextAppend l@(TextAppend {}) r@(TextAppend {}) = - enclosed' " " (operator "++" <> " ") (docs l r) +diffPlusExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffPlusExpression l@(NaturalPlus {}) r@(NaturalPlus {}) = + enclosed' " " (operator "+" <> " ") (docs l r) where - docs (TextAppend aL bL) (TextAppend aR bR) = - Data.List.NonEmpty.cons (diffNaturalPlus aL aR) (docs bL bR) + docs (NaturalPlus aL bL) (NaturalPlus aR bR) = + Data.List.NonEmpty.cons (diffListAppendExpression aL aR) (docs bL bR) docs aL aR = - pure (diffNaturalPlus aL aR) -diffTextAppend l@(TextAppend {}) r = + pure (diffListAppendExpression aL aR) +diffPlusExpression l@(NaturalPlus {}) r = mismatch l r -diffTextAppend l r@(TextAppend {}) = +diffPlusExpression l r@(NaturalPlus {}) = mismatch l r -diffTextAppend l r = - diffNaturalPlus l r +diffPlusExpression l r = + diffTextAppendExpression l r -diffNaturalPlus :: Pretty a => Expr s a -> Expr s a -> Diff -diffNaturalPlus l@(NaturalPlus {}) r@(NaturalPlus {}) = - enclosed' " " (operator "+" <> " ") (docs l r) +diffTextAppendExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffTextAppendExpression l@(TextAppend {}) r@(TextAppend {}) = + enclosed' " " (operator "++" <> " ") (docs l r) where - docs (NaturalPlus aL bL) (NaturalPlus aR bR) = - Data.List.NonEmpty.cons (diffListAppend aL aR) (docs bL bR) + docs (TextAppend aL bL) (TextAppend aR bR) = + Data.List.NonEmpty.cons (diffPlusExpression aL aR) (docs bL bR) docs aL aR = - pure (diffListAppend aL aR) -diffNaturalPlus l@(NaturalPlus {}) r = + pure (diffPlusExpression aL aR) +diffTextAppendExpression l@(TextAppend {}) r = mismatch l r -diffNaturalPlus l r@(NaturalPlus {}) = +diffTextAppendExpression l r@(TextAppend {}) = mismatch l r -diffNaturalPlus l r = - diffListAppend l r +diffTextAppendExpression l r = + diffListAppendExpression l r -diffListAppend :: Pretty a => Expr s a -> Expr s a -> Diff -diffListAppend l@(ListAppend {}) r@(ListAppend {}) = +diffListAppendExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffListAppendExpression l@(ListAppend {}) r@(ListAppend {}) = enclosed' " " (operator "#" <> " ") (docs l r) where docs (ListAppend aL bL) (ListAppend aR bR) = - Data.List.NonEmpty.cons (diffBoolAnd aL aR) (docs bL bR) + Data.List.NonEmpty.cons (diffAndExpression aL aR) (docs bL bR) docs aL aR = - pure (diffBoolAnd aL aR) -diffListAppend l@(ListAppend {}) r = + pure (diffAndExpression aL aR) +diffListAppendExpression l@(ListAppend {}) r = mismatch l r -diffListAppend l r@(ListAppend {}) = +diffListAppendExpression l r@(ListAppend {}) = mismatch l r -diffListAppend l r = - diffBoolAnd l r +diffListAppendExpression l r = + diffAndExpression l r -diffBoolAnd :: Pretty a => Expr s a -> Expr s a -> Diff -diffBoolAnd l@(BoolAnd {}) r@(BoolAnd {}) = +diffAndExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffAndExpression l@(BoolAnd {}) r@(BoolAnd {}) = enclosed' " " (operator "&&" <> " ") (docs l r) where docs (BoolAnd aL bL) (BoolAnd aR bR) = - Data.List.NonEmpty.cons (diffCombine aL aR) (docs bL bR) + Data.List.NonEmpty.cons (diffCombineExpression aL aR) (docs bL bR) docs aL aR = - pure (diffCombine aL aR) -diffBoolAnd l@(BoolAnd {}) r = + pure (diffCombineExpression aL aR) +diffAndExpression l@(BoolAnd {}) r = mismatch l r -diffBoolAnd l r@(BoolAnd {}) = +diffAndExpression l r@(BoolAnd {}) = mismatch l r -diffBoolAnd l r = - diffCombine l r +diffAndExpression l r = + diffCombineExpression l r -diffCombine :: Pretty a => Expr s a -> Expr s a -> Diff -diffCombine l@(Combine {}) r@(Combine {}) = +diffCombineExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffCombineExpression l@(Combine {}) r@(Combine {}) = enclosed' " " (operator "∧" <> " ") (docs l r) where docs (Combine aL bL) (Combine aR bR) = - Data.List.NonEmpty.cons (diffPrefer aL aR) (docs bL bR) + Data.List.NonEmpty.cons (diffPreferExpression aL aR) (docs bL bR) docs aL aR = - pure (diffPrefer aL aR) -diffCombine l@(Combine {}) r = + pure (diffPreferExpression aL aR) +diffCombineExpression l@(Combine {}) r = mismatch l r -diffCombine l r@(Combine {}) = +diffCombineExpression l r@(Combine {}) = mismatch l r -diffCombine l r = - diffPrefer l r +diffCombineExpression l r = + diffPreferExpression l r -diffPrefer :: Pretty a => Expr s a -> Expr s a -> Diff -diffPrefer l@(Prefer {}) r@(Prefer {}) = +diffPreferExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffPreferExpression l@(Prefer {}) r@(Prefer {}) = enclosed' " " (operator "⫽" <> " ") (docs l r) where docs (Prefer aL bL) (Prefer aR bR) = - Data.List.NonEmpty.cons (diffCombineTypes aL aR) (docs bL bR) + Data.List.NonEmpty.cons (diffCombineTypesExpression aL aR) (docs bL bR) docs aL aR = - pure (diffCombineTypes aL aR) -diffPrefer l@(Prefer {}) r = + pure (diffCombineTypesExpression aL aR) +diffPreferExpression l@(Prefer {}) r = mismatch l r -diffPrefer l r@(Prefer {}) = +diffPreferExpression l r@(Prefer {}) = mismatch l r -diffPrefer l r = - diffCombineTypes l r +diffPreferExpression l r = + diffCombineTypesExpression l r -diffCombineTypes :: Pretty a => Expr s a -> Expr s a -> Diff -diffCombineTypes l@(CombineTypes {}) r@(CombineTypes {}) = +diffCombineTypesExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffCombineTypesExpression l@(CombineTypes {}) r@(CombineTypes {}) = enclosed' " " (operator "*" <> " ") (docs l r) where docs (CombineTypes aL bL) (CombineTypes aR bR) = - Data.List.NonEmpty.cons (diffNaturalTimes aL aR) (docs bL bR) + Data.List.NonEmpty.cons (diffTimesExpression aL aR) (docs bL bR) docs aL aR = - pure (diffNaturalTimes aL aR) -diffCombineTypes l@(CombineTypes {}) r = + pure (diffTimesExpression aL aR) +diffCombineTypesExpression l@(CombineTypes {}) r = mismatch l r -diffCombineTypes l r@(CombineTypes {}) = +diffCombineTypesExpression l r@(CombineTypes {}) = mismatch l r -diffCombineTypes l r = - diffNaturalTimes l r +diffCombineTypesExpression l r = + diffTimesExpression l r -diffNaturalTimes :: Pretty a => Expr s a -> Expr s a -> Diff -diffNaturalTimes l@(NaturalTimes {}) r@(NaturalTimes {}) = +diffTimesExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffTimesExpression l@(NaturalTimes {}) r@(NaturalTimes {}) = enclosed' " " (operator "*" <> " ") (docs l r) where docs (NaturalTimes aL bL) (NaturalTimes aR bR) = - Data.List.NonEmpty.cons (diffBoolEQ aL aR) (docs bL bR) + Data.List.NonEmpty.cons (diffEqualExpression aL aR) (docs bL bR) docs aL aR = - pure (diffBoolEQ aL aR) -diffNaturalTimes l@(NaturalTimes {}) r = + pure (diffEqualExpression aL aR) +diffTimesExpression l@(NaturalTimes {}) r = mismatch l r -diffNaturalTimes l r@(NaturalTimes {}) = +diffTimesExpression l r@(NaturalTimes {}) = mismatch l r -diffNaturalTimes l r = - diffBoolEQ l r +diffTimesExpression l r = + diffEqualExpression l r -diffBoolEQ :: Pretty a => Expr s a -> Expr s a -> Diff -diffBoolEQ l@(BoolEQ {}) r@(BoolEQ {}) = +diffEqualExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffEqualExpression l@(BoolEQ {}) r@(BoolEQ {}) = enclosed' " " (operator "==" <> " ") (docs l r) where docs (BoolEQ aL bL) (BoolEQ aR bR) = - Data.List.NonEmpty.cons (diffBoolNE aL aR) (docs bL bR) + Data.List.NonEmpty.cons (diffNotEqualExpression aL aR) (docs bL bR) docs aL aR = - pure (diffBoolNE aL aR) -diffBoolEQ l@(BoolEQ {}) r = + pure (diffNotEqualExpression aL aR) +diffEqualExpression l@(BoolEQ {}) r = mismatch l r -diffBoolEQ l r@(BoolEQ {}) = +diffEqualExpression l r@(BoolEQ {}) = mismatch l r -diffBoolEQ l r = - diffBoolNE l r +diffEqualExpression l r = + diffNotEqualExpression l r -diffBoolNE :: Pretty a => Expr s a -> Expr s a -> Diff -diffBoolNE l@(BoolNE {}) r@(BoolNE {}) = +diffNotEqualExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffNotEqualExpression l@(BoolNE {}) r@(BoolNE {}) = enclosed' " " (operator "!=" <> " ") (docs l r) where docs (BoolNE aL bL) (BoolNE aR bR) = - Data.List.NonEmpty.cons (diffExprD aL aR) (docs bL bR) + Data.List.NonEmpty.cons (diffApplicationExpression aL aR) (docs bL bR) docs aL aR = - pure (diffExprD aL aR) -diffBoolNE l@(BoolNE {}) r = + pure (diffApplicationExpression aL aR) +diffNotEqualExpression l@(BoolNE {}) r = mismatch l r -diffBoolNE l r@(BoolNE {}) = +diffNotEqualExpression l r@(BoolNE {}) = mismatch l r -diffBoolNE l r = - diffExprD l r +diffNotEqualExpression l r = + diffApplicationExpression l r -diffExprD :: Pretty a => Expr s a -> Expr s a -> Diff -diffExprD l@(App {}) r@(App {}) = +diffApplicationExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffApplicationExpression l@(App {}) r@(App {}) = enclosed' mempty mempty (Data.List.NonEmpty.reverse (docs l r)) where docs (App aL bL) (App aR bR) = - Data.List.NonEmpty.cons (diffExprE bL bR) (docs aL aR) + Data.List.NonEmpty.cons (diffImportExpression bL bR) (docs aL aR) docs (Constructors aL) (Constructors aR) = - diffExprE aL aR :| [ keyword "constructors" ] + diffImportExpression aL aR :| [ keyword "constructors" ] docs aL@(App {}) aR@(Constructors {}) = pure (mismatch aL aR) docs aL@(Constructors {}) aR@(App {}) = pure (mismatch aL aR) docs aL aR = - pure (diffExprE aL aR) -diffExprD l@(App {}) r = + pure (diffImportExpression aL aR) +diffApplicationExpression l@(App {}) r = mismatch l r -diffExprD l r@(App {}) = +diffApplicationExpression l r@(App {}) = mismatch l r -diffExprD l@(Constructors {}) r@(Constructors {}) = - enclosed' mempty mempty (keyword "constructors" :| [ diffExprE l r ]) -diffExprD l@(Constructors {}) r = +diffApplicationExpression l@(Constructors {}) r@(Constructors {}) = + enclosed' mempty mempty (keyword "constructors" :| [ diffImportExpression l r ]) +diffApplicationExpression l@(Constructors {}) r = mismatch l r -diffExprD l r@(Constructors {}) = +diffApplicationExpression l r@(Constructors {}) = mismatch l r -diffExprD l r = - diffExprE l r +diffApplicationExpression l r = + diffImportExpression l r -diffExprE :: Pretty a => Expr s a -> Expr s a -> Diff -diffExprE l@(Field {}) r@(Field {}) = +diffImportExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffImportExpression (Embed l) (Embed r) = + diffPretty l r +diffImportExpression l@(Embed {}) r = + mismatch l r +diffImportExpression l r@(Embed {}) = + mismatch l r +diffImportExpression l r = + diffSelectorExpression l r + +diffSelectorExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffSelectorExpression l@(Field {}) r@(Field {}) = enclosed' " " (dot <> " ") (Data.List.NonEmpty.reverse (docs l r)) where docs (Field aL bL) (Field aR bR) = @@ -873,12 +1003,12 @@ docs (Project aL bL) (Project aR bR) = Data.List.NonEmpty.cons (diffLabels bL bR) (docs aL aR) docs aL aR = - pure (diffExprF aL aR) -diffExprE l@(Field {}) r = + pure (diffPrimitiveExpression aL aR) +diffSelectorExpression l@(Field {}) r = mismatch l r -diffExprE l r@(Field {}) = +diffSelectorExpression l r@(Field {}) = mismatch l r -diffExprE l@(Project {}) r@(Project {}) = +diffSelectorExpression l@(Project {}) r@(Project {}) = enclosed' " " (dot <> " ") (Data.List.NonEmpty.reverse (docs l r)) where docs (Field aL bL) (Field aR bR) = @@ -886,235 +1016,247 @@ docs (Project aL bL) (Project aR bR) = Data.List.NonEmpty.cons (diffLabels bL bR) (docs aL aR) docs aL aR = - pure (diffExprF aL aR) -diffExprE l@(Project {}) r = + pure (diffPrimitiveExpression aL aR) +diffSelectorExpression l@(Project {}) r = mismatch l r -diffExprE l r@(Project {}) = +diffSelectorExpression l r@(Project {}) = mismatch l r -diffExprE l r = - diffExprF l r +diffSelectorExpression l r = + diffPrimitiveExpression l r -diffExprF :: Pretty a => Expr s a -> Expr s a -> Diff -diffExprF (Var aL) (Var aR) = +diffPrimitiveExpression :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Diff +diffPrimitiveExpression (Var aL) (Var aR) = diffVar aL aR -diffExprF l@(Var {}) r = +diffPrimitiveExpression l@(Var {}) r = mismatch l r -diffExprF l r@(Var {}) = +diffPrimitiveExpression l r@(Var {}) = mismatch l r -diffExprF (Const aL) (Const aR) = +diffPrimitiveExpression (Const aL) (Const aR) = diffConst aL aR -diffExprF l@(Const {}) r = +diffPrimitiveExpression l@(Const {}) r = mismatch l r -diffExprF l r@(Const {}) = +diffPrimitiveExpression l r@(Const {}) = mismatch l r -diffExprF Bool Bool = +diffPrimitiveExpression Bool Bool = "…" -diffExprF l@Bool r = +diffPrimitiveExpression l@Bool r = mismatch l r -diffExprF l r@Bool = +diffPrimitiveExpression l r@Bool = mismatch l r -diffExprF Natural Natural = +diffPrimitiveExpression Natural Natural = "…" -diffExprF l@Natural r = +diffPrimitiveExpression l@Natural r = mismatch l r -diffExprF l r@Natural = +diffPrimitiveExpression l r@Natural = mismatch l r -diffExprF NaturalFold NaturalFold = +diffPrimitiveExpression NaturalFold NaturalFold = "…" -diffExprF l@NaturalFold r = +diffPrimitiveExpression l@NaturalFold r = mismatch l r -diffExprF l r@NaturalFold = +diffPrimitiveExpression l r@NaturalFold = mismatch l r -diffExprF NaturalBuild NaturalBuild = +diffPrimitiveExpression NaturalBuild NaturalBuild = "…" -diffExprF l@NaturalBuild r = +diffPrimitiveExpression l@NaturalBuild r = mismatch l r -diffExprF l r@NaturalBuild = +diffPrimitiveExpression l r@NaturalBuild = mismatch l r -diffExprF NaturalIsZero NaturalIsZero = +diffPrimitiveExpression NaturalIsZero NaturalIsZero = "…" -diffExprF l@NaturalIsZero r = +diffPrimitiveExpression l@NaturalIsZero r = mismatch l r -diffExprF l r@NaturalIsZero = +diffPrimitiveExpression l r@NaturalIsZero = mismatch l r -diffExprF NaturalEven NaturalEven = +diffPrimitiveExpression NaturalEven NaturalEven = "…" -diffExprF l@NaturalEven r = +diffPrimitiveExpression l@NaturalEven r = mismatch l r -diffExprF l r@NaturalEven = +diffPrimitiveExpression l r@NaturalEven = mismatch l r -diffExprF NaturalOdd NaturalOdd = +diffPrimitiveExpression NaturalOdd NaturalOdd = "…" -diffExprF l@NaturalOdd r = +diffPrimitiveExpression l@NaturalOdd r = mismatch l r -diffExprF l r@NaturalOdd = +diffPrimitiveExpression l r@NaturalOdd = mismatch l r -diffExprF NaturalToInteger NaturalToInteger = +diffPrimitiveExpression NaturalToInteger NaturalToInteger = "…" -diffExprF l@NaturalToInteger r = +diffPrimitiveExpression l@NaturalToInteger r = mismatch l r -diffExprF l r@NaturalToInteger = +diffPrimitiveExpression l r@NaturalToInteger = mismatch l r -diffExprF NaturalShow NaturalShow = +diffPrimitiveExpression NaturalShow NaturalShow = "…" -diffExprF l@NaturalShow r = +diffPrimitiveExpression l@NaturalShow r = mismatch l r -diffExprF l r@NaturalShow = +diffPrimitiveExpression l r@NaturalShow = mismatch l r -diffExprF Integer Integer = +diffPrimitiveExpression Integer Integer = "…" -diffExprF l@Integer r = +diffPrimitiveExpression l@Integer r = mismatch l r -diffExprF l r@Integer = +diffPrimitiveExpression l r@Integer = mismatch l r -diffExprF IntegerShow IntegerShow = +diffPrimitiveExpression IntegerShow IntegerShow = "…" -diffExprF l@IntegerShow r = +diffPrimitiveExpression l@IntegerShow r = mismatch l r -diffExprF l r@IntegerShow = +diffPrimitiveExpression l r@IntegerShow = mismatch l r -diffExprF Double Double = +diffPrimitiveExpression IntegerToDouble IntegerToDouble = "…" -diffExprF l@Double r = +diffPrimitiveExpression l@IntegerToDouble r = mismatch l r -diffExprF l r@Double = +diffPrimitiveExpression l r@IntegerToDouble = mismatch l r -diffExprF DoubleShow DoubleShow = +diffPrimitiveExpression Double Double = "…" -diffExprF l@DoubleShow r = +diffPrimitiveExpression l@Double r = mismatch l r -diffExprF l r@DoubleShow = +diffPrimitiveExpression l r@Double = mismatch l r -diffExprF Text Text = +diffPrimitiveExpression DoubleShow DoubleShow = "…" -diffExprF l@Text r = +diffPrimitiveExpression l@DoubleShow r = mismatch l r -diffExprF l r@Text = +diffPrimitiveExpression l r@DoubleShow = mismatch l r -diffExprF List List = +diffPrimitiveExpression Text Text = "…" -diffExprF l@List r = +diffPrimitiveExpression l@Text r = mismatch l r -diffExprF l r@List = +diffPrimitiveExpression l r@Text = mismatch l r -diffExprF ListBuild ListBuild = +diffPrimitiveExpression List List = "…" -diffExprF l@ListBuild r = +diffPrimitiveExpression l@List r = mismatch l r -diffExprF l r@ListBuild = +diffPrimitiveExpression l r@List = mismatch l r -diffExprF ListFold ListFold = +diffPrimitiveExpression (ListLit Nothing bL) (ListLit Nothing bR) = align doc + where + doc = format " " (diffList bL bR) +diffPrimitiveExpression l@(ListLit {}) r = + mismatch l r +diffPrimitiveExpression l r@(ListLit {}) = + mismatch l r +diffPrimitiveExpression ListBuild ListBuild = "…" -diffExprF l@ListFold r = +diffPrimitiveExpression l@ListBuild r = mismatch l r -diffExprF l r@ListFold = +diffPrimitiveExpression l r@ListBuild = mismatch l r -diffExprF ListLength ListLength = +diffPrimitiveExpression ListFold ListFold = "…" -diffExprF l@ListLength r = +diffPrimitiveExpression l@ListFold r = mismatch l r -diffExprF l r@ListLength = +diffPrimitiveExpression l r@ListFold = mismatch l r -diffExprF ListHead ListHead = +diffPrimitiveExpression ListLength ListLength = "…" -diffExprF l@ListHead r = +diffPrimitiveExpression l@ListLength r = mismatch l r -diffExprF l r@ListHead = +diffPrimitiveExpression l r@ListLength = mismatch l r -diffExprF ListLast ListLast = +diffPrimitiveExpression ListHead ListHead = "…" -diffExprF l@ListLast r = +diffPrimitiveExpression l@ListHead r = mismatch l r -diffExprF l r@ListLast = +diffPrimitiveExpression l r@ListHead = mismatch l r -diffExprF ListIndexed ListIndexed = +diffPrimitiveExpression ListLast ListLast = "…" -diffExprF l@ListIndexed r = +diffPrimitiveExpression l@ListLast r = mismatch l r -diffExprF l r@ListIndexed = +diffPrimitiveExpression l r@ListLast = mismatch l r -diffExprF ListReverse ListReverse = +diffPrimitiveExpression ListIndexed ListIndexed = "…" -diffExprF l@ListReverse r = +diffPrimitiveExpression l@ListIndexed r = mismatch l r -diffExprF l r@ListReverse = +diffPrimitiveExpression l r@ListIndexed = mismatch l r -diffExprF Optional Optional = +diffPrimitiveExpression ListReverse ListReverse = "…" -diffExprF l@Optional r = +diffPrimitiveExpression l@ListReverse r = mismatch l r -diffExprF l r@Optional = +diffPrimitiveExpression l r@ListReverse = mismatch l r -diffExprF OptionalFold OptionalFold = +diffPrimitiveExpression Optional Optional = "…" -diffExprF l@OptionalFold r = +diffPrimitiveExpression l@Optional r = mismatch l r -diffExprF l r@OptionalFold = +diffPrimitiveExpression l r@Optional = mismatch l r -diffExprF OptionalBuild OptionalBuild = +diffPrimitiveExpression OptionalFold OptionalFold = "…" -diffExprF l@OptionalBuild r = +diffPrimitiveExpression l@OptionalFold r = mismatch l r -diffExprF l r@OptionalBuild = +diffPrimitiveExpression l r@OptionalFold = mismatch l r -diffExprF (BoolLit aL) (BoolLit aR) = +diffPrimitiveExpression OptionalBuild OptionalBuild = + "…" +diffPrimitiveExpression l@OptionalBuild r = + mismatch l r +diffPrimitiveExpression l r@OptionalBuild = + mismatch l r +diffPrimitiveExpression (BoolLit aL) (BoolLit aR) = diffBool aL aR -diffExprF l@(BoolLit {}) r = +diffPrimitiveExpression l@(BoolLit {}) r = mismatch l r -diffExprF l r@(BoolLit {}) = +diffPrimitiveExpression l r@(BoolLit {}) = mismatch l r -diffExprF (IntegerLit aL) (IntegerLit aR) = +diffPrimitiveExpression (IntegerLit aL) (IntegerLit aR) = diffInteger aL aR -diffExprF l@(IntegerLit {}) r = +diffPrimitiveExpression l@(IntegerLit {}) r = mismatch l r -diffExprF l r@(IntegerLit {}) = +diffPrimitiveExpression l r@(IntegerLit {}) = mismatch l r -diffExprF (NaturalLit aL) (NaturalLit aR) = - token (Internal.literal "+") <> diffNatural aL aR -diffExprF l@(NaturalLit {}) r = +diffPrimitiveExpression (NaturalLit aL) (NaturalLit aR) = + diffNatural aL aR +diffPrimitiveExpression l@(NaturalLit {}) r = mismatch l r -diffExprF l r@(NaturalLit {}) = +diffPrimitiveExpression l r@(NaturalLit {}) = mismatch l r -diffExprF (DoubleLit aL) (DoubleLit aR) = +diffPrimitiveExpression (DoubleLit aL) (DoubleLit aR) = diffScientific aL aR -diffExprF l@(DoubleLit {}) r = - mismatch l r -diffExprF l r@(DoubleLit {}) = +diffPrimitiveExpression l@(DoubleLit {}) r = mismatch l r --- TODO: Implement proper textual diff -diffExprF l@(TextLit {}) r@(TextLit {}) = +diffPrimitiveExpression l r@(DoubleLit {}) = mismatch l r -diffExprF l@(TextLit {}) r = +diffPrimitiveExpression (TextLit l) (TextLit r) = + diffChunks l r +diffPrimitiveExpression l@(TextLit {}) r = mismatch l r -diffExprF l r@(TextLit {}) = +diffPrimitiveExpression l r@(TextLit {}) = mismatch l r -diffExprF (Record aL) (Record aR) = +diffPrimitiveExpression (Record aL) (Record aR) = diffRecord aL aR -diffExprF l@(Record {}) r = +diffPrimitiveExpression l@(Record {}) r = mismatch l r -diffExprF l r@(Record {}) = +diffPrimitiveExpression l r@(Record {}) = mismatch l r -diffExprF (RecordLit aL) (RecordLit aR) = +diffPrimitiveExpression (RecordLit aL) (RecordLit aR) = diffRecordLit aL aR -diffExprF l@(RecordLit {}) r = +diffPrimitiveExpression l@(RecordLit {}) r = mismatch l r -diffExprF l r@(RecordLit {}) = +diffPrimitiveExpression l r@(RecordLit {}) = mismatch l r -diffExprF (Union aL) (Union aR) = +diffPrimitiveExpression (Union aL) (Union aR) = diffUnion aL aR -diffExprF l@(Union {}) r = +diffPrimitiveExpression l@(Union {}) r = mismatch l r -diffExprF l r@(Union {}) = +diffPrimitiveExpression l r@(Union {}) = mismatch l r -diffExprF (UnionLit aL bL cL) (UnionLit aR bR cR) = +diffPrimitiveExpression (UnionLit aL bL cL) (UnionLit aR bR cR) = diffUnionLit aL aR bL bR cL cR -diffExprF l@(UnionLit {}) r = +diffPrimitiveExpression l@(UnionLit {}) r = mismatch l r -diffExprF l r@(UnionLit {}) = +diffPrimitiveExpression l r@(UnionLit {}) = mismatch l r -diffExprF aL aR = +diffPrimitiveExpression aL aR = if same doc then ignore else align ("( " <> doc <> hardline <> ")") where - doc = diffExprA aL aR + doc = diffExpression aL aR diff --git a/src/Dhall/Format.hs b/src/Dhall/Format.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Format.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Dhall.Format ( format ) where + +import Dhall.Parser (exprAndHeaderFromText) +import Dhall.Pretty (annToAnsiStyle, prettyExpr) + +import Data.Monoid ((<>)) + +import qualified Data.Text.Prettyprint.Doc as Pretty +import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty +import qualified Control.Exception +import qualified Data.Text.IO +import qualified System.Console.ANSI +import qualified System.IO + +opts :: Pretty.LayoutOptions +opts = + Pretty.defaultLayoutOptions + { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 } + +format :: Maybe FilePath -> IO () +format inplace = do + case inplace of + Just file -> do + text <- Data.Text.IO.readFile file + (header, expr) <- case exprAndHeaderFromText "(stdin)" text of + Left err -> Control.Exception.throwIO err + Right x -> return x + + let doc = Pretty.pretty header <> Pretty.pretty expr + System.IO.withFile file System.IO.WriteMode (\handle -> do + Pretty.renderIO handle (Pretty.layoutSmart opts doc) + Data.Text.IO.hPutStrLn handle "" ) + Nothing -> do + System.IO.hSetEncoding System.IO.stdin System.IO.utf8 + inText <- Data.Text.IO.getContents + + (header, expr) <- case exprAndHeaderFromText "(stdin)" inText of + Left err -> Control.Exception.throwIO err + Right x -> return x + + let doc = Pretty.pretty header <> prettyExpr expr + + supportsANSI <- System.Console.ANSI.hSupportsANSI System.IO.stdout + + if supportsANSI + then + Pretty.renderIO + System.IO.stdout + (fmap annToAnsiStyle (Pretty.layoutSmart opts doc)) + else + Pretty.renderIO + System.IO.stdout + (Pretty.layoutSmart opts (Pretty.unAnnotate doc)) diff --git a/src/Dhall/Freeze.hs b/src/Dhall/Freeze.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Freeze.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Dhall.Freeze ( + freeze + , hashImport + ) where + +import Dhall.Core +import Dhall.Import (load, hashExpression) +import Dhall.Parser (exprAndHeaderFromText, Src) +import Dhall.Pretty (annToAnsiStyle) + +import System.Console.ANSI (hSupportsANSI) +import Data.Monoid ((<>)) +import Data.Maybe (fromMaybe) +import Data.Text + +import qualified Data.Text.Prettyprint.Doc as Pretty +import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty +import qualified Control.Exception +import qualified Data.Text.IO +import qualified System.IO + +opts :: Pretty.LayoutOptions +opts = + Pretty.defaultLayoutOptions + { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 } + +readInput :: Maybe FilePath -> IO Text +readInput = maybe fromStdin Data.Text.IO.readFile + where + fromStdin = System.IO.hSetEncoding System.IO.stdin System.IO.utf8 >> Data.Text.IO.getContents + +hashImport :: Import -> IO Import +hashImport import_ = do + expression <- Dhall.Import.load (Embed import_) + let expressionHash = Just (Dhall.Import.hashExpression expression) + let newImportHashed = (importHashed import_) { hash = expressionHash } + return $ import_ { importHashed = newImportHashed } + +parseExpr :: String -> Text -> IO (Text, Expr Src Import) +parseExpr src txt = + case exprAndHeaderFromText src txt of + Left err -> Control.Exception.throwIO err + Right x -> return x + +freezeExpr :: (Text, Expr s Import) -> IO (Text, Expr s Import) +freezeExpr (t, e) = do + e' <- traverse hashImport e + return (t, e') + +writeExpr :: Maybe FilePath -> (Text, Expr s Import) -> IO () +writeExpr inplace (header, expr) = do + let doc = Pretty.pretty header <> Pretty.pretty expr + let layoutOptions = opts + let stream = Pretty.layoutSmart layoutOptions doc + + case inplace of + Just f -> + System.IO.withFile f System.IO.WriteMode (\h -> + Pretty.renderIO h (annToAnsiStyle <$> stream)) + + Nothing -> do + supportsANSI <- System.Console.ANSI.hSupportsANSI System.IO.stdout + if supportsANSI + then + Pretty.renderIO System.IO.stdout (annToAnsiStyle <$> Pretty.layoutSmart opts doc) + else + Pretty.renderIO System.IO.stdout (Pretty.layoutSmart opts (Pretty.unAnnotate doc)) + +freeze :: Maybe FilePath -> IO () +freeze inplace = do + expr <- readInput inplace + parseExpr srcInfo expr >>= freezeExpr >>= writeExpr inplace + where + srcInfo = fromMaybe "(stdin)" inplace diff --git a/src/Dhall/Hash.hs b/src/Dhall/Hash.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Hash.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Dhall.Hash ( hash ) where + +import Dhall.Parser (exprFromText) +import Dhall.Import (hashExpressionToCode, load) + +import qualified Control.Exception +import qualified Dhall.TypeCheck +import qualified Data.Text.IO +import qualified System.IO + +hash :: IO () +hash = do + System.IO.hSetEncoding System.IO.stdin System.IO.utf8 + inText <- Data.Text.IO.getContents + + expr <- case exprFromText "(stdin)" inText of + Left err -> Control.Exception.throwIO err + Right expr -> return expr + + expr' <- load expr + + _ <- case Dhall.TypeCheck.typeOf expr' of + Left err -> Control.Exception.throwIO err + Right _ -> return () + + Data.Text.IO.putStrLn (hashExpressionToCode expr') diff --git a/src/Dhall/Import.hs b/src/Dhall/Import.hs --- a/src/Dhall/Import.hs +++ b/src/Dhall/Import.hs @@ -113,27 +113,24 @@ , PrettyHttpException(..) , MissingFile(..) , MissingEnvironmentVariable(..) + , MissingImports(..) ) where import Control.Applicative (empty) -import Control.Exception (Exception, SomeException, throwIO) -import Control.Monad (join) -import Control.Monad.Catch (throwM, MonadCatch(catch)) +import Control.Exception (Exception, SomeException, throwIO, toException) +import Control.Monad.Catch (throwM, MonadCatch(catch), catches, Handler(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.State.Strict (StateT) import Crypto.Hash (SHA256) import Data.CaseInsensitive (CI) import Data.List.NonEmpty (NonEmpty(..)) -import Data.Map (Map) import Data.Semigroup (sconcat, (<>)) -import Data.Text.Lazy (Text) -import Data.Text.Lazy.Builder (Builder) +import Data.Text (Text) #if MIN_VERSION_base(4,8,0) #else import Data.Traversable (traverse) #endif import Data.Typeable (Typeable) -import Formatting.Buildable (build) import System.FilePath (()) import Dhall.Core ( Expr(..) @@ -146,46 +143,38 @@ , ImportMode(..) , Import(..) ) +#ifdef MIN_VERSION_http_client +import Dhall.Import.HTTP +#endif +import Dhall.Import.Types + import Dhall.Parser (Parser(..), ParseError(..), Src(..)) import Dhall.TypeCheck (X(..)) -import Lens.Family (LensLike') import Lens.Family.State.Strict (zoom) -#if MIN_VERSION_http_client(0,5,0) -import Network.HTTP.Client - (HttpException(..), HttpExceptionContent(..), Manager) -#else -import Network.HTTP.Client (HttpException(..), Manager) -#endif -import qualified Control.Monad.Trans.State.Strict as State +import qualified Control.Monad.Trans.State.Strict as State import qualified Crypto.Hash import qualified Data.ByteString import qualified Data.CaseInsensitive import qualified Data.Foldable -import qualified Data.List as List + +import qualified Data.List as List import qualified Data.HashMap.Strict.InsOrd -import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as Map import qualified Data.Text.Encoding -import qualified Data.Text.Lazy as Text -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Text.Lazy.Encoding -import qualified Data.Text.Lazy.IO +import qualified Data.Text as Text +import qualified Data.Text.IO import qualified Dhall.Core import qualified Dhall.Parser import qualified Dhall.Context +import qualified Dhall.Pretty.Internal import qualified Dhall.TypeCheck -import qualified Network.HTTP.Client as HTTP -import qualified Network.HTTP.Client.TLS as HTTP import qualified System.Environment import qualified System.Directory -import qualified System.FilePath as FilePath import qualified Text.Megaparsec import qualified Text.Parser.Combinators import qualified Text.Parser.Token -builderToString :: Builder -> String -builderToString = Text.unpack . Builder.toLazyText - -- | An import failed because of a cycle in the import graph newtype Cycle = Cycle { cyclicImport :: Import -- ^ The offending cyclic import @@ -196,7 +185,7 @@ instance Show Cycle where show (Cycle import_) = - "\nCyclic import: " ++ builderToString (build import_) + "\nCyclic import: " ++ Dhall.Pretty.Internal.prettyToString import_ {-| Dhall tries to ensure that all expressions hosted on network endpoints are weakly referentially transparent, meaning roughly that any two clients will @@ -232,7 +221,7 @@ instance Show ReferentiallyOpaque where show (ReferentiallyOpaque import_) = - "\nReferentially opaque import: " ++ builderToString (build import_) + "\nReferentially opaque import: " ++ Dhall.Pretty.Internal.prettyToString import_ -- | Extend another exception with the current import stack data Imported e = Imported @@ -249,56 +238,11 @@ ++ show e where indent (n, import_) = - take (2 * n) (repeat ' ') ++ "↳ " ++ builderToString (build import_) + take (2 * n) (repeat ' ') ++ "↳ " ++ Dhall.Pretty.Internal.prettyToString import_ -- Canonicalize all imports imports' = zip [0..] (drop 1 (reverse (canonicalizeAll imports))) --- | Newtype used to wrap `HttpException`s with a prettier `Show` instance -newtype PrettyHttpException = PrettyHttpException HttpException - deriving (Typeable) -instance Exception PrettyHttpException - -#if MIN_VERSION_http_client(0,5,0) -instance Show PrettyHttpException where - show (PrettyHttpException (InvalidUrlException _ r)) = - "\n" - <> "\ESC[1;31mError\ESC[0m: Invalid URL\n" - <> "\n" - <> "↳ " <> show r - show (PrettyHttpException (HttpExceptionRequest _ e)) = case e of - ConnectionFailure e' -> - "\n" - <> "\ESC[1;31mError\ESC[0m: Wrong host\n" - <> "\n" - <> "↳ " <> show e' - InvalidDestinationHost host -> - "\n" - <> "\ESC[1;31mError\ESC[0m: Invalid host name\n" - <> "\n" - <> "↳ " <> show host - ResponseTimeout -> - "\ESC[1;31mError\ESC[0m: The host took too long to respond\n" - e' -> "\n" <> show e' -#else -instance Show PrettyHttpException where - show (PrettyHttpException e) = case e of - FailedConnectionException2 _ _ _ e' -> - "\n" - <> "\ESC[1;31mError\ESC[0m: Wrong host\n" - <> "\n" - <> "↳ " <> show e' - InvalidDestinationHost host -> - "\n" - <> "\ESC[1;31mError\ESC[0m: Invalid host name\n" - <> "\n" - <> "↳ " <> show host - ResponseTimeout -> - "\ESC[1;31mError\ESC[0m: The host took too long to respond\n" - e' -> "\n" - <> show e' -#endif - -- | Exception thrown when an imported file is missing data MissingFile = MissingFile FilePath deriving (Typeable) @@ -325,56 +269,61 @@ <> "\n" <> "↳ " <> Text.unpack name --- | State threaded throughout the import process -data Status = Status - { _stack :: [Import] - -- ^ Stack of `Import`s that we've imported along the way to get to the - -- current point - , _cache :: Map Import (Expr Src X) - -- ^ Cache of imported expressions in order to avoid importing the same - -- expression twice with different values - , _manager :: Maybe Manager - -- ^ Cache for the `Manager` so that we only acquire it once - } +-- | List of Exceptions we encounter while resolving Import Alternatives +newtype MissingImports = MissingImports [SomeException] --- | Default starting `Status` -emptyStatus :: Status -emptyStatus = Status [] Map.empty Nothing +instance Exception MissingImports -canonicalizeAll :: [Import] -> [Import] -canonicalizeAll = map canonicalizeImport . List.tails +instance Show MissingImports where + show (MissingImports []) = + "\n" + <> "\ESC[1;31mError\ESC[0m: No valid imports" + <> "\n" + show (MissingImports [e]) = show e + show (MissingImports es) = + "\n" + <> "\ESC[1;31mError\ESC[0m: Failed to resolve imports. Error list:" + <> "\n" + <> concatMap (\e -> "\n" <> show e <> "\n") es + <> "\n" -stack :: Functor f => LensLike' f Status [Import] -stack k s = fmap (\x -> s { _stack = x }) (k (_stack s)) +throwMissingImport :: (MonadCatch m, Exception e) => e -> m a +throwMissingImport e = throwM (MissingImports [(toException e)]) -cache :: Functor f => LensLike' f Status (Map Import (Expr Src X)) -cache k s = fmap (\x -> s { _cache = x }) (k (_cache s)) -manager :: Functor f => LensLike' f Status (Maybe Manager) -manager k s = fmap (\x -> s { _manager = x }) (k (_manager s)) +-- | Exception thrown when a HTTP url is imported but dhall was built without +-- the @with-http@ Cabal flag. +data CannotImportHTTPURL = + CannotImportHTTPURL + String + (Maybe [(CI Data.ByteString.ByteString, Data.ByteString.ByteString)]) + deriving (Typeable) -needManager :: StateT Status IO Manager -needManager = do - x <- zoom manager State.get - case x of - Just m -> return m - Nothing -> do - let settings = HTTP.tlsManagerSettings -#if MIN_VERSION_http_client(0,5,0) - { HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (30 * 1000 * 1000) } -- 30 seconds -#else - { HTTP.managerResponseTimeout = Just (30 * 1000 * 1000) } -- 30 seconds -#endif - m <- liftIO (HTTP.newManager settings) - zoom manager (State.put (Just m)) - return m +instance Exception CannotImportHTTPURL +instance Show CannotImportHTTPURL where + show (CannotImportHTTPURL url _mheaders) = + "\n" + <> "\ESC[1;31mError\ESC[0m: Cannot import HTTP URL.\n" + <> "\n" + <> "Dhall was compiled without the 'with-http' flag.\n" + <> "\n" + <> "The requested URL was: " + <> url + <> "\n" + +canonicalizeAll :: [Import] -> [Import] +canonicalizeAll = map canonicalizeImport . List.tails + {-| > canonicalize (canonicalize x) = canonicalize x -} class Canonicalize path where canonicalize :: path -> path +-- | +-- >>> canonicalize (Directory {components = ["..",".."]}) +-- Directory {components = ["..",".."]} instance Canonicalize Directory where canonicalize (Directory []) = Directory [] @@ -383,8 +332,12 @@ canonicalize (Directory (".." : components₀)) = case canonicalize (Directory components₀) of - Directory [] -> Directory [ ".." ] - Directory (_ : components₁) -> Directory components₁ + Directory [] -> + Directory [ ".." ] + Directory (".." : components₁) -> + Directory (".." : ".." : components₁) + Directory (_ : components₁) -> + Directory components₁ canonicalize (Directory (component : components₀)) = Directory (component : components₁) @@ -405,6 +358,9 @@ canonicalize (Env name) = Env name + canonicalize Missing = + Missing + instance Canonicalize ImportHashed where canonicalize (ImportHashed hash importType) = ImportHashed hash (canonicalize importType) @@ -439,10 +395,8 @@ :: Expr s a -> Maybe (CI Data.ByteString.ByteString, Data.ByteString.ByteString) toHeader (RecordLit m) = do - TextLit (Chunks [] keyBuilder ) <- Data.HashMap.Strict.InsOrd.lookup "header" m - TextLit (Chunks [] valueBuilder) <- Data.HashMap.Strict.InsOrd.lookup "value" m - let keyText = Text.toStrict (Builder.toLazyText keyBuilder ) - let valueText = Text.toStrict (Builder.toLazyText valueBuilder) + TextLit (Chunks [] keyText ) <- Data.HashMap.Strict.InsOrd.lookup "header" m + TextLit (Chunks [] valueText) <- Data.HashMap.Strict.InsOrd.lookup "value" m let keyBytes = Data.Text.Encoding.encodeUtf8 keyText let valueBytes = Data.Text.Encoding.encodeUtf8 valueText return (Data.CaseInsensitive.mk keyBytes, valueBytes) @@ -450,38 +404,6 @@ empty -{-| This exception indicates that there was an internal error in Dhall's - import-related logic - the `expected` type then the `extract` function must succeed. If not, then - this exception is thrown - - This exception indicates that an invalid `Type` was provided to the `input` - function --} -data InternalError = InternalError deriving (Typeable) - -_ERROR :: String -_ERROR = "\ESC[1;31mError\ESC[0m" - -instance Show InternalError where - show InternalError = unlines - [ _ERROR <> ": Compiler bug " - , " " - , "Explanation: This error message means that there is a bug in the Dhall compiler." - , "You didn't do anything wrong, but if you would like to see this problem fixed " - , "then you should report the bug at: " - , " " - , "https://github.com/dhall-lang/dhall-haskell/issues " - , " " - , "Please include the following text in your bug report: " - , " " - , "``` " - , "Header extraction failed even though the header type-checked " - , "``` " - ] - -instance Exception InternalError - -- | Exception thrown when an integrity check fails data HashMismatch = HashMismatch { expectedHash :: Crypto.Hash.Digest SHA256 @@ -519,10 +441,6 @@ Absolute -> do return "/" - Parent -> do - pwd <- System.Directory.getCurrentDirectory - return (FilePath.takeDirectory pwd) - Here -> do System.Directory.getCurrentDirectory @@ -536,26 +454,25 @@ if exists then return () - else throwIO (MissingFile path) + else throwMissingImport (MissingFile path) - text <- Data.Text.Lazy.IO.readFile path + text <- Data.Text.IO.readFile path return (path, text) URL prefix file suffix maybeHeaders -> do - m <- needManager - - let fileText = Builder.toLazyText (build file) + let fileText = Dhall.Pretty.Internal.prettyToStrictText file let url = Text.unpack (prefix <> fileText <> suffix) - request <- liftIO (HTTP.parseUrlThrow url) - - requestWithHeaders <- case maybeHeaders of - Nothing -> return request + mheaders <- case maybeHeaders of + Nothing -> return Nothing Just importHashed_ -> do - expr <- loadStaticIO Dhall.Context.empty - (const Nothing) - (Import importHashed_ Code) + expr <- loadStaticWith + exprFromImport + Dhall.Context.empty + (const Nothing) + (Embed (Import importHashed_ Code)) + let expected :: Expr Src X expected = App List @@ -564,10 +481,7 @@ [("header", Text), ("value", Text)] ) ) - let suffix_ = - ( Builder.toLazyText - . build - ) expected + let suffix_ = Dhall.Pretty.Internal.prettyToStrictText expected let annot = case expr of Note (Src begin end bytes) _ -> Note (Src begin end bytes') (Annot expr expected) @@ -582,32 +496,27 @@ let expr' = Dhall.Core.normalize expr - headers <- case toHeaders expr' of + case toHeaders expr' of Just headers -> do - return headers + return (Just headers) Nothing -> do liftIO (throwIO InternalError) - let requestWithHeaders = request - { HTTP.requestHeaders = headers - } - - return requestWithHeaders - - response <- liftIO (HTTP.httpLbs requestWithHeaders m) - - let bytes = HTTP.responseBody response - - case Data.Text.Lazy.Encoding.decodeUtf8' bytes of - Left err -> liftIO (throwIO err) - Right text -> return (url, text) +#ifdef MIN_VERSION_http_client + fetchFromHttpUrl url mheaders +#else + liftIO (throwIO (CannotImportHTTPURL url mheaders)) +#endif Env env -> liftIO $ do x <- System.Environment.lookupEnv (Text.unpack env) case x of Just string -> return (Text.unpack env, Text.pack string) - Nothing -> throwIO (MissingEnvironmentVariable env) + Nothing -> throwMissingImport (MissingEnvironmentVariable env) + Missing -> liftIO $ do + throwM (MissingImports []) + case importMode of Code -> do let parser = unParser $ do @@ -623,29 +532,7 @@ return expr RawText -> do - return (TextLit (Chunks [] (build text))) - -{-| Load an `Import` as a \"dynamic\" expression (without resolving any imports) --} -loadDynamic - :: forall m . MonadCatch m - => (Import -> StateT Status m (Expr Src Import)) - -> Import - -> StateT Status m (Expr Src Import) -loadDynamic from_import import_ = do - imports <- zoom stack State.get - - let handler :: SomeException -> StateT Status m (Expr Src Import) - handler e = throwM (Imported (import_:imports) e) - - from_import (canonicalizeImport (import_:imports)) `catch` handler - -loadStaticIO - :: Dhall.Context.Context (Expr Src X) - -> Dhall.Core.Normalizer X - -> Import - -> StateT Status IO (Expr Src X) -loadStaticIO = loadStaticWith exprFromImport + return (TextLit (Chunks [] text)) -- | Resolve all imports within an expression using a custom typing context and -- `Import`-resolving callback in arbitrary `MonadCatch` monad. @@ -656,7 +543,8 @@ -> Dhall.Core.Normalizer X -> Expr Src Import -> m (Expr Src X) -loadWith from_import ctx n = evalStatus (loadStaticWith from_import ctx n) +loadWith from_import ctx n expr = + State.evalStateT (loadStaticWith from_import ctx n expr) emptyStatus -- | Resolve all imports within an expression using a custom typing context. -- @@ -666,48 +554,78 @@ -> Dhall.Core.Normalizer X -> Expr Src Import -> IO (Expr Src X) -loadWithContext ctx n = evalStatus (loadStaticIO ctx n) +loadWithContext ctx n expr = + State.evalStateT (loadStaticWith exprFromImport ctx n expr) emptyStatus +-- | This loads a \"static\" expression (i.e. an expression free of imports) loadStaticWith :: MonadCatch m => (Import -> StateT Status m (Expr Src Import)) -> Dhall.Context.Context (Expr Src X) -> Dhall.Core.Normalizer X - -> Import + -> Expr Src Import -> StateT Status m (Expr Src X) -loadStaticWith from_import ctx n import_ = do +loadStaticWith from_import ctx n expr₀ = case expr₀ of + Embed import_ -> do imports <- zoom stack State.get - let local (Import (ImportHashed _ (URL {})) _) = False - local (Import (ImportHashed _ (Local {})) _) = True - local (Import (ImportHashed _ (Env {})) _) = True + let local (Import (ImportHashed _ (URL {})) _) = False + local (Import (ImportHashed _ (Local {})) _) = True + local (Import (ImportHashed _ (Env {})) _) = True + local (Import (ImportHashed _ (Missing {})) _) = True let parent = canonicalizeImport imports let here = canonicalizeImport (import_:imports) if local here && not (local parent) - then throwM (Imported imports (ReferentiallyOpaque import_)) + then throwMissingImport (Imported imports (ReferentiallyOpaque import_)) else return () expr <- if here `elem` canonicalizeAll imports - then throwM (Imported imports (Cycle import_)) + then throwMissingImport (Imported imports (Cycle import_)) else do m <- zoom cache State.get case Map.lookup here m of Just expr -> return expr Nothing -> do - expr' <- loadDynamic from_import import_ - expr'' <- case traverse (\_ -> Nothing) expr' of - -- No imports left - Just expr -> return expr - -- Some imports left, so recurse - Nothing -> do - let imports' = import_:imports - zoom stack (State.put imports') - expr'' <- fmap join (traverse (loadStaticWith from_import ctx n) - expr') - zoom stack (State.put imports) - return expr'' + -- Here we have to match and unwrap the @MissingImports@ + -- in a separate handler, otherwise we'd have it wrapped + -- in another @Imported@ when parsing a @missing@, because + -- we are representing it with an empty exception list + -- (which would not be empty if this would happen). + -- TODO: restructure the Exception hierarchy to prevent + -- this nesting from happening in the first place. + let handler₀ + :: (MonadCatch m) + => MissingImports + -> StateT Status m (Expr Src Import) + handler₀ e@(MissingImports []) = throwM e + handler₀ (MissingImports [e]) = + throwMissingImport (Imported (import_:imports) e) + handler₀ (MissingImports es) = throwM + (MissingImports + (fmap + (\e -> (toException (Imported (import_:imports) e))) + es)) + handler₁ + :: (MonadCatch m) + => SomeException + -> StateT Status m (Expr Src Import) + handler₁ e = + throwMissingImport (Imported (import_:imports) e) + + -- This loads a \"dynamic\" expression (i.e. an expression + -- that might still contain imports) + let loadDynamic = + from_import (canonicalizeImport (import_:imports)) + + expr' <- loadDynamic `catches` [ Handler handler₀, Handler handler₁ ] + + let imports' = import_:imports + zoom stack (State.put imports') + expr'' <- loadStaticWith from_import ctx n expr' + zoom stack (State.put imports) + -- Type-check expressions here for three separate reasons: -- -- * to verify that they are closed @@ -731,14 +649,80 @@ let actualHash = hashExpression expr if expectedHash == actualHash then return () - else throwM (Imported (import_:imports) (HashMismatch {..})) + else throwMissingImport (Imported (import_:imports) (HashMismatch {..})) return expr + ImportAlt a b -> loop a `catch` handler₀ + where + handler₀ (MissingImports es₀) = + loop b `catch` handler₁ + where + handler₁ (MissingImports es₁) = + throwM (MissingImports (es₀ ++ es₁)) + Const a -> pure (Const a) + Var a -> pure (Var a) + Lam a b c -> Lam <$> pure a <*> loop b <*> loop c + Pi a b c -> Pi <$> pure a <*> loop b <*> loop c + App a b -> App <$> loop a <*> loop b + Let a b c d -> Let <$> pure a <*> mapM loop b <*> loop c <*> loop d + Annot a b -> Annot <$> loop a <*> loop b + Bool -> pure Bool + BoolLit a -> pure (BoolLit a) + BoolAnd a b -> BoolAnd <$> loop a <*> loop b + BoolOr a b -> BoolOr <$> loop a <*> loop b + BoolEQ a b -> BoolEQ <$> loop a <*> loop b + BoolNE a b -> BoolNE <$> loop a <*> loop b + BoolIf a b c -> BoolIf <$> loop a <*> loop b <*> loop c + Natural -> pure Natural + NaturalLit a -> pure (NaturalLit a) + NaturalFold -> pure NaturalFold + NaturalBuild -> pure NaturalBuild + NaturalIsZero -> pure NaturalIsZero + NaturalEven -> pure NaturalEven + NaturalOdd -> pure NaturalOdd + NaturalToInteger -> pure NaturalToInteger + NaturalShow -> pure NaturalShow + NaturalPlus a b -> NaturalPlus <$> loop a <*> loop b + NaturalTimes a b -> NaturalTimes <$> loop a <*> loop b + Integer -> pure Integer + IntegerLit a -> pure (IntegerLit a) + IntegerShow -> pure IntegerShow + IntegerToDouble -> pure IntegerToDouble + Double -> pure Double + DoubleLit a -> pure (DoubleLit a) + DoubleShow -> pure DoubleShow + Text -> pure Text + TextLit (Chunks a b) -> fmap TextLit (Chunks <$> mapM (mapM loop) a <*> pure b) + TextAppend a b -> TextAppend <$> loop a <*> loop b + List -> pure List + ListLit a b -> ListLit <$> mapM loop a <*> mapM loop b + ListAppend a b -> ListAppend <$> loop a <*> loop b + ListBuild -> pure ListBuild + ListFold -> pure ListFold + ListLength -> pure ListLength + ListHead -> pure ListHead + ListLast -> pure ListLast + ListIndexed -> pure ListIndexed + ListReverse -> pure ListReverse + Optional -> pure Optional + OptionalLit a b -> OptionalLit <$> loop a <*> mapM loop b + OptionalFold -> pure OptionalFold + OptionalBuild -> pure OptionalBuild + Record a -> Record <$> mapM loop a + RecordLit a -> RecordLit <$> mapM loop a + Union a -> Union <$> mapM loop a + UnionLit a b c -> UnionLit <$> pure a <*> loop b <*> mapM loop c + Combine a b -> Combine <$> loop a <*> loop b + CombineTypes a b -> CombineTypes <$> loop a <*> loop b + Prefer a b -> Prefer <$> loop a <*> loop b + Merge a b c -> Merge <$> loop a <*> loop b <*> mapM loop c + Constructors a -> Constructors <$> loop a + Field a b -> Field <$> loop a <*> pure b + Project a b -> Project <$> loop a <*> pure b + Note a b -> Note <$> pure a <*> loop b + where + loop = loadStaticWith from_import ctx n -evalStatus - :: (Traversable f, Monad m, Monad f) - => (a -> StateT Status m (f b)) -> f a -> m (f b) -evalStatus cb expr = State.evalStateT (fmap join (traverse cb expr)) emptyStatus -- | Resolve all imports within an expression load :: Expr Src Import -> IO (Expr Src X) @@ -746,10 +730,10 @@ -- | Hash a fully resolved expression hashExpression :: Expr s X -> (Crypto.Hash.Digest SHA256) -hashExpression expr = Crypto.Hash.hashlazy actualBytes +hashExpression expr = Crypto.Hash.hash actualBytes where text = Dhall.Core.pretty (Dhall.Core.normalize expr) - actualBytes = Data.Text.Lazy.Encoding.encodeUtf8 text + actualBytes = Data.Text.Encoding.encodeUtf8 text {-| Convenience utility to hash a fully resolved expression and return the base-16 encoded hash with the @sha256:@ prefix diff --git a/src/Dhall/Import/HTTP.hs b/src/Dhall/Import/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Import/HTTP.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Dhall.Import.HTTP where + +import Control.Exception (throwIO) +import Control.Monad (join) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.State.Strict (StateT) +import Data.ByteString (ByteString) +import Data.CaseInsensitive (CI) +import Data.Dynamic (fromDynamic, toDyn) +import Data.Semigroup ((<>)) +import Lens.Family.State.Strict (zoom) + +import qualified Control.Monad.Trans.State.Strict as State +import qualified Data.Text as Text +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Encoding + +import Dhall.Import.Types + +#if MIN_VERSION_http_client(0,5,0) +import Network.HTTP.Client + (HttpException(..), HttpExceptionContent(..), Manager) +#else +import Network.HTTP.Client (HttpException(..), Manager) +#endif + +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client.TLS as HTTP + +mkPrettyHttpException :: HttpException -> PrettyHttpException +mkPrettyHttpException ex = + PrettyHttpException (renderPrettyHttpException ex) (toDyn ex) + +renderPrettyHttpException :: HttpException -> String +#if MIN_VERSION_http_client(0,5,0) +renderPrettyHttpException (InvalidUrlException _ r) = + "\n" + <> "\ESC[1;31mError\ESC[0m: Invalid URL\n" + <> "\n" + <> "↳ " <> show r +renderPrettyHttpException (HttpExceptionRequest _ e) = + case e of + ConnectionFailure e' -> + "\n" + <> "\ESC[1;31mError\ESC[0m: Wrong host\n" + <> "\n" + <> "↳ " <> show e' + InvalidDestinationHost host -> + "\n" + <> "\ESC[1;31mError\ESC[0m: Invalid host name\n" + <> "\n" + <> "↳ " <> show host + ResponseTimeout -> + "\ESC[1;31mError\ESC[0m: The host took too long to respond\n" + e' -> "\n" <> show e' +#else +renderPrettyHttpException e = case e of + FailedConnectionException2 _ _ _ e' -> + "\n" + <> "\ESC[1;31mError\ESC[0m: Wrong host\n" + <> "\n" + <> "↳ " <> show e' + InvalidDestinationHost host -> + "\n" + <> "\ESC[1;31mError\ESC[0m: Invalid host name\n" + <> "\n" + <> "↳ " <> show host + ResponseTimeout -> + "\ESC[1;31mError\ESC[0m: The host took too long to respond\n" + e' -> "\n" + <> show e' +#endif + +needManager :: StateT Status IO Manager +needManager = do + x <- zoom manager State.get + case join (fmap fromDynamic x) of + Just m -> return m + Nothing -> do + let settings = HTTP.tlsManagerSettings + +#ifdef MIN_VERSION_http_client +#if MIN_VERSION_http_client(0,5,0) + { HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (30 * 1000 * 1000) } -- 30 seconds +#else + { HTTP.managerResponseTimeout = Just (30 * 1000 * 1000) } -- 30 seconds +#endif +#endif + m <- liftIO (HTTP.newManager settings) + zoom manager (State.put (Just (toDyn m))) + return m + +fetchFromHttpUrl + :: String + -> Maybe [(CI ByteString, ByteString)] + -> StateT Status IO (String, Text.Text) +fetchFromHttpUrl url mheaders = do + m <- needManager + + request <- liftIO (HTTP.parseUrlThrow url) + + let requestWithHeaders = + case mheaders of + Nothing -> request + Just headers -> request { HTTP.requestHeaders = headers } + + response <- liftIO (HTTP.httpLbs requestWithHeaders m) + + let bytes = HTTP.responseBody response + + case Data.Text.Lazy.Encoding.decodeUtf8' bytes of + Left err -> liftIO (throwIO err) + Right text -> return (url, Data.Text.Lazy.toStrict text) diff --git a/src/Dhall/Import/Types.hs b/src/Dhall/Import/Types.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Import/Types.hs @@ -0,0 +1,89 @@ +{-# OPTIONS_GHC -Wall #-} + +module Dhall.Import.Types where + +import Control.Exception (Exception) +import Data.Dynamic +import Data.Map (Map) +import Data.Semigroup ((<>)) +import Lens.Family (LensLike') + +import qualified Data.Map as Map + +import Dhall.Core (Import, Expr) +import Dhall.Parser (Src) +import Dhall.TypeCheck (X) + + +-- | State threaded throughout the import process +data Status = Status + { _stack :: [Import] + -- ^ Stack of `Import`s that we've imported along the way to get to the + -- current point + , _cache :: Map Import (Expr Src X) + -- ^ Cache of imported expressions in order to avoid importing the same + -- expression twice with different values + , _manager :: Maybe Dynamic + -- ^ Cache for the HTTP `Manager` so that we only acquire it once + } + +-- | Default starting `Status` +emptyStatus :: Status +emptyStatus = Status [] Map.empty Nothing + +stack :: Functor f => LensLike' f Status [Import] +stack k s = fmap (\x -> s { _stack = x }) (k (_stack s)) + +cache :: Functor f => LensLike' f Status (Map Import (Expr Src X)) +cache k s = fmap (\x -> s { _cache = x }) (k (_cache s)) + +manager :: Functor f => LensLike' f Status (Maybe Dynamic) +manager k s = fmap (\x -> s { _manager = x }) (k (_manager s)) + + + +{-| This exception indicates that there was an internal error in Dhall's + import-related logic + the `expected` type then the `extract` function must succeed. If not, then + this exception is thrown + + This exception indicates that an invalid `Type` was provided to the `input` + function +-} +data InternalError = InternalError deriving (Typeable) + + +instance Show InternalError where + show InternalError = unlines + [ _ERROR <> ": Compiler bug " + , " " + , "Explanation: This error message means that there is a bug in the Dhall compiler." + , "You didn't do anything wrong, but if you would like to see this problem fixed " + , "then you should report the bug at: " + , " " + , "https://github.com/dhall-lang/dhall-haskell/issues " + , " " + , "Please include the following text in your bug report: " + , " " + , "``` " + , "Header extraction failed even though the header type-checked " + , "``` " + ] + where + _ERROR :: String + _ERROR = "\ESC[1;31mError\ESC[0m" + +instance Exception InternalError + +-- | Wrapper around `HttpException`s with a prettier `Show` instance. +-- +-- In order to keep the library API constant even when the @with-http@ Cabal +-- flag is disabled the pretty error message is pre-rendered and the real +-- 'HttpExcepion' is stored in a 'Dynamic' +data PrettyHttpException = PrettyHttpException String Dynamic + deriving (Typeable) + +instance Exception PrettyHttpException + +instance Show PrettyHttpException where + show (PrettyHttpException msg _) = msg diff --git a/src/Dhall/Lint.hs b/src/Dhall/Lint.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Lint.hs @@ -0,0 +1,222 @@ +module Dhall.Lint + ( -- * Lint + lint + ) where + +import Dhall.Core (Chunks(..), Expr(..), Import, Var(..)) +import Dhall.TypeCheck (X(..)) + +import qualified Dhall.Core + +lint :: Expr s Import -> Expr t Import +lint expression = loop (Dhall.Core.denote expression) + where + loop (Const a) = + Const a + loop (Var a) = + Var a + loop (Lam a b c) = Lam a b' c' + where + b' = loop b + c' = loop c + loop (Pi a b c) = Pi a b' c' + where + b' = loop b + c' = loop c + loop (App a b) = App a' b' + where + a' = loop a + b' = loop b + loop (Let a b c d) + | not (V a 0 `Dhall.Core.freeIn` d) = + loop d + | otherwise = + Let a b' c' d' + where + b' = fmap loop b + c' = loop c + d' = loop d + loop (Annot a b) = + Annot a' b' + where + a' = loop a + b' = loop b + loop Bool = + Bool + loop (BoolLit a) = + BoolLit a + loop (BoolAnd a b) = + BoolAnd a' b' + where + a' = loop a + b' = loop b + loop (BoolOr a b) = + BoolOr a' b' + where + a' = loop a + b' = loop b + loop (BoolEQ a b) = + BoolEQ a' b' + where + a' = loop a + b' = loop b + loop (BoolNE a b) = + BoolNE a' b' + where + a' = loop a + b' = loop b + loop (BoolIf a b c) = + BoolIf a' b' c' + where + a' = loop a + b' = loop b + c' = loop c + loop Natural = + Natural + loop (NaturalLit a) = + NaturalLit a + loop NaturalFold = + NaturalFold + loop NaturalBuild = + NaturalBuild + loop NaturalIsZero = + NaturalIsZero + loop NaturalEven = + NaturalEven + loop NaturalOdd = + NaturalOdd + loop NaturalToInteger = + NaturalToInteger + loop NaturalShow = + NaturalShow + loop (NaturalPlus a b) = + NaturalPlus a' b' + where + a' = loop a + b' = loop b + loop (NaturalTimes a b) = + NaturalTimes a' b' + where + a' = loop a + b' = loop b + loop Integer = + Integer + loop (IntegerLit a) = + IntegerLit a + loop IntegerShow = + IntegerShow + loop IntegerToDouble = + IntegerToDouble + loop Double = + Double + loop (DoubleLit a) = + DoubleLit a + loop DoubleShow = + DoubleShow + loop Text = + Text + loop (TextLit (Chunks a b)) = + TextLit (Chunks a' b) + where + a' = fmap (fmap loop) a + loop (TextAppend a b) = + TextAppend a' b' + where + a' = loop a + b' = loop b + loop List = + List + loop (ListLit a b) = + ListLit a' b' + where + a' = fmap loop a + b' = fmap loop b + loop (ListAppend a b) = + ListAppend a' b' + where + a' = loop a + b' = loop b + loop ListBuild = + ListBuild + loop ListFold = + ListFold + loop ListLength = + ListLength + loop ListHead = + ListHead + loop ListLast = + ListLast + loop ListIndexed = + ListIndexed + loop ListReverse = + ListReverse + loop Optional = + Optional + loop (OptionalLit a b) = + OptionalLit a' b' + where + a' = loop a + b' = fmap loop b + loop OptionalFold = + OptionalFold + loop OptionalBuild = + OptionalBuild + loop (Record a) = + Record a' + where + a' = fmap loop a + loop (RecordLit a) = + RecordLit a' + where + a' = fmap loop a + loop (Union a) = + Union a' + where + a' = fmap loop a + loop (UnionLit a b c) = + UnionLit a b' c' + where + b' = loop b + c' = fmap loop c + loop (Combine a b) = + Combine a' b' + where + a' = loop a + b' = loop b + loop (CombineTypes a b) = + CombineTypes a' b' + where + a' = loop a + b' = loop b + loop (Prefer a b) = + Prefer a' b' + where + a' = loop a + b' = loop b + loop (Merge a b c) = + Merge a' b' c' + where + a' = loop a + b' = loop b + c' = fmap loop c + loop (Constructors a) = + Constructors a' + where + a' = loop a + loop (Field a b) = + Field a' b + where + a' = loop a + loop (Project a b) = + Project a' b + where + a' = loop a + loop (Note a _) = + absurd a + loop (ImportAlt a b) = + ImportAlt a' b' + where + a' = loop a + b' = loop b + loop (Embed a) = + Embed a diff --git a/src/Dhall/Main.hs b/src/Dhall/Main.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Main.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Dhall.Main + ( -- Commands + parseOptions + , parserInfoOptions + , command + , main + ) where + +import Control.Applicative (optional, (<|>)) +import Control.Exception (Exception, SomeException) +import Data.Monoid (mempty, (<>)) +import Data.Text (Text) +import Data.Text.Prettyprint.Doc (Pretty) +import Data.Version (showVersion) +import Dhall.Core (Expr, Import) +import Dhall.Import (Imported(..), load) +import Dhall.Parser (Src) +import Dhall.Pretty (annToAnsiStyle, prettyExpr) +import Dhall.TypeCheck (DetailedTypeError(..), TypeError, X) +import Options.Applicative (Parser, ParserInfo) +import System.Exit (exitFailure) +import System.IO (Handle) + +import qualified Paths_dhall as Meta + +import qualified Control.Exception +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 Dhall +import qualified Dhall.Core +import qualified Dhall.Diff +import qualified Dhall.Format +import qualified Dhall.Freeze +import qualified Dhall.Hash +import qualified Dhall.Lint +import qualified Dhall.Parser +import qualified Dhall.Repl +import qualified Dhall.TypeCheck +import qualified Options.Applicative +import qualified System.Console.ANSI +import qualified System.IO + +data Options = Options + { mode :: Mode + , explain :: Bool + , plain :: Bool + } + +data Mode + = Default + | Version + | Resolve + | Type + | Normalize + | Repl + | Format (Maybe FilePath) + | Freeze (Maybe FilePath) + | Hash + | Diff Text Text + | Lint (Maybe FilePath) + +parseInplace :: Parser String +parseInplace = + Options.Applicative.strOption + ( Options.Applicative.long "inplace" + <> Options.Applicative.help "Modify the specified file in-place" + <> Options.Applicative.metavar "FILE" + ) + +parseOptions :: Parser Options +parseOptions = Options <$> parseMode <*> parseExplain <*> parsePlain + where + parseExplain = + Options.Applicative.switch + ( Options.Applicative.long "explain" + <> Options.Applicative.help "Explain error messages in more detail" + ) + + parsePlain = + Options.Applicative.switch + ( Options.Applicative.long "plain" + <> Options.Applicative.help "Disable syntax highlighting" + ) + + +parseMode :: Parser Mode +parseMode = + subcommand "version" "Display version" (pure Version) + <|> subcommand "resolve" "Resolve an expression's imports" (pure Resolve) + <|> subcommand "type" "Infer an expression's type" (pure Type) + <|> subcommand "normalize" "Normalize an expression" (pure Normalize) + <|> subcommand "repl" "Interpret expressions in a REPL" (pure Repl) + <|> subcommand "diff" "Render the difference between the normal form of two expressions" diffParser + <|> subcommand "hash" "Compute semantic hashes for Dhall expressions" (pure Hash) + <|> subcommand "lint" "Improve Dhall code" parseLint + <|> formatSubcommand + <|> freezeSubcommand + <|> pure Default + where + subcommand name description modeParser = + Options.Applicative.subparser + ( Options.Applicative.command name parserInfo + <> Options.Applicative.metavar name + ) + where + parserInfo = + Options.Applicative.info parser + ( Options.Applicative.fullDesc + <> Options.Applicative.progDesc description + ) + + parser = + Options.Applicative.helper <*> modeParser + + diffParser = + Diff <$> argument "expr1" <*> argument "expr2" + where + argument = + fmap Data.Text.pack + . Options.Applicative.strArgument + . Options.Applicative.metavar + + parseLint = + Lint <$> optional parseInplace + + formatSubcommand = + Options.Applicative.hsubparser + ( Options.Applicative.command "format" parserInfo + <> Options.Applicative.metavar "format" + ) + where parserInfo = + Options.Applicative.info parserWithHelper + ( Options.Applicative.fullDesc + <> Options.Applicative.progDesc "Formatter for the Dhall language" + ) + parserWithHelper = Options.Applicative.helper <*> parser + parser = Format <$> optional parseInplace + + freezeSubcommand = subcommand "freeze" "Add hashes to all import statements of an expression" parseFreeze + where + parseFreeze = Freeze <$> optional parseInplace + +opts :: Pretty.LayoutOptions +opts = + Pretty.defaultLayoutOptions + { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 } + +data ImportResolutionDisabled = ImportResolutionDisabled deriving (Exception) + +instance Show ImportResolutionDisabled where + show _ = "\nImport resolution is disabled" + +throws :: Exception e => Either e a -> IO a +throws (Left e) = Control.Exception.throwIO e +throws (Right a) = return a + +getExpression :: IO (Expr Src Import) +getExpression = do + inText <- Data.Text.IO.getContents + + throws (Dhall.Parser.exprFromText "(stdin)" inText) + +assertNoImports :: Expr Src Import -> IO (Expr Src X) +assertNoImports expression = + throws (traverse (\_ -> Left ImportResolutionDisabled) expression) + +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 + System.IO.hSetEncoding System.IO.stdin System.IO.utf8 + + let handle = + Control.Exception.handle handler2 + . Control.Exception.handle handler1 + . Control.Exception.handle handler0 + where + handler0 e = do + let _ = e :: TypeError Src X + System.IO.hPutStrLn System.IO.stderr "" + if explain + then Control.Exception.throwIO (DetailedTypeError e) + else do + Data.Text.IO.hPutStrLn System.IO.stderr "\ESC[2mUse \"dhall --explain\" for detailed errors\ESC[0m" + Control.Exception.throwIO e + + handler1 (Imported ps e) = do + let _ = e :: TypeError Src X + 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) + + handler2 e = do + let _ = e :: SomeException + System.IO.hSetEncoding System.IO.stderr System.IO.utf8 + System.IO.hPrint System.IO.stderr e + System.Exit.exitFailure + + let render :: Pretty a => Handle -> Expr s a -> IO () + render h e = do + let doc = prettyExpr e + + let layoutOptions = opts + + let stream = Pretty.layoutSmart layoutOptions 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 "" + + handle $ case mode of + Version -> do + putStrLn (showVersion Meta.version) + + Default -> do + expression <- getExpression + + resolvedExpression <- load expression + + inferredType <- throws (Dhall.TypeCheck.typeOf resolvedExpression) + + render System.IO.stderr (Dhall.Core.normalize inferredType) + + Data.Text.IO.hPutStrLn System.IO.stderr mempty + + render System.IO.stdout (Dhall.Core.normalize resolvedExpression) + + Resolve -> do + expression <- getExpression + + resolvedExpression <- load expression + + render System.IO.stdout resolvedExpression + + Normalize -> do + expression <- getExpression + + resolvedExpression <- assertNoImports expression + + _ <- throws (Dhall.TypeCheck.typeOf resolvedExpression) + + render System.IO.stdout (Dhall.Core.normalize resolvedExpression) + + Type -> do + expression <- getExpression + + resolvedExpression <- assertNoImports expression + + inferredType <- throws (Dhall.TypeCheck.typeOf resolvedExpression) + + render System.IO.stdout (Dhall.Core.normalize inferredType) + + Repl -> do + Dhall.Repl.repl explain + + Diff expr1 expr2 -> do + expression1 <- Dhall.inputExpr expr1 + + expression2 <- Dhall.inputExpr expr2 + + let diff = Dhall.Diff.diffNormalized expression1 expression2 + prettyDiff = fmap annToAnsiStyle diff + + Pretty.hPutDoc System.IO.stdout prettyDiff + + Format inplace -> do + Dhall.Format.format inplace + + Freeze inplace -> do + Dhall.Freeze.freeze inplace + + Hash -> do + Dhall.Hash.hash + + Lint inplace -> do + case inplace of + Just file -> do + text <- Data.Text.IO.readFile file + + (header, expression) <- throws (Dhall.Parser.exprAndHeaderFromText file text) + + let lintedExpression = Dhall.Lint.lint expression + + let doc = Pretty.pretty header <> Pretty.pretty lintedExpression + + System.IO.withFile file System.IO.WriteMode (\h -> do + Pretty.renderIO h (Pretty.layoutSmart opts doc) + Data.Text.IO.hPutStrLn h "" ) + Nothing -> do + System.IO.hSetEncoding System.IO.stdin System.IO.utf8 + text <- Data.Text.IO.getContents + + (header, expression) <- throws (Dhall.Parser.exprAndHeaderFromText "(stdin)" text) + + let lintedExpression = Dhall.Lint.lint expression + + let doc = Pretty.pretty header <> prettyExpr lintedExpression + + supportsANSI <- System.Console.ANSI.hSupportsANSI System.IO.stdout + + if supportsANSI + then + Pretty.renderIO + System.IO.stdout + (fmap annToAnsiStyle (Pretty.layoutSmart opts doc)) + else + Pretty.renderIO + System.IO.stdout + (Pretty.layoutSmart opts (Pretty.unAnnotate doc)) + +main :: IO () +main = do + options <- Options.Applicative.execParser parserInfoOptions + command options diff --git a/src/Dhall/Parser.hs b/src/Dhall/Parser.hs --- a/src/Dhall/Parser.hs +++ b/src/Dhall/Parser.hs @@ -1,1639 +1,83 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- | This module contains Dhall's parsing logic - -module Dhall.Parser ( - -- * Utilities - exprFromText - , exprAndHeaderFromText - - -- * Parsers - , expr, exprA - - -- * Types - , Src(..) - , ParseError(..) - , Parser(..) - ) where - -import Control.Applicative (Alternative(..), liftA2, optional) -import Control.Exception (Exception) -import Control.Monad (MonadPlus) -import Data.ByteArray.Encoding (Base(..)) -import Data.Functor (void) -import Data.HashMap.Strict.InsOrd (InsOrdHashMap) -import Data.Scientific (Scientific) -import Data.Semigroup (Semigroup(..)) -import Data.Sequence (ViewL(..)) -import Data.Set (Set) -import Data.String (IsString(..)) -import Data.Text.Lazy (Text) -import Data.Text.Lazy.Builder (Builder) -import Data.Void (Void) -import Dhall.Core -import Formatting.Buildable (Buildable(..)) -import Numeric.Natural (Natural) -import Prelude hiding (const, pi) -import Text.Parser.Combinators (choice, try, ()) -import Text.Parser.Token (TokenParsing(..)) - -import qualified Control.Monad -import qualified Crypto.Hash -import qualified Data.ByteArray.Encoding -import qualified Data.ByteString -import qualified Data.ByteString.Lazy -import qualified Data.Char -import qualified Data.HashMap.Strict.InsOrd -import qualified Data.HashSet -import qualified Data.List -import qualified Data.List.NonEmpty -import qualified Data.Sequence -import qualified Data.Set -import qualified Data.Text -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Builder -import qualified Data.Text.Lazy.Encoding -import qualified Text.Megaparsec -import qualified Text.Megaparsec.Char -import qualified Text.Parser.Char -import qualified Text.Parser.Combinators -import qualified Text.Parser.Token -import qualified Text.Parser.Token.Style - --- | Source code extract -data Src = Src Text.Megaparsec.SourcePos Text.Megaparsec.SourcePos Text - deriving (Eq, Show) - -instance Buildable Src where - build (Src begin _ text) = - build text <> "\n" - <> "\n" - <> build (Text.Megaparsec.sourcePosPretty begin) - <> "\n" - -{-| A `Parser` that is almost identical to - @"Text.Megaparsec".`Text.Megaparsec.Parsec`@ except treating Haskell-style - comments as whitespace --} -newtype Parser a = Parser { unParser :: Text.Megaparsec.Parsec Void Text a } - deriving - ( Functor - , Applicative - , Monad - , Alternative - , MonadPlus - , Text.Megaparsec.MonadParsec Void Text - ) - -instance Data.Semigroup.Semigroup a => Data.Semigroup.Semigroup (Parser a) where - (<>) = liftA2 (<>) - -instance (Data.Semigroup.Semigroup a, Monoid a) => Monoid (Parser a) where - mempty = pure mempty - -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<>) -#endif - -instance IsString a => IsString (Parser a) where - fromString x = fromString x <$ Text.Megaparsec.Char.string (fromString x) - -instance Text.Parser.Combinators.Parsing Parser where - try = Text.Megaparsec.try - - () = (Text.Megaparsec.) - - skipMany = Text.Megaparsec.skipMany - - skipSome = Text.Megaparsec.skipSome - - unexpected = fail - - eof = Parser Text.Megaparsec.eof - - notFollowedBy = Text.Megaparsec.notFollowedBy - -instance Text.Parser.Char.CharParsing Parser where - satisfy = Parser . Text.Megaparsec.Char.satisfy - - char = Text.Megaparsec.Char.char - - notChar = Text.Megaparsec.Char.char - - anyChar = Text.Megaparsec.Char.anyChar - - string = fmap Data.Text.Lazy.unpack . Text.Megaparsec.Char.string . fromString - - text = fmap Data.Text.Lazy.toStrict . Text.Megaparsec.Char.string . Data.Text.Lazy.fromStrict - -instance TokenParsing Parser where - someSpace = - Text.Parser.Token.Style.buildSomeSpaceParser - (Parser (Text.Megaparsec.skipSome (Text.Megaparsec.Char.satisfy Data.Char.isSpace))) - Text.Parser.Token.Style.haskellCommentStyle - - highlight _ = id - - semi = token (Text.Megaparsec.Char.char ';' ";") - -noted :: Parser (Expr Src a) -> Parser (Expr Src a) -noted parser = do - before <- Text.Megaparsec.getPosition - (tokens, e) <- Text.Megaparsec.match parser - after <- Text.Megaparsec.getPosition - return (Note (Src before after tokens) e) - -count :: (Semigroup a, Monoid a) => Int -> Parser a -> Parser a -count n parser = mconcat (replicate n parser) - -range :: (Semigroup a, Monoid a) => Int -> Int -> Parser a -> Parser a -range minimumBound maximumMatches parser = - count minimumBound parser <> loop maximumMatches - where - loop 0 = mempty - loop n = (parser <> loop (n - 1)) <|> mempty - -option :: (Alternative f, Monoid a) => f a -> f a -option p = p <|> pure mempty - -star :: (Alternative f, Monoid a) => f a -> f a -star p = plus p <|> pure mempty - -plus :: (Alternative f, Monoid a) => f a -> f a -plus p = mappend <$> p <*> star p - -satisfy :: (Char -> Bool) -> Parser Builder -satisfy predicate = - fmap Data.Text.Lazy.Builder.singleton (Text.Parser.Char.satisfy predicate) - -blockComment :: Parser () -blockComment = do - _ <- Text.Parser.Char.text "{-" - blockCommentContinue - -blockCommentChunk :: Parser () -blockCommentChunk = - choice - [ blockComment -- Nested block comment - , character - , endOfLine - ] - where - character = void (Text.Parser.Char.satisfy predicate) - where - predicate c = '\x20' <= c && c <= '\x10FFFF' || c == '\n' || c == '\t' - - endOfLine = void (Text.Parser.Char.text "\r\n") - -blockCommentContinue :: Parser () -blockCommentContinue = endOfComment <|> continue - where - endOfComment = void (Text.Parser.Char.text "-}") - - continue = do - blockCommentChunk - blockCommentContinue - -lineComment :: Parser () -lineComment = do - _ <- Text.Parser.Char.text "--" - Text.Parser.Combinators.skipMany notEndOfLine - endOfLine - return () - where - endOfLine = - void (Text.Parser.Char.char '\n' ) - <|> void (Text.Parser.Char.text "\r\n") - - notEndOfLine = void (Text.Parser.Char.satisfy predicate) - where - predicate c = ('\x20' <= c && c <= '\x10FFFF') || c == '\t' - - -whitespaceChunk :: Parser () -whitespaceChunk = - choice - [ void (Text.Parser.Char.satisfy predicate) - , void (Text.Parser.Char.text "\r\n") - , lineComment - , blockComment - ] "whitespace" - where - predicate c = c == ' ' || c == '\t' || c == '\n' - -whitespace :: Parser () -whitespace = Text.Parser.Combinators.skipMany whitespaceChunk - -alpha :: Char -> Bool -alpha c = ('\x41' <= c && c <= '\x5A') || ('\x61' <= c && c <= '\x7A') - -digit :: Char -> Bool -digit c = '\x30' <= c && c <= '\x39' - -hexdig :: Char -> Bool -hexdig c = - ('0' <= c && c <= '9') - || ('A' <= c && c <= 'F') - || ('a' <= c && c <= 'f') - -hexNumber :: Parser Int -hexNumber = choice [ hexDigit, hexUpper, hexLower ] - where - hexDigit = do - c <- Text.Parser.Char.satisfy predicate - return (Data.Char.ord c - Data.Char.ord '0') - where - predicate c = '0' <= c && c <= '9' - - hexUpper = do - c <- Text.Parser.Char.satisfy predicate - return (10 + Data.Char.ord c - Data.Char.ord 'A') - where - predicate c = 'A' <= c && c <= 'F' - - hexLower = do - c <- Text.Parser.Char.satisfy predicate - return (10 + Data.Char.ord c - Data.Char.ord 'a') - where - predicate c = 'a' <= c && c <= 'f' - -simpleLabel :: Parser Text -simpleLabel = try (do - c <- Text.Parser.Char.satisfy headCharacter - cs <- many (Text.Parser.Char.satisfy tailCharacter) - let string = c:cs - let text = Data.Text.Lazy.pack string - Control.Monad.guard (not (Data.HashSet.member text reservedIdentifiers)) - return text ) - where - headCharacter c = alpha c || c == '_' - - tailCharacter c = alpha c || digit c || c == '_' || c == '-' || c == '/' - -backtickLabel :: Parser Text -backtickLabel = do - _ <- Text.Parser.Char.char '`' - t <- some (Text.Parser.Char.satisfy predicate) - _ <- Text.Parser.Char.char '`' - return (Data.Text.Lazy.pack t) - where - predicate c = alpha c || digit c || elem c ("-/_:." :: String) - -label :: Parser Text -label = (do - t <- backtickLabel <|> simpleLabel - whitespace - return t ) "label" - -noDuplicates :: Ord a => [a] -> Parser (Set a) -noDuplicates = go Data.Set.empty - where - go found [] = return found - go found (x:xs) = - if Data.Set.member x found - then fail "Duplicate key" - else go (Data.Set.insert x found) xs - -labels :: Parser (Set Text) -labels = do - _openBrace - xs <- nonEmptyLabels <|> emptyLabels - _closeBrace - return xs - where - emptyLabels = pure Data.Set.empty - - nonEmptyLabels = do - x <- label - xs <- many (do _ <- _comma; label) - noDuplicates (x : xs) - -doubleQuotedChunk :: Parser a -> Parser (Chunks Src a) -doubleQuotedChunk embedded = - choice - [ interpolation - , unescapedCharacter - , escapedCharacter - ] - where - interpolation = do - _ <- Text.Parser.Char.text "${" - e <- completeExpression embedded - _ <- Text.Parser.Char.char '}' - return (Chunks [(mempty, e)] mempty) - - unescapedCharacter = do - c <- Text.Parser.Char.satisfy predicate - return (Chunks [] (Data.Text.Lazy.Builder.singleton c)) - where - predicate c = - ('\x20' <= c && c <= '\x21' ) - || ('\x23' <= c && c <= '\x5B' ) - || ('\x5D' <= c && c <= '\x10FFFF') - - escapedCharacter = do - _ <- Text.Parser.Char.char '\\' - c <- choice - [ quotationMark - , dollarSign - , backSlash - , forwardSlash - , backSpace - , formFeed - , lineFeed - , carriageReturn - , tab - , unicode - ] - return (Chunks [] (Data.Text.Lazy.Builder.singleton c)) - where - quotationMark = Text.Parser.Char.char '"' - - dollarSign = Text.Parser.Char.char '$' - - backSlash = Text.Parser.Char.char '\\' - - forwardSlash = Text.Parser.Char.char '/' - - backSpace = do _ <- Text.Parser.Char.char 'b'; return '\b' - - formFeed = do _ <- Text.Parser.Char.char 'f'; return '\f' - - lineFeed = do _ <- Text.Parser.Char.char 'n'; return '\n' - - carriageReturn = do _ <- Text.Parser.Char.char 'r'; return '\r' - - tab = do _ <- Text.Parser.Char.char 't'; return '\t' - - unicode = do - _ <- Text.Parser.Char.char 'u'; - n0 <- hexNumber - n1 <- hexNumber - n2 <- hexNumber - n3 <- hexNumber - let n = ((n0 * 16 + n1) * 16 + n2) * 16 + n3 - return (Data.Char.chr n) - -doubleQuotedLiteral :: Parser a -> Parser (Chunks Src a) -doubleQuotedLiteral embedded = do - _ <- Text.Parser.Char.char '"' - chunks <- many (doubleQuotedChunk embedded) - _ <- Text.Parser.Char.char '"' - return (mconcat chunks) - --- | Similar to `Dhall.Core.buildChunks` except that this doesn't bother to --- render interpolated expressions to avoid a `Buildable a` constraint. The --- interpolated contents are not necessary for computing how much to dedent a --- multi-line string --- --- This also doesn't include the surrounding quotes since they would interfere --- with the whitespace detection -buildChunks :: Chunks s a -> Builder -buildChunks (Chunks a b) = foldMap buildChunk a <> escapeText b - where - buildChunk (c, _) = escapeText c <> "${x}" - -dedent :: Chunks Src a -> Chunks Src a -dedent chunks0 = process chunks0 - where - builder0 = buildChunks chunks0 - - text0 = Data.Text.Lazy.Builder.toLazyText builder0 - - lines0 = Data.Text.Lazy.lines text0 - - isEmpty = Data.Text.Lazy.all Data.Char.isSpace - - nonEmptyLines = filter (not . isEmpty) lines0 - - indentLength line = - Data.Text.Lazy.length (Data.Text.Lazy.takeWhile Data.Char.isSpace line) - - shortestIndent = case nonEmptyLines of - [] -> 0 - _ -> minimum (map indentLength nonEmptyLines) - - -- The purpose of this complicated `trimBegin`/`trimContinue` is to ensure - -- that we strip leading whitespace without stripping whitespace after - -- variable interpolation - - -- This is the trim function we use up until the first variable - -- interpolation, dedenting all lines - trimBegin = - build - . Data.Text.Lazy.intercalate "\n" - . map (Data.Text.Lazy.drop shortestIndent) - . Data.Text.Lazy.splitOn "\n" - . Data.Text.Lazy.Builder.toLazyText - - -- This is the trim function we use after each variable interpolation - -- where we indent each line except the first line (since it's not a true - -- beginning of a line) - trimContinue builder = build (Data.Text.Lazy.intercalate "\n" lines_) - where - text = Data.Text.Lazy.Builder.toLazyText builder - - lines_ = case Data.Text.Lazy.splitOn "\n" text of - [] -> [] - l:ls -> l:map (Data.Text.Lazy.drop shortestIndent) ls - - -- This is the loop that drives whether or not to use `trimBegin` or - -- `trimContinue`. We call this function with `trimBegin`, but after the - -- first interpolation we switch permanently to `trimContinue` - process (Chunks ((x0, y0):xys) z) = - Chunks ((trimBegin x0, y0):xys') (trimContinue z) - where - xys' = [ (trimContinue x, y) | (x, y) <- xys ] - process (Chunks [] z) = - Chunks [] (trimBegin z) - -singleQuoteContinue :: Parser a -> Parser (Chunks Src a) -singleQuoteContinue embedded = - choice - [ escapeSingleQuotes - , interpolation - , escapeInterpolation - , endLiteral - , unescapedCharacter - , tab - , endOfLine - ] - where - escapeSingleQuotes = do - _ <- "'''" :: Parser Builder - b <- singleQuoteContinue embedded - return ("''" <> b) - - interpolation = do - _ <- Text.Parser.Char.text "${" - a <- completeExpression embedded - _ <- Text.Parser.Char.char '}' - b <- singleQuoteContinue embedded - return (Chunks [(mempty, a)] mempty <> b) - - escapeInterpolation = do - _ <- Text.Parser.Char.text "''${" - b <- singleQuoteContinue embedded - return ("${" <> b) - - endLiteral = do - _ <- Text.Parser.Char.text "''" - return mempty - - unescapedCharacter = do - a <- satisfy predicate - b <- singleQuoteContinue embedded - return (Chunks [] a <> b) - where - predicate c = '\x20' <= c && c <= '\x10FFFF' - - endOfLine = do - a <- "\n" <|> "\r\n" - b <- singleQuoteContinue embedded - return (Chunks [] a <> b) - - tab = do - _ <- Text.Parser.Char.char '\t' - b <- singleQuoteContinue embedded - return ("\t" <> b) - -singleQuoteLiteral :: Parser a -> Parser (Chunks Src a) -singleQuoteLiteral embedded = do - _ <- Text.Parser.Char.text "''" - - -- This is technically not in the grammar, but it's still equivalent to the - -- original grammar and an easy way to discard the first character if it's - -- a newline - _ <- optional endOfLine - - a <- singleQuoteContinue embedded - - return (dedent a) - where - endOfLine = - void (Text.Parser.Char.char '\n' ) - <|> void (Text.Parser.Char.text "\r\n") - -textLiteral :: Parser a -> Parser (Expr Src a) -textLiteral embedded = (do - literal <- doubleQuotedLiteral embedded <|> singleQuoteLiteral embedded - whitespace - return (TextLit literal) ) "text literal" - -reserved :: Data.Text.Text -> Parser () -reserved x = do _ <- Text.Parser.Char.text x; whitespace - -_if :: Parser () -_if = reserved "if" - -_then :: Parser () -_then = reserved "then" - -_else :: Parser () -_else = reserved "else" - -_let :: Parser () -_let = reserved "let" - -_in :: Parser () -_in = reserved "in" - -_as :: Parser () -_as = reserved "as" - -_using :: Parser () -_using = reserved "using" - -_merge :: Parser () -_merge = reserved "merge" - -_constructors :: Parser () -_constructors = reserved "constructors" - -_NaturalFold :: Parser () -_NaturalFold = reserved "Natural/fold" - -_NaturalBuild :: Parser () -_NaturalBuild = reserved "Natural/build" - -_NaturalIsZero :: Parser () -_NaturalIsZero = reserved "Natural/isZero" - -_NaturalEven :: Parser () -_NaturalEven = reserved "Natural/even" - -_NaturalOdd :: Parser () -_NaturalOdd = reserved "Natural/odd" - -_NaturalToInteger :: Parser () -_NaturalToInteger = reserved "Natural/toInteger" - -_NaturalShow :: Parser () -_NaturalShow = reserved "Natural/show" - -_IntegerShow :: Parser () -_IntegerShow = reserved "Integer/show" - -_DoubleShow :: Parser () -_DoubleShow = reserved "Double/show" - -_ListBuild :: Parser () -_ListBuild = reserved "List/build" - -_ListFold :: Parser () -_ListFold = reserved "List/fold" - -_ListLength :: Parser () -_ListLength = reserved "List/length" - -_ListHead :: Parser () -_ListHead = reserved "List/head" - -_ListLast :: Parser () -_ListLast = reserved "List/last" - -_ListIndexed :: Parser () -_ListIndexed = reserved "List/indexed" - -_ListReverse :: Parser () -_ListReverse = reserved "List/reverse" - -_OptionalFold :: Parser () -_OptionalFold = reserved "Optional/fold" - -_OptionalBuild :: Parser () -_OptionalBuild = reserved "Optional/build" - -_Bool :: Parser () -_Bool = reserved "Bool" - -_Optional :: Parser () -_Optional = reserved "Optional" - -_Natural :: Parser () -_Natural = reserved "Natural" - -_Integer :: Parser () -_Integer = reserved "Integer" - -_Double :: Parser () -_Double = reserved "Double" - -_Text :: Parser () -_Text = reserved "Text" - -_List :: Parser () -_List = reserved "List" - -_True :: Parser () -_True = reserved "True" - -_False :: Parser () -_False = reserved "False" - -_Type :: Parser () -_Type = reserved "Type" - -_Kind :: Parser () -_Kind = reserved "Kind" - -_equal :: Parser () -_equal = reserved "=" - -_or :: Parser () -_or = reserved "||" - -_plus :: Parser () -_plus = reserved "+" - -_textAppend :: Parser () -_textAppend = reserved "++" - -_listAppend :: Parser () -_listAppend = reserved "#" - -_and :: Parser () -_and = reserved "&&" - -_times :: Parser () -_times = reserved "*" - -_doubleEqual :: Parser () -_doubleEqual = reserved "==" - -_notEqual :: Parser () -_notEqual = reserved "!=" - -_dot :: Parser () -_dot = reserved "." - -_openBrace :: Parser () -_openBrace = reserved "{" - -_closeBrace :: Parser () -_closeBrace = reserved "}" - -_openBracket :: Parser () -_openBracket = reserved "[" - -_closeBracket :: Parser () -_closeBracket = reserved "]" - -_openAngle :: Parser () -_openAngle = reserved "<" - -_closeAngle :: Parser () -_closeAngle = reserved ">" - -_bar :: Parser () -_bar = reserved "|" - -_comma :: Parser () -_comma = reserved "," - -_openParens :: Parser () -_openParens = reserved "(" - -_closeParens :: Parser () -_closeParens = reserved ")" - -_colon :: Parser () -_colon = reserved ":" - -_at :: Parser () -_at = reserved "@" - -_combine :: Parser () -_combine = do - void (Text.Parser.Char.char '∧' "\"∧\"") <|> void (Text.Parser.Char.text "/\\") - whitespace - -_combineTypes :: Parser () -_combineTypes = do - void (Text.Parser.Char.char '⩓' "\"⩓\"") <|> void (Text.Parser.Char.text "//\\\\") - whitespace - -_prefer :: Parser () -_prefer = do - void (Text.Parser.Char.char '⫽' "\"⫽\"") <|> void (Text.Parser.Char.text "//") - whitespace - -_lambda :: Parser () -_lambda = do - _ <- Text.Parser.Char.satisfy predicate - whitespace - where - predicate 'λ' = True - predicate '\\' = True - predicate _ = False - -_forall :: Parser () -_forall = do - void (Text.Parser.Char.char '∀' "\"∀\"") <|> void (Text.Parser.Char.text "forall") - whitespace - -_arrow :: Parser () -_arrow = do - void (Text.Parser.Char.char '→' "\"→\"") <|> void (Text.Parser.Char.text "->") - whitespace - -doubleLiteral :: Parser Scientific -doubleLiteral = (do - sign <- fmap (\_ -> negate) (Text.Parser.Char.char '-') - <|> pure id - a <- Text.Parser.Token.scientific - return (sign a) ) "double literal" - -integerLiteral :: Parser Integer -integerLiteral = (do - let positive = fmap (\_ -> id ) (Text.Parser.Char.char '+') - let negative = fmap (\_ -> negate) (Text.Parser.Char.char '-') - sign <- positive <|> negative - a <- Text.Parser.Token.natural - return (sign a) ) "integer literal" - -naturalLiteral :: Parser Natural -naturalLiteral = (do - a <- Text.Parser.Token.natural - return (fromIntegral a) ) "natural literal" - -identifier :: Parser Var -identifier = do - x <- label - - let indexed = do - _ <- Text.Parser.Char.char '@' - Text.Parser.Token.natural - - n <- indexed <|> pure 0 - return (V x n) - -pathCharacter :: Char -> Bool -pathCharacter c = - ('\x21' <= c && c <= '\x22') - || ('\x24' <= c && c <= '\x27') - || ('\x2A' <= c && c <= '\x2B') - || ('\x2D' <= c && c <= '\x2E') - || ('\x30' <= c && c <= '\x3B') - || c == '\x3D' - || ('\x40' <= c && c <= '\x5A') - || ('\x5E' <= c && c <= '\x7A') - || c == '\x7C' - || c == '\x7E' - -pathComponent :: Parser Text -pathComponent = do - _ <- "/" :: Parser Builder - string <- some (Text.Parser.Char.satisfy pathCharacter) - - return (Data.Text.Lazy.pack string) - -file_ :: Parser File -file_ = do - path <- Data.List.NonEmpty.some1 pathComponent - - let directory = Directory (reverse (Data.List.NonEmpty.init path)) - let file = Data.List.NonEmpty.last path - - return (File {..}) - -localRaw :: Parser ImportType -localRaw = - choice - [ parentPath - , herePath - , homePath - , try absolutePath - ] - where - parentPath = do - _ <- ".." :: Parser Builder - file <- file_ - - return (Local Parent file) - - herePath = do - _ <- "." :: Parser Builder - file <- file_ - - return (Local Here file) - - homePath = do - _ <- "~" :: Parser Builder - file <- file_ - - return (Local Home file) - - absolutePath = do - file <- file_ - - return (Local Absolute file) - -local :: Parser ImportType -local = do - a <- localRaw - whitespace - return a - -scheme :: Parser Builder -scheme = "http" <> option "s" - -httpRaw :: Parser (Text, File, Text) -httpRaw = do - prefix <- scheme <> "://" <> authority - file <- file_ - suffix <- option ("?" <> query) <> option ("#" <> fragment) - - let prefixText = Data.Text.Lazy.Builder.toLazyText prefix - let suffixText = Data.Text.Lazy.Builder.toLazyText suffix - - return (prefixText, file, suffixText) - -authority :: Parser Builder -authority = option (try (userinfo <> "@")) <> host <> option (":" <> port) - -userinfo :: Parser Builder -userinfo = star (satisfy predicate <|> pctEncoded) - where - predicate c = unreserved c || subDelims c || c == ':' - -host :: Parser Builder -host = choice [ ipLiteral, ipV4Address, regName ] - -port :: Parser Builder -port = star (satisfy digit) - -ipLiteral :: Parser Builder -ipLiteral = "[" <> (ipV6Address <|> ipVFuture) <> "]" - -ipVFuture :: Parser Builder -ipVFuture = "v" <> plus (satisfy hexdig) <> "." <> plus (satisfy predicate) - where - predicate c = unreserved c || subDelims c || c == ':' - -ipV6Address :: Parser Builder -ipV6Address = - choice - [ try alternative0 - , try alternative1 - , try alternative2 - , try alternative3 - , try alternative4 - , try alternative5 - , try alternative6 - , try alternative7 - , alternative8 - ] - where - alternative0 = count 6 (h16 <> ":") <> ls32 - - alternative1 = "::" <> count 5 (h16 <> ":") <> ls32 - - alternative2 = option h16 <> "::" <> count 4 (h16 <> ":") <> ls32 - - alternative3 = - option (range 0 1 (h16 <> ":") <> h16) - <> "::" - <> count 3 (h16 <> ":") - <> ls32 - - alternative4 = - option (range 0 2 (h16 <> ":") <> h16) - <> "::" - <> count 2 (h16 <> ":") - <> ls32 - - alternative5 = - option (range 0 3 (h16 <> ":") <> h16) <> "::" <> h16 <> ":" <> ls32 - - alternative6 = - option (range 0 4 (h16 <> ":") <> h16) <> "::" <> ls32 - - alternative7 = - option (range 0 5 (h16 <> ":") <> h16) <> "::" <> h16 - - alternative8 = - option (range 0 6 (h16 <> ":") <> h16) <> "::" - -h16 :: Parser Builder -h16 = range 1 3 (satisfy hexdig) - -ls32 :: Parser Builder -ls32 = (h16 <> ":" <> h16) <|> ipV4Address - -ipV4Address :: Parser Builder -ipV4Address = decOctet <> "." <> decOctet <> "." <> decOctet <> "." <> decOctet - -decOctet :: Parser Builder -decOctet = - choice - [ try alternative4 - , try alternative3 - , try alternative2 - , try alternative1 - , alternative0 - ] - where - alternative0 = satisfy digit - - alternative1 = satisfy predicate <> satisfy digit - where - predicate c = '\x31' <= c && c <= '\x39' - - alternative2 = "1" <> count 2 (satisfy digit) - - alternative3 = "2" <> satisfy predicate <> satisfy digit - where - predicate c = '\x30' <= c && c <= '\x34' - - alternative4 = "25" <> satisfy predicate - where - predicate c = '\x30' <= c && c <= '\x35' - -regName :: Parser Builder -regName = star (satisfy predicate <|> pctEncoded) - where - predicate c = unreserved c || subDelims c - -pchar :: Parser Builder -pchar = satisfy predicate <|> pctEncoded - where - predicate c = unreserved c || subDelims c || c == ':' || c == '@' - -query :: Parser Builder -query = star (pchar <|> satisfy predicate) - where - predicate c = c == '/' || c == '?' - -fragment :: Parser Builder -fragment = star (pchar <|> satisfy predicate) - where - predicate c = c == '/' || c == '?' - -pctEncoded :: Parser Builder -pctEncoded = "%" <> count 2 (satisfy hexdig) - -unreserved :: Char -> Bool -unreserved c = - alpha c || digit c || c == '-' || c == '.' || c == '_' || c == '~' - -subDelims :: Char -> Bool -subDelims c = c `elem` ("!$&'()*+,;=" :: String) - -http :: Parser ImportType -http = do - (prefix, path, suffix) <- httpRaw - whitespace - headers <- optional (do - _using - importHashed_ ) - return (URL prefix path suffix headers) - -env :: Parser ImportType -env = do - _ <- Text.Parser.Char.text "env:" - a <- (alternative0 <|> alternative1) - whitespace - return (Env a) - where - alternative0 = do - a <- bashEnvironmentVariable - return (Data.Text.Lazy.Builder.toLazyText a) - - alternative1 = do - _ <- Text.Parser.Char.char '"' - a <- posixEnvironmentVariable - _ <- Text.Parser.Char.char '"' - return (Data.Text.Lazy.Builder.toLazyText a) - -bashEnvironmentVariable :: Parser Builder -bashEnvironmentVariable = satisfy predicate0 <> star (satisfy predicate1) - where - predicate0 c = alpha c || c == '_' - - predicate1 c = alpha c || digit c || c == '_' - -posixEnvironmentVariable :: Parser Builder -posixEnvironmentVariable = plus posixEnvironmentVariableCharacter - -posixEnvironmentVariableCharacter :: Parser Builder -posixEnvironmentVariableCharacter = - ("\\" <> satisfy predicate0) <|> satisfy predicate1 - where - predicate0 c = c `elem` ("\"\\abfnrtv" :: String) - - predicate1 c = - ('\x20' <= c && c <= '\x21') - || ('\x23' <= c && c <= '\x3C') - || ('\x3E' <= c && c <= '\x5B') - || ('\x5D' <= c && c <= '\x7E') - -expression :: Parser a -> Parser (Expr Src a) -expression embedded = - ( noted - ( choice - [ alternative0 - , alternative1 - , alternative2 - , alternative3 - , alternative4 - ] - ) - <|> alternative5 - ) "expression" - where - alternative0 = do - _lambda - _openParens - a <- label - _colon - b <- expression embedded - _closeParens - _arrow - c <- expression embedded - return (Lam a b c) - - alternative1 = do - _if - a <- expression embedded - _then - b <- expression embedded - _else - c <- expression embedded - return (BoolIf a b c) - - alternative2 = do - _let - a <- label - b <- optional (do - _colon - expression embedded ) - _equal - c <- expression embedded - _in - d <- expression embedded - return (Let a b c d) - - alternative3 = do - _forall - _openParens - a <- label - _colon - b <- expression embedded - _closeParens - _arrow - c <- expression embedded - return (Pi a b c) - - alternative4 = do - a <- try (do a <- operatorExpression embedded; _arrow; return a) - b <- expression embedded - return (Pi "_" a b) - - alternative5 = annotatedExpression embedded - -annotatedExpression :: Parser a -> Parser (Expr Src a) -annotatedExpression embedded = - noted - ( choice - [ alternative0 - , try alternative1 - , alternative2 - ] - ) - where - alternative0 = do - _merge - a <- selectorExpression embedded - b <- selectorExpression embedded - c <- optional (do - _colon - applicationExpression embedded ) - return (Merge a b c) - - alternative1 = (do - _openBracket - (emptyCollection embedded <|> nonEmptyOptional embedded) ) - "list literal" - - alternative2 = do - a <- operatorExpression embedded - b <- optional (do _colon; expression embedded) - case b of - Nothing -> return a - Just c -> return (Annot a c) - -emptyCollection :: Parser a -> Parser (Expr Src a) -emptyCollection embedded = do - _closeBracket - _colon - a <- alternative0 <|> alternative1 - b <- selectorExpression embedded - return (a b) - where - alternative0 = do - _List - return (\a -> ListLit (Just a) empty) - - alternative1 = do - _Optional - return (\a -> OptionalLit a empty) - -nonEmptyOptional :: Parser a -> Parser (Expr Src a) -nonEmptyOptional embedded = do - a <- expression embedded - _closeBracket - _colon - _Optional - b <- selectorExpression embedded - return (OptionalLit b (pure a)) - -operatorExpression :: Parser a -> Parser (Expr Src a) -operatorExpression = orExpression - -makeOperatorExpression - :: (Parser a -> Parser (Expr Src a)) - -> Parser () - -> (Expr Src a -> Expr Src a -> Expr Src a) - -> Parser a - -> Parser (Expr Src a) -makeOperatorExpression subExpression operatorParser operator embedded = - noted (do - a <- subExpression embedded - b <- many (do operatorParser; subExpression embedded) - return (foldr1 operator (a:b)) ) - -orExpression :: Parser a -> Parser (Expr Src a) -orExpression = - makeOperatorExpression plusExpression _or BoolOr - -plusExpression :: Parser a -> Parser (Expr Src a) -plusExpression = - makeOperatorExpression textAppendExpression _plus NaturalPlus - -textAppendExpression :: Parser a -> Parser (Expr Src a) -textAppendExpression = - makeOperatorExpression listAppendExpression _textAppend TextAppend - -listAppendExpression :: Parser a -> Parser (Expr Src a) -listAppendExpression = - makeOperatorExpression andExpression _listAppend ListAppend - -andExpression :: Parser a -> Parser (Expr Src a) -andExpression = - makeOperatorExpression combineExpression _and BoolAnd - -combineExpression :: Parser a -> Parser (Expr Src a) -combineExpression = - makeOperatorExpression preferExpression _combine Combine - -preferExpression :: Parser a -> Parser (Expr Src a) -preferExpression = - makeOperatorExpression combineTypesExpression _prefer Prefer - -combineTypesExpression :: Parser a -> Parser (Expr Src a) -combineTypesExpression = - makeOperatorExpression timesExpression _combineTypes CombineTypes - -timesExpression :: Parser a -> Parser (Expr Src a) -timesExpression = - makeOperatorExpression equalExpression _times NaturalTimes - -equalExpression :: Parser a -> Parser (Expr Src a) -equalExpression = - makeOperatorExpression notEqualExpression _doubleEqual BoolEQ - -notEqualExpression :: Parser a -> Parser (Expr Src a) -notEqualExpression = - makeOperatorExpression applicationExpression _notEqual BoolNE - -applicationExpression :: Parser a -> Parser (Expr Src a) -applicationExpression embedded = do - f <- (do _constructors; return Constructors) <|> return id - a <- noted (selectorExpression embedded) - b <- many (noted (selectorExpression embedded)) - return (foldl app (f a) b) - where - app nL@(Note (Src before _ bytesL) _) nR@(Note (Src _ after bytesR) _) = - Note (Src before after (bytesL <> bytesR)) (App nL nR) - app nL nR = - App nL nR - -selectorExpression :: Parser a -> Parser (Expr Src a) -selectorExpression embedded = noted (do - a <- primitiveExpression embedded - - let left x e = Field e x - let right xs e = Project e xs - b <- many (try (do _dot; fmap left label <|> fmap right labels)) - return (foldl (\e k -> k e) a b) ) - -primitiveExpression :: Parser a -> Parser (Expr Src a) -primitiveExpression embedded = - noted - ( choice - [ alternative00 - , alternative01 - , alternative02 - , alternative03 - , alternative04 - , alternative05 - , alternative06 - , alternative07 - , alternative37 - - , choice - [ alternative08 - , alternative09 - , alternative10 - , alternative11 - , alternative12 - , alternative13 - , alternative14 - , alternative15 - , alternative16 - , alternative17 - , alternative18 - , alternative19 - , alternative20 - , alternative21 - , alternative22 - , alternative23 - , alternative24 - , alternative25 - , alternative26 - , alternative27 - , alternative28 - , alternative29 - , alternative30 - , alternative31 - , alternative32 - , alternative33 - , alternative34 - , alternative35 - , alternative36 - ] "built-in expression" - ] - ) - <|> alternative38 - where - alternative00 = do - a <- try doubleLiteral - return (DoubleLit a) - - alternative01 = do - a <- try naturalLiteral - return (NaturalLit a) - - alternative02 = do - a <- try integerLiteral - return (IntegerLit a) - - alternative03 = textLiteral embedded - - alternative04 = (do - _openBrace - a <- recordTypeOrLiteral embedded - _closeBrace - return a ) "record type or literal" - - alternative05 = (do - _openAngle - a <- unionTypeOrLiteral embedded - _closeAngle - return a ) "union type or literal" - - alternative06 = nonEmptyListLiteral embedded - - alternative07 = do - a <- embedded - return (Embed a) - - alternative08 = do - _NaturalFold - return NaturalFold - - alternative09 = do - _NaturalBuild - return NaturalBuild - - alternative10 = do - _NaturalIsZero - return NaturalIsZero - - alternative11 = do - _NaturalEven - return NaturalEven - - alternative12 = do - _NaturalOdd - return NaturalOdd - - alternative13 = do - _NaturalToInteger - return NaturalToInteger - - alternative14 = do - _NaturalShow - return NaturalShow - - alternative15 = do - _IntegerShow - return IntegerShow - - alternative16 = do - _DoubleShow - return DoubleShow - - alternative17 = do - _ListBuild - return ListBuild - - alternative18 = do - _ListFold - return ListFold - - alternative19 = do - _ListLength - return ListLength - - alternative20 = do - _ListHead - return ListHead - - alternative21 = do - _ListLast - return ListLast - - alternative22 = do - _ListIndexed - return ListIndexed - - alternative23 = do - _ListReverse - return ListReverse - - alternative24 = do - _OptionalFold - return OptionalFold - - alternative25 = do - _OptionalBuild - return OptionalBuild - - alternative26 = do - _Bool - return Bool - - alternative27 = do - _Optional - return Optional - - alternative28 = do - _Natural - return Natural - - alternative29 = do - _Integer - return Integer - - alternative30 = do - _Double - return Double - - alternative31 = do - _Text - return Text - - alternative32 = do - _List - return List - - alternative33 = do - _True - return (BoolLit True) - - alternative34 = do - _False - return (BoolLit False) - - alternative35 = do - _Type - return (Const Type) - - alternative36 = do - _Kind - return (Const Kind) - - alternative37 = do - a <- identifier - return (Var a) - - alternative38 = do - _openParens - a <- expression embedded - _closeParens - return a - -recordTypeOrLiteral :: Parser a -> Parser (Expr Src a) -recordTypeOrLiteral embedded = - choice - [ alternative0 - , alternative1 - , alternative2 - ] - where - alternative0 = do - _equal - return (RecordLit Data.HashMap.Strict.InsOrd.empty) - - alternative1 = nonEmptyRecordTypeOrLiteral embedded - - alternative2 = return (Record Data.HashMap.Strict.InsOrd.empty) - -nonEmptyRecordTypeOrLiteral :: Parser a -> Parser (Expr Src a) -nonEmptyRecordTypeOrLiteral embedded = do - a <- label - - let nonEmptyRecordType = do - _colon - b <- expression embedded - e <- many (do - _comma - c <- label - _colon - d <- expression embedded - return (c, d) ) - return (Record (Data.HashMap.Strict.InsOrd.fromList ((a, b):e))) - - let nonEmptyRecordLiteral = do - _equal - b <- expression embedded - e <- many (do - _comma - c <- label - _equal - d <- expression embedded - return (c, d) ) - return (RecordLit (Data.HashMap.Strict.InsOrd.fromList ((a, b):e))) - - nonEmptyRecordType <|> nonEmptyRecordLiteral - -unionTypeOrLiteral :: Parser a -> Parser (Expr Src a) -unionTypeOrLiteral embedded = - nonEmptyUnionTypeOrLiteral embedded - <|> return (Union Data.HashMap.Strict.InsOrd.empty) - -nonEmptyUnionTypeOrLiteral :: Parser a -> Parser (Expr Src a) -nonEmptyUnionTypeOrLiteral embedded = do - (f, kvs) <- loop - m <- toMap kvs - return (f m) - where - loop = do - a <- label - - let alternative0 = do - _equal - b <- expression embedded - kvs <- many (do - _bar - c <- label - _colon - d <- expression embedded - return (c, d) ) - return (UnionLit a b, kvs) - - let alternative1 = do - _colon - b <- expression embedded - - let alternative2 = do - _bar - (f, kvs) <- loop - return (f, (a, b):kvs) - - let alternative3 = return (Union, [(a, b)]) - - alternative2 <|> alternative3 - - alternative0 <|> alternative1 - -nonEmptyListLiteral :: Parser a -> Parser (Expr Src a) -nonEmptyListLiteral embedded = (do - _openBracket - a <- expression embedded - b <- many (do _comma; expression embedded) - _closeBracket - return (ListLit Nothing (Data.Sequence.fromList (a:b))) ) "list literal" - -completeExpression :: Parser a -> Parser (Expr Src a) -completeExpression embedded = do - whitespace - expression embedded - -toMap :: [(Text, a)] -> Parser (InsOrdHashMap Text a) -toMap kvs = do - let adapt (k, v) = (k, pure v) - let m = fromListWith (<|>) (fmap adapt kvs) - let action k vs = case Data.Sequence.viewl vs of - EmptyL -> empty - v :< vs' -> - if null vs' - then pure v - else - Text.Parser.Combinators.unexpected - ("duplicate field: " ++ Data.Text.Lazy.unpack k) - Data.HashMap.Strict.InsOrd.traverseWithKey action m - where - fromListWith combine = Data.List.foldl' snoc nil - where - nil = Data.HashMap.Strict.InsOrd.empty - - snoc m (k, v) = Data.HashMap.Strict.InsOrd.insertWith combine k v m - --- | Parser for a top-level Dhall expression -expr :: Parser (Expr Src Import) -expr = exprA import_ - --- | Parser for a top-level Dhall expression. The expression is parameterized --- over any parseable type, allowing the language to be extended as needed. -exprA :: Parser a -> Parser (Expr Src a) -exprA = completeExpression - -importType_ :: Parser ImportType -importType_ = choice [ local, http, env ] - -importHashed_ :: Parser ImportHashed -importHashed_ = do - importType <- importType_ - hash <- optional importHash_ - return (ImportHashed {..}) - where - importHash_ = do - _ <- Text.Parser.Char.text "sha256:" - builder <- count 64 (satisfy hexdig "hex digit") - whitespace - let lazyText = Data.Text.Lazy.Builder.toLazyText builder - let lazyBytes16 = Data.Text.Lazy.Encoding.encodeUtf8 lazyText - let strictBytes16 = Data.ByteString.Lazy.toStrict lazyBytes16 - strictBytes <- case Data.ByteArray.Encoding.convertFromBase Base16 strictBytes16 of - Left string -> fail string - Right strictBytes -> return (strictBytes :: Data.ByteString.ByteString) - case Crypto.Hash.digestFromByteString strictBytes of - Nothing -> fail "Invalid sha256 hash" - Just h -> pure h - -import_ :: Parser Import -import_ = (do - importHashed <- importHashed_ - importMode <- alternative <|> pure Code - return (Import {..}) ) "import" - where - alternative = do - _as - _Text - return RawText - --- | A parsing error -data ParseError = ParseError - { unwrap :: Text.Megaparsec.ParseError Char Void - , input :: Text - } - -instance Show ParseError where - show (ParseError {..}) = - "\n\ESC[1;31mError\ESC[0m: Invalid input\n\n" <> Text.Megaparsec.parseErrorPretty' input unwrap - -instance Exception ParseError - --- | Parse an expression from `Text` containing a Dhall program -exprFromText :: String -> Text -> Either ParseError (Expr Src Import) -exprFromText delta text = fmap snd (exprAndHeaderFromText delta text) - -{-| Like `exprFromText` but also returns the leading comments and whitespace - (i.e. header) up to the last newline before the code begins - - In other words, if you have a Dhall file of the form: - -> -- Comment 1 -> {- Comment -} 2 - - Then this will preserve @Comment 1@, but not @Comment 2@ - - This is used by @dhall-format@ to preserve leading comments and whitespace --} -exprAndHeaderFromText - :: String - -> Text - -> Either ParseError (Text, Expr Src Import) -exprAndHeaderFromText delta text = case result of - Left errInfo -> Left (ParseError { unwrap = errInfo, input = text }) - Right (txt, r) -> Right (Data.Text.Lazy.dropWhileEnd (/= '\n') txt, r) +{-# LANGUAGE RecordWildCards #-} +-- | This module contains Dhall's parsing logic + +module Dhall.Parser ( + -- * Utilities + exprFromText + , exprAndHeaderFromText + + -- * Parsers + , expr, exprA + + -- * Types + , Src(..) + , ParseError(..) + , Parser(..) + ) where + +import Control.Exception (Exception) +import Data.Semigroup (Semigroup(..)) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Core +import Prelude hiding (const, pi) + +import qualified Data.Text +import qualified Text.Megaparsec + +import Dhall.Parser.Combinators +import Dhall.Parser.Token +import Dhall.Parser.Expression + +-- | Parser for a top-level Dhall expression +expr :: Parser (Expr Src Import) +expr = exprA import_ + +-- | Parser for a top-level Dhall expression. The expression is parameterized +-- over any parseable type, allowing the language to be extended as needed. +exprA :: Parser a -> Parser (Expr Src a) +exprA = completeExpression + +-- | A parsing error +data ParseError = ParseError + { unwrap :: Text.Megaparsec.ParseError Char Void + , input :: Text + } + +instance Show ParseError where + show (ParseError {..}) = + "\n\ESC[1;31mError\ESC[0m: Invalid input\n\n" <> Text.Megaparsec.parseErrorPretty' input unwrap + +instance Exception ParseError + +-- | Parse an expression from `Text` containing a Dhall program +exprFromText + :: String -- ^ User-friendly name describing the input expression, + -- used in parsing error messages + -> Text -- ^ Input expression to parse + -> Either ParseError (Expr Src Import) +exprFromText delta text = fmap snd (exprAndHeaderFromText delta text) + +{-| Like `exprFromText` but also returns the leading comments and whitespace + (i.e. header) up to the last newline before the code begins + + In other words, if you have a Dhall file of the form: + +> -- Comment 1 +> {- Comment -} 2 + + Then this will preserve @Comment 1@, but not @Comment 2@ + + This is used by @dhall-format@ to preserve leading comments and whitespace +-} +exprAndHeaderFromText + :: String -- ^ User-friendly name describing the input expression, + -- used in parsing error messages + -> Text -- ^ Input expression to parse + -> Either ParseError (Text, Expr Src Import) +exprAndHeaderFromText delta text = case result of + Left errInfo -> Left (ParseError { unwrap = errInfo, input = text }) + Right (txt, r) -> Right (Data.Text.dropWhileEnd (/= '\n') txt, r) where parser = do (bytes, _) <- Text.Megaparsec.match whitespace diff --git a/src/Dhall/Parser/Combinators.hs b/src/Dhall/Parser/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Parser/Combinators.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Dhall.Parser.Combinators where + + +import Control.Applicative (Alternative (..), liftA2) +import Control.Monad (MonadPlus) +import Data.Data (Data) +import Data.HashMap.Strict.InsOrd (InsOrdHashMap) +import Data.Semigroup (Semigroup (..)) +import Data.Sequence (ViewL (..)) +import Data.Set (Set) +import Data.String (IsString (..)) +import Data.Text (Text) +import Data.Text.Prettyprint.Doc (Pretty (..)) +import Data.Void (Void) +import Prelude hiding (const, pi) +import Text.Parser.Combinators (try, ()) +import Text.Parser.Token (TokenParsing (..)) + +import qualified Data.Char +import qualified Data.HashMap.Strict.InsOrd +import qualified Data.List +import qualified Data.Sequence +import qualified Data.Set +import qualified Data.Text +import qualified Text.Megaparsec +import qualified Text.Megaparsec.Char +import qualified Text.Parser.Char +import qualified Text.Parser.Combinators +import qualified Text.Parser.Token.Style + +-- | Source code extract +data Src = Src Text.Megaparsec.SourcePos Text.Megaparsec.SourcePos Text + deriving (Data, Eq, Show) + +instance Pretty Src where + pretty (Src begin _ text) = + pretty text <> "\n" + <> "\n" + <> pretty (Text.Megaparsec.sourcePosPretty begin) + <> "\n" + +{-| A `Parser` that is almost identical to + @"Text.Megaparsec".`Text.Megaparsec.Parsec`@ except treating Haskell-style + comments as whitespace +-} +newtype Parser a = Parser { unParser :: Text.Megaparsec.Parsec Void Text a } + deriving + ( Functor + , Applicative + , Monad + , Alternative + , MonadPlus + , Text.Megaparsec.MonadParsec Void Text + ) + +instance Data.Semigroup.Semigroup a => Data.Semigroup.Semigroup (Parser a) where + (<>) = liftA2 (<>) + +instance (Data.Semigroup.Semigroup a, Monoid a) => Monoid (Parser a) where + mempty = pure mempty + +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) +#endif + +instance IsString a => IsString (Parser a) where + fromString x = fromString x <$ Text.Megaparsec.Char.string (fromString x) + +instance Text.Parser.Combinators.Parsing Parser where + try = Text.Megaparsec.try + + () = (Text.Megaparsec.) + + skipMany = Text.Megaparsec.skipMany + + skipSome = Text.Megaparsec.skipSome + + unexpected = fail + + eof = Parser Text.Megaparsec.eof + + notFollowedBy = Text.Megaparsec.notFollowedBy + +instance Text.Parser.Char.CharParsing Parser where + satisfy = Parser . Text.Megaparsec.Char.satisfy + + char = Text.Megaparsec.Char.char + + notChar = Text.Megaparsec.Char.char + + anyChar = Text.Megaparsec.Char.anyChar + + string = fmap Data.Text.unpack . Text.Megaparsec.Char.string . fromString + + text = Text.Megaparsec.Char.string + +instance TokenParsing Parser where + someSpace = + Text.Parser.Token.Style.buildSomeSpaceParser + (Parser (Text.Megaparsec.skipSome (Text.Megaparsec.Char.satisfy Data.Char.isSpace))) + Text.Parser.Token.Style.haskellCommentStyle + + highlight _ = id + + semi = token (Text.Megaparsec.Char.char ';' ";") + +count :: (Semigroup a, Monoid a) => Int -> Parser a -> Parser a +count n parser = mconcat (replicate n parser) + +range :: (Semigroup a, Monoid a) => Int -> Int -> Parser a -> Parser a +range minimumBound maximumMatches parser = + count minimumBound parser <> loop maximumMatches + where + loop 0 = mempty + loop n = (parser <> loop (n - 1)) <|> mempty + +option :: (Alternative f, Monoid a) => f a -> f a +option p = p <|> pure mempty + +star :: (Alternative f, Monoid a) => f a -> f a +star p = plus p <|> pure mempty + +plus :: (Alternative f, Monoid a) => f a -> f a +plus p = mappend <$> p <*> star p + +satisfy :: (Char -> Bool) -> Parser Text +satisfy = fmap Data.Text.singleton . Text.Parser.Char.satisfy + +noDuplicates :: Ord a => [a] -> Parser (Set a) +noDuplicates = go Data.Set.empty + where + go found [] = return found + go found (x:xs) = + if Data.Set.member x found + then fail "Duplicate key" + else go (Data.Set.insert x found) xs + +toMap :: [(Text, a)] -> Parser (InsOrdHashMap Text a) +toMap kvs = do + let adapt (k, v) = (k, pure v) + let m = fromListWith (<|>) (fmap adapt kvs) + let action k vs = case Data.Sequence.viewl vs of + EmptyL -> empty + v :< vs' -> + if null vs' + then pure v + else + Text.Parser.Combinators.unexpected + ("duplicate field: " ++ Data.Text.unpack k) + Data.HashMap.Strict.InsOrd.traverseWithKey action m + where + fromListWith combine = Data.List.foldl' snoc nil + where + nil = Data.HashMap.Strict.InsOrd.empty + + snoc m (k, v) = Data.HashMap.Strict.InsOrd.insertWith combine k v m diff --git a/src/Dhall/Parser/Expression.hs b/src/Dhall/Parser/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Parser/Expression.hs @@ -0,0 +1,863 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Parsing Dhall expressions. +module Dhall.Parser.Expression where + +import Control.Applicative (Alternative(..), optional) +import Data.ByteArray.Encoding (Base(..)) +import Data.Functor (void) +import Data.Semigroup (Semigroup(..)) +import Data.Text (Text) +import Dhall.Core +import Prelude hiding (const, pi) +import Text.Parser.Combinators (choice, try, ()) + +import qualified Crypto.Hash +import qualified Data.ByteArray.Encoding +import qualified Data.ByteString +import qualified Data.Char +import qualified Data.HashMap.Strict.InsOrd +import qualified Data.Sequence +import qualified Data.Text +import qualified Data.Text.Encoding +import qualified Text.Megaparsec +import qualified Text.Parser.Char + +import Dhall.Parser.Combinators +import Dhall.Parser.Token + +noted :: Parser (Expr Src a) -> Parser (Expr Src a) +noted parser = do + before <- Text.Megaparsec.getPosition + (tokens, e) <- Text.Megaparsec.match parser + after <- Text.Megaparsec.getPosition + let src₀ = Src before after tokens + case e of + Note src₁ _ | src₀ == src₁ -> return e + _ -> return (Note src₀ e) + +expression :: Parser a -> Parser (Expr Src a) +expression embedded = + ( noted + ( choice + [ alternative0 + , alternative1 + , alternative2 + , alternative3 + , alternative4 + ] + ) + <|> alternative5 + ) "expression" + where + alternative0 = do + _lambda + _openParens + a <- label + _colon + b <- expression embedded + _closeParens + _arrow + c <- expression embedded + return (Lam a b c) + + alternative1 = do + _if + a <- expression embedded + _then + b <- expression embedded + _else + c <- expression embedded + return (BoolIf a b c) + + alternative2 = do + _let + a <- label + b <- optional (do + _colon + expression embedded ) + _equal + c <- expression embedded + _in + d <- expression embedded + return (Let a b c d) + + alternative3 = do + _forall + _openParens + a <- label + _colon + b <- expression embedded + _closeParens + _arrow + c <- expression embedded + return (Pi a b c) + + alternative4 = do + a <- try (do a <- operatorExpression embedded; _arrow; return a) + b <- expression embedded + return (Pi "_" a b) + + alternative5 = annotatedExpression embedded + +annotatedExpression :: Parser a -> Parser (Expr Src a) +annotatedExpression embedded = + noted + ( choice + [ alternative0 + , try alternative1 + , alternative2 + ] + ) + where + alternative0 = do + _merge + a <- importExpression embedded + b <- importExpression embedded + c <- optional (do + _colon + applicationExpression embedded ) + return (Merge a b c) + + alternative1 = (do + _openBracket + (emptyCollection embedded <|> nonEmptyOptional embedded) ) + "list literal" + + alternative2 = do + a <- operatorExpression embedded + b <- optional (do _colon; expression embedded) + case b of + Nothing -> return a + Just c -> return (Annot a c) + +emptyCollection :: Parser a -> Parser (Expr Src a) +emptyCollection embedded = do + _closeBracket + _colon + a <- alternative0 <|> alternative1 + b <- importExpression embedded + return (a b) + where + alternative0 = do + _List + return (\a -> ListLit (Just a) empty) + + alternative1 = do + _Optional + return (\a -> OptionalLit a empty) + +nonEmptyOptional :: Parser a -> Parser (Expr Src a) +nonEmptyOptional embedded = do + a <- expression embedded + _closeBracket + _colon + _Optional + b <- importExpression embedded + return (OptionalLit b (pure a)) + +operatorExpression :: Parser a -> Parser (Expr Src a) +operatorExpression = importAltExpression + +makeOperatorExpression + :: (Parser a -> Parser (Expr Src a)) + -> Parser () + -> (Expr Src a -> Expr Src a -> Expr Src a) + -> Parser a + -> Parser (Expr Src a) +makeOperatorExpression subExpression operatorParser operator embedded = + noted (do + a <- subExpression embedded + b <- many (do operatorParser; subExpression embedded) + return (foldr1 operator (a:b)) ) + +importAltExpression :: Parser a -> Parser (Expr Src a) +importAltExpression = + makeOperatorExpression orExpression _importAlt ImportAlt + +orExpression :: Parser a -> Parser (Expr Src a) +orExpression = + makeOperatorExpression plusExpression _or BoolOr + +plusExpression :: Parser a -> Parser (Expr Src a) +plusExpression = + makeOperatorExpression textAppendExpression _plus NaturalPlus + +textAppendExpression :: Parser a -> Parser (Expr Src a) +textAppendExpression = + makeOperatorExpression listAppendExpression _textAppend TextAppend + +listAppendExpression :: Parser a -> Parser (Expr Src a) +listAppendExpression = + makeOperatorExpression andExpression _listAppend ListAppend + +andExpression :: Parser a -> Parser (Expr Src a) +andExpression = + makeOperatorExpression combineExpression _and BoolAnd + +combineExpression :: Parser a -> Parser (Expr Src a) +combineExpression = + makeOperatorExpression preferExpression _combine Combine + +preferExpression :: Parser a -> Parser (Expr Src a) +preferExpression = + makeOperatorExpression combineTypesExpression _prefer Prefer + +combineTypesExpression :: Parser a -> Parser (Expr Src a) +combineTypesExpression = + makeOperatorExpression timesExpression _combineTypes CombineTypes + +timesExpression :: Parser a -> Parser (Expr Src a) +timesExpression = + makeOperatorExpression equalExpression _times NaturalTimes + +equalExpression :: Parser a -> Parser (Expr Src a) +equalExpression = + makeOperatorExpression notEqualExpression _doubleEqual BoolEQ + +notEqualExpression :: Parser a -> Parser (Expr Src a) +notEqualExpression = + makeOperatorExpression applicationExpression _notEqual BoolNE + +applicationExpression :: Parser a -> Parser (Expr Src a) +applicationExpression embedded = do + f <- (do _constructors; return Constructors) <|> return id + a <- noted (importExpression embedded) + b <- many (noted (importExpression embedded)) + return (foldl app (f a) b) + where + app nL@(Note (Src before _ bytesL) _) nR@(Note (Src _ after bytesR) _) = + Note (Src before after (bytesL <> bytesR)) (App nL nR) + app nL nR = + App nL nR + +importExpression :: Parser a -> Parser (Expr Src a) +importExpression embedded = noted (choice [ alternative0, alternative1 ]) + where + alternative0 = do + a <- embedded + return (Embed a) + + alternative1 = selectorExpression embedded + +selectorExpression :: Parser a -> Parser (Expr Src a) +selectorExpression embedded = noted (do + a <- primitiveExpression embedded + + let left x e = Field e x + let right xs e = Project e xs + b <- many (try (do _dot; fmap left label <|> fmap right labels)) + return (foldl (\e k -> k e) a b) ) + +primitiveExpression :: Parser a -> Parser (Expr Src a) +primitiveExpression embedded = + noted + ( choice + [ alternative00 + , alternative01 + , alternative02 + , alternative03 + , alternative04 + , alternative05 + , alternative06 + , alternative37 + + , choice + [ alternative08 + , alternative09 + , alternative10 + , alternative11 + , alternative12 + , alternative13 + , alternative14 + , alternative15 + , alternativeIntegerToDouble + , alternative16 + , alternative17 + , alternative18 + , alternative19 + , alternative20 + , alternative21 + , alternative22 + , alternative23 + , alternative24 + , alternative25 + , alternative26 + , alternative27 + , alternative28 + , alternative29 + , alternative30 + , alternative31 + , alternative32 + , alternative33 + , alternative34 + , alternative35 + , alternative36 + ] "built-in expression" + ] + ) + <|> alternative38 + where + alternative00 = do + a <- try doubleLiteral + return (DoubleLit a) + + alternative01 = do + a <- try naturalLiteral + return (NaturalLit a) + + alternative02 = do + a <- try integerLiteral + return (IntegerLit a) + + alternative03 = textLiteral embedded + + alternative04 = (do + _openBrace + a <- recordTypeOrLiteral embedded + _closeBrace + return a ) "record type or literal" + + alternative05 = (do + _openAngle + a <- unionTypeOrLiteral embedded + _closeAngle + return a ) "union type or literal" + + alternative06 = nonEmptyListLiteral embedded + + alternative08 = do + _NaturalFold + return NaturalFold + + alternative09 = do + _NaturalBuild + return NaturalBuild + + alternative10 = do + _NaturalIsZero + return NaturalIsZero + + alternative11 = do + _NaturalEven + return NaturalEven + + alternative12 = do + _NaturalOdd + return NaturalOdd + + alternative13 = do + _NaturalToInteger + return NaturalToInteger + + alternative14 = do + _NaturalShow + return NaturalShow + + alternative15 = do + _IntegerShow + return IntegerShow + + alternativeIntegerToDouble = do + _IntegerToDouble + return IntegerToDouble + + alternative16 = do + _DoubleShow + return DoubleShow + + alternative17 = do + _ListBuild + return ListBuild + + alternative18 = do + _ListFold + return ListFold + + alternative19 = do + _ListLength + return ListLength + + alternative20 = do + _ListHead + return ListHead + + alternative21 = do + _ListLast + return ListLast + + alternative22 = do + _ListIndexed + return ListIndexed + + alternative23 = do + _ListReverse + return ListReverse + + alternative24 = do + _OptionalFold + return OptionalFold + + alternative25 = do + _OptionalBuild + return OptionalBuild + + alternative26 = do + _Bool + return Bool + + alternative27 = do + _Optional + return Optional + + alternative28 = do + _Natural + return Natural + + alternative29 = do + _Integer + return Integer + + alternative30 = do + _Double + return Double + + alternative31 = do + _Text + return Text + + alternative32 = do + _List + return List + + alternative33 = do + _True + return (BoolLit True) + + alternative34 = do + _False + return (BoolLit False) + + alternative35 = do + _Type + return (Const Type) + + alternative36 = do + _Kind + return (Const Kind) + + alternative37 = do + a <- identifier + return (Var a) + + alternative38 = do + _openParens + a <- expression embedded + _closeParens + return a + + +doubleQuotedChunk :: Parser a -> Parser (Chunks Src a) +doubleQuotedChunk embedded = + choice + [ interpolation + , unescapedCharacter + , escapedCharacter + ] + where + interpolation = do + _ <- Text.Parser.Char.text "${" + e <- completeExpression embedded + _ <- Text.Parser.Char.char '}' + return (Chunks [(mempty, e)] mempty) + + unescapedCharacter = do + c <- Text.Parser.Char.satisfy predicate + return (Chunks [] (Data.Text.singleton c)) + where + predicate c = + ('\x20' <= c && c <= '\x21' ) + || ('\x23' <= c && c <= '\x5B' ) + || ('\x5D' <= c && c <= '\x10FFFF') + + escapedCharacter = do + _ <- Text.Parser.Char.char '\\' + c <- choice + [ quotationMark + , dollarSign + , backSlash + , forwardSlash + , backSpace + , formFeed + , lineFeed + , carriageReturn + , tab + , unicode + ] + return (Chunks [] (Data.Text.singleton c)) + where + quotationMark = Text.Parser.Char.char '"' + + dollarSign = Text.Parser.Char.char '$' + + backSlash = Text.Parser.Char.char '\\' + + forwardSlash = Text.Parser.Char.char '/' + + backSpace = do _ <- Text.Parser.Char.char 'b'; return '\b' + + formFeed = do _ <- Text.Parser.Char.char 'f'; return '\f' + + lineFeed = do _ <- Text.Parser.Char.char 'n'; return '\n' + + carriageReturn = do _ <- Text.Parser.Char.char 'r'; return '\r' + + tab = do _ <- Text.Parser.Char.char 't'; return '\t' + + unicode = do + _ <- Text.Parser.Char.char 'u'; + n0 <- hexNumber + n1 <- hexNumber + n2 <- hexNumber + n3 <- hexNumber + let n = ((n0 * 16 + n1) * 16 + n2) * 16 + n3 + return (Data.Char.chr n) + +doubleQuotedLiteral :: Parser a -> Parser (Chunks Src a) +doubleQuotedLiteral embedded = do + _ <- Text.Parser.Char.char '"' + chunks <- many (doubleQuotedChunk embedded) + _ <- Text.Parser.Char.char '"' + return (mconcat chunks) + +singleQuoteContinue :: Parser a -> Parser (Chunks Src a) +singleQuoteContinue embedded = + choice + [ escapeSingleQuotes + , interpolation + , escapeInterpolation + , endLiteral + , unescapedCharacter + , tab + , endOfLine + ] + where + escapeSingleQuotes = do + _ <- "'''" :: Parser Text + b <- singleQuoteContinue embedded + return ("''" <> b) + + interpolation = do + _ <- Text.Parser.Char.text "${" + a <- completeExpression embedded + _ <- Text.Parser.Char.char '}' + b <- singleQuoteContinue embedded + return (Chunks [(mempty, a)] mempty <> b) + + escapeInterpolation = do + _ <- Text.Parser.Char.text "''${" + b <- singleQuoteContinue embedded + return ("${" <> b) + + endLiteral = do + _ <- Text.Parser.Char.text "''" + return mempty + + unescapedCharacter = do + a <- satisfy predicate + b <- singleQuoteContinue embedded + return (Chunks [] a <> b) + where + predicate c = '\x20' <= c && c <= '\x10FFFF' + + endOfLine = do + a <- "\n" <|> "\r\n" + b <- singleQuoteContinue embedded + return (Chunks [] a <> b) + + tab = do + _ <- Text.Parser.Char.char '\t' + b <- singleQuoteContinue embedded + return ("\t" <> b) + +singleQuoteLiteral :: Parser a -> Parser (Chunks Src a) +singleQuoteLiteral embedded = do + _ <- Text.Parser.Char.text "''" + + -- This is technically not in the grammar, but it's still equivalent to the + -- original grammar and an easy way to discard the first character if it's + -- a newline + _ <- optional endOfLine + + a <- singleQuoteContinue embedded + + return (dedent a) + where + endOfLine = + void (Text.Parser.Char.char '\n' ) + <|> void (Text.Parser.Char.text "\r\n") + +textLiteral :: Parser a -> Parser (Expr Src a) +textLiteral embedded = (do + literal <- doubleQuotedLiteral embedded <|> singleQuoteLiteral embedded + whitespace + return (TextLit literal) ) "text literal" + +recordTypeOrLiteral :: Parser a -> Parser (Expr Src a) +recordTypeOrLiteral embedded = + choice + [ alternative0 + , alternative1 + , alternative2 + ] + where + alternative0 = do + _equal + return (RecordLit Data.HashMap.Strict.InsOrd.empty) + + alternative1 = nonEmptyRecordTypeOrLiteral embedded + + alternative2 = return (Record Data.HashMap.Strict.InsOrd.empty) + +nonEmptyRecordTypeOrLiteral :: Parser a -> Parser (Expr Src a) +nonEmptyRecordTypeOrLiteral embedded = do + a <- label + + let nonEmptyRecordType = do + _colon + b <- expression embedded + e <- many (do + _comma + c <- label + _colon + d <- expression embedded + return (c, d) ) + m <- toMap ((a, b) : e) + return (Record m) + + let nonEmptyRecordLiteral = do + _equal + b <- expression embedded + e <- many (do + _comma + c <- label + _equal + d <- expression embedded + return (c, d) ) + m <- toMap ((a, b) : e) + return (RecordLit m) + + nonEmptyRecordType <|> nonEmptyRecordLiteral + +unionTypeOrLiteral :: Parser a -> Parser (Expr Src a) +unionTypeOrLiteral embedded = + nonEmptyUnionTypeOrLiteral embedded + <|> return (Union Data.HashMap.Strict.InsOrd.empty) + +nonEmptyUnionTypeOrLiteral :: Parser a -> Parser (Expr Src a) +nonEmptyUnionTypeOrLiteral embedded = do + (f, kvs) <- loop + m <- toMap kvs + return (f m) + where + loop = do + a <- label + + let alternative0 = do + _equal + b <- expression embedded + kvs <- many (do + _bar + c <- label + _colon + d <- expression embedded + return (c, d) ) + return (UnionLit a b, kvs) + + let alternative1 = do + _colon + b <- expression embedded + + let alternative2 = do + _bar + (f, kvs) <- loop + return (f, (a, b):kvs) + + let alternative3 = return (Union, [(a, b)]) + + alternative2 <|> alternative3 + + alternative0 <|> alternative1 + +nonEmptyListLiteral :: Parser a -> Parser (Expr Src a) +nonEmptyListLiteral embedded = (do + _openBracket + a <- expression embedded + b <- many (do _comma; expression embedded) + _closeBracket + return (ListLit Nothing (Data.Sequence.fromList (a:b))) ) "list literal" + +completeExpression :: Parser a -> Parser (Expr Src a) +completeExpression embedded = do + whitespace + expression embedded + +env :: Parser ImportType +env = do + _ <- Text.Parser.Char.text "env:" + a <- (alternative0 <|> alternative1) + whitespace + return (Env a) + where + alternative0 = bashEnvironmentVariable + + alternative1 = do + _ <- Text.Parser.Char.char '"' + a <- posixEnvironmentVariable + _ <- Text.Parser.Char.char '"' + return a + +localRaw :: Parser ImportType +localRaw = + choice + [ parentPath + , herePath + , homePath + , try absolutePath + ] + where + parentPath = do + _ <- ".." :: Parser Text + File (Directory segments) final <- file_ + + return (Local Here (File (Directory (segments ++ [".."])) final)) + + herePath = do + _ <- "." :: Parser Text + file <- file_ + + return (Local Here file) + + homePath = do + _ <- "~" :: Parser Text + file <- file_ + + return (Local Home file) + + absolutePath = do + file <- file_ + + return (Local Absolute file) + +local :: Parser ImportType +local = do + a <- localRaw + whitespace + return a + +http :: Parser ImportType +http = do + (prefix, path, suffix) <- httpRaw + whitespace + headers <- optional (do + _using + (importHashed_ <|> (_openParens *> importHashed_ <* _closeParens)) ) + return (URL prefix path suffix headers) + +missing :: Parser ImportType +missing = do + _missing + return Missing + +importType_ :: Parser ImportType +importType_ = choice [ local, http, env, missing ] + +importHashed_ :: Parser ImportHashed +importHashed_ = do + importType <- importType_ + hash <- optional importHash_ + return (ImportHashed {..}) + where + importHash_ = do + _ <- Text.Parser.Char.text "sha256:" + text <- count 64 (satisfy hexdig "hex digit") + whitespace + let strictBytes16 = Data.Text.Encoding.encodeUtf8 text + strictBytes <- case Data.ByteArray.Encoding.convertFromBase Base16 strictBytes16 of + Left string -> fail string + Right strictBytes -> return (strictBytes :: Data.ByteString.ByteString) + case Crypto.Hash.digestFromByteString strictBytes of + Nothing -> fail "Invalid sha256 hash" + Just h -> pure h + +import_ :: Parser Import +import_ = (do + importHashed <- importHashed_ + importMode <- alternative <|> pure Code + return (Import {..}) ) "import" + where + alternative = do + _as + _Text + return RawText + +-- | Similar to `Dhall.Core.renderChunks` except that this doesn't bother to +-- render interpolated expressions to avoid a `Buildable a` constraint. The +-- interpolated contents are not necessary for computing how much to dedent a +-- multi-line string +-- +-- This also doesn't include the surrounding quotes since they would interfere +-- with the whitespace detection +renderChunks :: Chunks s a -> Text +renderChunks (Chunks a b) = foldMap renderChunk a <> b + where + renderChunk :: (Text, Expr s a) -> Text + renderChunk (c, _) = c <> "${x}" + +dedent :: Chunks Src a -> Chunks Src a +dedent chunks0 = process chunks0 + where + text0 = renderChunks chunks0 + + lines0 = Data.Text.lines text0 + + isEmpty = Data.Text.all Data.Char.isSpace + + nonEmptyLines = filter (not . isEmpty) lines0 + + indentLength line = + Data.Text.length (Data.Text.takeWhile Data.Char.isSpace line) + + shortestIndent = case nonEmptyLines of + [] -> 0 + _ -> minimum (map indentLength nonEmptyLines) + + -- The purpose of this complicated `trimBegin`/`trimContinue` is to ensure + -- that we strip leading whitespace without stripping whitespace after + -- variable interpolation + + -- This is the trim function we use up until the first variable + -- interpolation, dedenting all lines + trimBegin = + Data.Text.intercalate "\n" + . map (Data.Text.drop shortestIndent) + . Data.Text.splitOn "\n" + + -- This is the trim function we use after each variable interpolation + -- where we indent each line except the first line (since it's not a true + -- beginning of a line) + trimContinue text = Data.Text.intercalate "\n" lines_ + where + lines_ = case Data.Text.splitOn "\n" text of + [] -> [] + l:ls -> l:map (Data.Text.drop shortestIndent) ls + + -- This is the loop that drives whether or not to use `trimBegin` or + -- `trimContinue`. We call this function with `trimBegin`, but after the + -- first interpolation we switch permanently to `trimContinue` + process (Chunks ((x0, y0):xys) z) = + Chunks ((trimBegin x0, y0):xys') (trimContinue z) + where + xys' = [ (trimContinue x, y) | (x, y) <- xys ] + process (Chunks [] z) = + Chunks [] (trimBegin z) diff --git a/src/Dhall/Parser/Token.hs b/src/Dhall/Parser/Token.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Parser/Token.hs @@ -0,0 +1,616 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Parse Dhall tokens. Even though we don't have a tokenizer per-se this +--- module is useful for keeping some small parsing utilities. +module Dhall.Parser.Token where + +import Dhall.Parser.Combinators + +import Control.Applicative (Alternative(..)) +import Data.Functor (void) +import Data.Semigroup (Semigroup(..)) +import Data.Set (Set) +import Data.Text (Text) +import Dhall.Core +import Prelude hiding (const, pi) +import Text.Parser.Combinators (choice, try, ()) + +import qualified Control.Monad +import qualified Data.Char +import qualified Data.HashSet +import qualified Data.List.NonEmpty +import qualified Data.Set +import qualified Data.Text +import qualified Text.Parser.Char +import qualified Text.Parser.Combinators + +import Data.Scientific (Scientific) +import Numeric.Natural (Natural) +import Prelude hiding (const, pi) + +import qualified Text.Parser.Token + + +whitespace :: Parser () +whitespace = Text.Parser.Combinators.skipMany whitespaceChunk + +alpha :: Char -> Bool +alpha c = ('\x41' <= c && c <= '\x5A') || ('\x61' <= c && c <= '\x7A') + +digit :: Char -> Bool +digit c = '\x30' <= c && c <= '\x39' + +hexdig :: Char -> Bool +hexdig c = + ('0' <= c && c <= '9') + || ('A' <= c && c <= 'F') + || ('a' <= c && c <= 'f') + +doubleLiteral :: Parser Scientific +doubleLiteral = (do + sign <- fmap (\_ -> negate) (Text.Parser.Char.char '-') + <|> pure id + a <- Text.Parser.Token.scientific + return (sign a) ) "double literal" + +integerLiteral :: Parser Integer +integerLiteral = (do + let positive = fmap (\_ -> id ) (Text.Parser.Char.char '+') + let negative = fmap (\_ -> negate) (Text.Parser.Char.char '-') + sign <- positive <|> negative + a <- Text.Parser.Token.natural + return (sign a) ) "integer literal" + +naturalLiteral :: Parser Natural +naturalLiteral = (do + a <- Text.Parser.Token.natural + return (fromIntegral a) ) "natural literal" + +identifier :: Parser Var +identifier = do + x <- label + + let indexed = do + _ <- Text.Parser.Char.char '@' + Text.Parser.Token.natural + + n <- indexed <|> pure 0 + return (V x n) + +whitespaceChunk :: Parser () +whitespaceChunk = + choice + [ void (Text.Parser.Char.satisfy predicate) + , void (Text.Parser.Char.text "\r\n") + , lineComment + , blockComment + ] "whitespace" + where + predicate c = c == ' ' || c == '\t' || c == '\n' + +hexNumber :: Parser Int +hexNumber = choice [ hexDigit, hexUpper, hexLower ] + where + hexDigit = do + c <- Text.Parser.Char.satisfy predicate + return (Data.Char.ord c - Data.Char.ord '0') + where + predicate c = '0' <= c && c <= '9' + + hexUpper = do + c <- Text.Parser.Char.satisfy predicate + return (10 + Data.Char.ord c - Data.Char.ord 'A') + where + predicate c = 'A' <= c && c <= 'F' + + hexLower = do + c <- Text.Parser.Char.satisfy predicate + return (10 + Data.Char.ord c - Data.Char.ord 'a') + where + predicate c = 'a' <= c && c <= 'f' + +lineComment :: Parser () +lineComment = do + _ <- Text.Parser.Char.text "--" + Text.Parser.Combinators.skipMany notEndOfLine + endOfLine + return () + where + endOfLine = + void (Text.Parser.Char.char '\n' ) + <|> void (Text.Parser.Char.text "\r\n") + + notEndOfLine = void (Text.Parser.Char.satisfy predicate) + where + predicate c = ('\x20' <= c && c <= '\x10FFFF') || c == '\t' + +blockComment :: Parser () +blockComment = do + _ <- Text.Parser.Char.text "{-" + blockCommentContinue + +blockCommentChunk :: Parser () +blockCommentChunk = + choice + [ blockComment -- Nested block comment + , character + , endOfLine + ] + where + character = void (Text.Parser.Char.satisfy predicate) + where + predicate c = '\x20' <= c && c <= '\x10FFFF' || c == '\n' || c == '\t' + + endOfLine = void (Text.Parser.Char.text "\r\n") + +blockCommentContinue :: Parser () +blockCommentContinue = endOfComment <|> continue + where + endOfComment = void (Text.Parser.Char.text "-}") + + continue = do + blockCommentChunk + blockCommentContinue + + +simpleLabel :: Parser Text +simpleLabel = try (do + c <- Text.Parser.Char.satisfy headCharacter + cs <- many (Text.Parser.Char.satisfy tailCharacter) + let string = c:cs + let text = Data.Text.pack string + Control.Monad.guard (not (Data.HashSet.member text reservedIdentifiers)) + return text ) + where + headCharacter c = alpha c || c == '_' + + tailCharacter c = alpha c || digit c || c == '_' || c == '-' || c == '/' + +backtickLabel :: Parser Text +backtickLabel = do + _ <- Text.Parser.Char.char '`' + t <- some (Text.Parser.Char.satisfy predicate) + _ <- Text.Parser.Char.char '`' + return (Data.Text.pack t) + where + predicate c = alpha c || digit c || elem c ("-/_:." :: String) + +labels :: Parser (Set Text) +labels = do + _openBrace + xs <- nonEmptyLabels <|> emptyLabels + _closeBrace + return xs + where + emptyLabels = pure Data.Set.empty + + nonEmptyLabels = do + x <- label + xs <- many (do _ <- _comma; label) + noDuplicates (x : xs) + + +label :: Parser Text +label = (do + t <- backtickLabel <|> simpleLabel + whitespace + return t ) "label" + +bashEnvironmentVariable :: Parser Text +bashEnvironmentVariable = satisfy predicate0 <> star (satisfy predicate1) + where + predicate0 c = alpha c || c == '_' + + predicate1 c = alpha c || digit c || c == '_' + +posixEnvironmentVariable :: Parser Text +posixEnvironmentVariable = plus posixEnvironmentVariableCharacter + +posixEnvironmentVariableCharacter :: Parser Text +posixEnvironmentVariableCharacter = + ("\\" <> satisfy predicate0) <|> satisfy predicate1 + where + predicate0 c = c `elem` ("\"\\abfnrtv" :: String) + + predicate1 c = + ('\x20' <= c && c <= '\x21') + || ('\x23' <= c && c <= '\x3C') + || ('\x3E' <= c && c <= '\x5B') + || ('\x5D' <= c && c <= '\x7E') + +pathCharacter :: Char -> Bool +pathCharacter c = + ('\x21' <= c && c <= '\x22') + || ('\x24' <= c && c <= '\x27') + || ('\x2A' <= c && c <= '\x2B') + || ('\x2D' <= c && c <= '\x2E') + || ('\x30' <= c && c <= '\x3B') + || c == '\x3D' + || ('\x40' <= c && c <= '\x5A') + || ('\x5E' <= c && c <= '\x7A') + || c == '\x7C' + || c == '\x7E' + +pathComponent :: Parser Text +pathComponent = do + _ <- "/" :: Parser Text + string <- some (Text.Parser.Char.satisfy pathCharacter) + + return (Data.Text.pack string) + +file_ :: Parser File +file_ = do + path <- Data.List.NonEmpty.some1 pathComponent + + let directory = Directory (reverse (Data.List.NonEmpty.init path)) + let file = Data.List.NonEmpty.last path + + return (File {..}) + +scheme :: Parser Text +scheme = "http" <> option "s" + +httpRaw :: Parser (Text, File, Text) +httpRaw = do + prefixText <- scheme <> "://" <> authority + file <- file_ + suffixText <- option ("?" <> query) <> option ("#" <> fragment) + + return (prefixText, file, suffixText) + +authority :: Parser Text +authority = option (try (userinfo <> "@")) <> host <> option (":" <> port) + +userinfo :: Parser Text +userinfo = star (satisfy predicate <|> pctEncoded) + where + predicate c = unreserved c || subDelims c || c == ':' + +host :: Parser Text +host = choice [ ipLiteral, ipV4Address, regName ] + +port :: Parser Text +port = star (satisfy digit) + +ipLiteral :: Parser Text +ipLiteral = "[" <> (ipV6Address <|> ipVFuture) <> "]" + +ipVFuture :: Parser Text +ipVFuture = "v" <> plus (satisfy hexdig) <> "." <> plus (satisfy predicate) + where + predicate c = unreserved c || subDelims c || c == ':' + +ipV6Address :: Parser Text +ipV6Address = + choice + [ try alternative0 + , try alternative1 + , try alternative2 + , try alternative3 + , try alternative4 + , try alternative5 + , try alternative6 + , try alternative7 + , alternative8 + ] + where + alternative0 = count 6 (h16 <> ":") <> ls32 + + alternative1 = "::" <> count 5 (h16 <> ":") <> ls32 + + alternative2 = option h16 <> "::" <> count 4 (h16 <> ":") <> ls32 + + alternative3 = + option (range 0 1 (h16 <> ":") <> h16) + <> "::" + <> count 3 (h16 <> ":") + <> ls32 + + alternative4 = + option (range 0 2 (h16 <> ":") <> h16) + <> "::" + <> count 2 (h16 <> ":") + <> ls32 + + alternative5 = + option (range 0 3 (h16 <> ":") <> h16) <> "::" <> h16 <> ":" <> ls32 + + alternative6 = + option (range 0 4 (h16 <> ":") <> h16) <> "::" <> ls32 + + alternative7 = + option (range 0 5 (h16 <> ":") <> h16) <> "::" <> h16 + + alternative8 = + option (range 0 6 (h16 <> ":") <> h16) <> "::" + +h16 :: Parser Text +h16 = range 1 3 (satisfy hexdig) + +ls32 :: Parser Text +ls32 = (h16 <> ":" <> h16) <|> ipV4Address + +ipV4Address :: Parser Text +ipV4Address = decOctet <> "." <> decOctet <> "." <> decOctet <> "." <> decOctet + +decOctet :: Parser Text +decOctet = + choice + [ try alternative4 + , try alternative3 + , try alternative2 + , try alternative1 + , alternative0 + ] + where + alternative0 = satisfy digit + + alternative1 = satisfy predicate <> satisfy digit + where + predicate c = '\x31' <= c && c <= '\x39' + + alternative2 = "1" <> count 2 (satisfy digit) + + alternative3 = "2" <> satisfy predicate <> satisfy digit + where + predicate c = '\x30' <= c && c <= '\x34' + + alternative4 = "25" <> satisfy predicate + where + predicate c = '\x30' <= c && c <= '\x35' + +regName :: Parser Text +regName = star (satisfy predicate <|> pctEncoded) + where + predicate c = unreserved c || subDelims c + +pchar :: Parser Text +pchar = satisfy predicate <|> pctEncoded + where + predicate c = unreserved c || subDelims c || c == ':' || c == '@' + +query :: Parser Text +query = star (pchar <|> satisfy predicate) + where + predicate c = c == '/' || c == '?' + +fragment :: Parser Text +fragment = star (pchar <|> satisfy predicate) + where + predicate c = c == '/' || c == '?' + +pctEncoded :: Parser Text +pctEncoded = "%" <> count 2 (satisfy hexdig) + +subDelims :: Char -> Bool +subDelims c = c `elem` ("!$&'()*+,;=" :: String) + +unreserved :: Char -> Bool +unreserved c = + alpha c || digit c || c == '-' || c == '.' || c == '_' || c == '~' + +reserved :: Data.Text.Text -> Parser () +reserved x = do _ <- Text.Parser.Char.text x; whitespace + +_if :: Parser () +_if = reserved "if" + +_then :: Parser () +_then = reserved "then" + +_else :: Parser () +_else = reserved "else" + +_let :: Parser () +_let = reserved "let" + +_in :: Parser () +_in = reserved "in" + +_as :: Parser () +_as = reserved "as" + +_using :: Parser () +_using = reserved "using" + +_merge :: Parser () +_merge = reserved "merge" + +_constructors :: Parser () +_constructors = reserved "constructors" + +_NaturalFold :: Parser () +_NaturalFold = reserved "Natural/fold" + +_NaturalBuild :: Parser () +_NaturalBuild = reserved "Natural/build" + +_NaturalIsZero :: Parser () +_NaturalIsZero = reserved "Natural/isZero" + +_NaturalEven :: Parser () +_NaturalEven = reserved "Natural/even" + +_NaturalOdd :: Parser () +_NaturalOdd = reserved "Natural/odd" + +_NaturalToInteger :: Parser () +_NaturalToInteger = reserved "Natural/toInteger" + +_NaturalShow :: Parser () +_NaturalShow = reserved "Natural/show" + +_IntegerShow :: Parser () +_IntegerShow = reserved "Integer/show" + +_IntegerToDouble :: Parser () +_IntegerToDouble = reserved "Integer/toDouble" + +_DoubleShow :: Parser () +_DoubleShow = reserved "Double/show" + +_ListBuild :: Parser () +_ListBuild = reserved "List/build" + +_ListFold :: Parser () +_ListFold = reserved "List/fold" + +_ListLength :: Parser () +_ListLength = reserved "List/length" + +_ListHead :: Parser () +_ListHead = reserved "List/head" + +_ListLast :: Parser () +_ListLast = reserved "List/last" + +_ListIndexed :: Parser () +_ListIndexed = reserved "List/indexed" + +_ListReverse :: Parser () +_ListReverse = reserved "List/reverse" + +_OptionalFold :: Parser () +_OptionalFold = reserved "Optional/fold" + +_OptionalBuild :: Parser () +_OptionalBuild = reserved "Optional/build" + +_Bool :: Parser () +_Bool = reserved "Bool" + +_Optional :: Parser () +_Optional = reserved "Optional" + +_Natural :: Parser () +_Natural = reserved "Natural" + +_Integer :: Parser () +_Integer = reserved "Integer" + +_Double :: Parser () +_Double = reserved "Double" + +_Text :: Parser () +_Text = reserved "Text" + +_List :: Parser () +_List = reserved "List" + +_True :: Parser () +_True = reserved "True" + +_False :: Parser () +_False = reserved "False" + +_Type :: Parser () +_Type = reserved "Type" + +_Kind :: Parser () +_Kind = reserved "Kind" + +_equal :: Parser () +_equal = reserved "=" + +_or :: Parser () +_or = reserved "||" + +_plus :: Parser () +_plus = reserved "+" + +_textAppend :: Parser () +_textAppend = reserved "++" + +_listAppend :: Parser () +_listAppend = reserved "#" + +_and :: Parser () +_and = reserved "&&" + +_times :: Parser () +_times = reserved "*" + +_doubleEqual :: Parser () +_doubleEqual = reserved "==" + +_notEqual :: Parser () +_notEqual = reserved "!=" + +_dot :: Parser () +_dot = reserved "." + +_openBrace :: Parser () +_openBrace = reserved "{" + +_closeBrace :: Parser () +_closeBrace = reserved "}" + +_openBracket :: Parser () +_openBracket = reserved "[" + +_closeBracket :: Parser () +_closeBracket = reserved "]" + +_openAngle :: Parser () +_openAngle = reserved "<" + +_closeAngle :: Parser () +_closeAngle = reserved ">" + +_bar :: Parser () +_bar = reserved "|" + +_comma :: Parser () +_comma = reserved "," + +_openParens :: Parser () +_openParens = reserved "(" + +_closeParens :: Parser () +_closeParens = reserved ")" + +_colon :: Parser () +_colon = reserved ":" + +_at :: Parser () +_at = reserved "@" + +_missing :: Parser () +_missing = reserved "missing" + +_importAlt :: Parser () +_importAlt = reserved "?" + +_combine :: Parser () +_combine = do + void (Text.Parser.Char.char '∧' "\"∧\"") <|> void (Text.Parser.Char.text "/\\") + whitespace + +_combineTypes :: Parser () +_combineTypes = do + void (Text.Parser.Char.char '⩓' "\"⩓\"") <|> void (Text.Parser.Char.text "//\\\\") + whitespace + +_prefer :: Parser () +_prefer = do + void (Text.Parser.Char.char '⫽' "\"⫽\"") <|> void (Text.Parser.Char.text "//") + whitespace + +_lambda :: Parser () +_lambda = do + _ <- Text.Parser.Char.satisfy predicate + whitespace + where + predicate 'λ' = True + predicate '\\' = True + predicate _ = False + +_forall :: Parser () +_forall = do + void (Text.Parser.Char.char '∀' "\"∀\"") <|> void (Text.Parser.Char.text "forall") + whitespace + +_arrow :: Parser () +_arrow = do + void (Text.Parser.Char.char '→' "\"→\"") <|> void (Text.Parser.Char.text "->") + whitespace diff --git a/src/Dhall/Pretty/Internal.hs b/src/Dhall/Pretty/Internal.hs --- a/src/Dhall/Pretty/Internal.hs +++ b/src/Dhall/Pretty/Internal.hs @@ -10,12 +10,7 @@ Ann(..) , annToAnsiStyle , prettyExpr - , buildConst - , buildVar - , buildExpr - , buildNatural - , buildNumber - , buildScientific + , prettyVar , pretty , escapeText @@ -25,7 +20,11 @@ , prettyNatural , prettyNumber , prettyScientific + , prettyToStrictText + , prettyToString + , docToStrictText + , builtin , keyword , literal @@ -61,10 +60,8 @@ import Data.Monoid ((<>)) import Data.Scientific (Scientific) import Data.Set (Set) -import Data.Text.Lazy (Text) -import Data.Text.Lazy.Builder (Builder) +import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty, space) -import Formatting.Buildable (Buildable(..)) import Numeric.Natural (Natural) import Prelude hiding (succ) import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal @@ -74,10 +71,10 @@ import qualified Data.HashSet import qualified Data.List import qualified Data.Set -import qualified Data.Text.Lazy as Text -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty +import qualified Data.Text as Text +import qualified Data.Text.Prettyprint.Doc as Pretty +import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty +import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty {-| Annotation type used to tag elements in a pretty-printed document for syntax highlighting purposes @@ -103,7 +100,7 @@ -- | Pretty print an expression prettyExpr :: Pretty a => Expr s a -> Doc Ann -prettyExpr = prettyExprA +prettyExpr = prettyExpression {-| Internal utility for pretty-printing, used when generating element lists to supply to `enclose` or `enclose'`. This utility indicates that the @@ -313,25 +310,26 @@ short = literal "\"" <> foldMap prettyChunk a <> literal (prettyText b <> "\"") - hasNewLine builder = Text.any (== '\n') lazyText - where - lazyText = Builder.toLazyText builder + hasNewLine = Text.any (== '\n') prettyMultilineChunk (c, d) = - prettyMultilineBuilder c <> dollar <> lbrace <> prettyExprA d <> rbrace + prettyMultilineBuilder c + <> dollar + <> lbrace + <> prettyExpression d + <> rbrace prettyMultilineBuilder builder = literal (mconcat docs) where - lazyText = Builder.toLazyText (escapeSingleQuotedText builder) - - lazyLines = Text.splitOn "\n" lazyText + lazyLines = Text.splitOn "\n" (escapeSingleQuotedText builder) docs = Data.List.intersperse Pretty.hardline (fmap Pretty.pretty lazyLines) - prettyChunk (c, d) = prettyText c <> syntax "${" <> prettyExprA d <> syntax rbrace + prettyChunk (c, d) = + prettyText c <> syntax "${" <> prettyExpression d <> syntax rbrace - prettyText t = literal (Pretty.pretty (Builder.toLazyText (escapeText t))) + prettyText t = literal (Pretty.pretty (escapeText t)) prettyConst :: Const -> Doc Ann prettyConst Type = builtin "Type" @@ -341,25 +339,8 @@ prettyVar (V x 0) = label (Pretty.unAnnotate (prettyLabel x)) prettyVar (V x n) = label (Pretty.unAnnotate (prettyLabel x <> "@" <> prettyNumber n)) -prettyExprA :: Pretty a => Expr s a -> Doc Ann -prettyExprA a0@(Annot _ _) = - enclose' - "" - " " - (" " <> colon <> " ") - (colon <> space) - (fmap duplicate (docs a0)) - where - docs (Annot a b) = prettyExprB a : docs b - docs (Note _ b) = docs b - docs b = [ prettyExprB b ] -prettyExprA (Note _ a) = - prettyExprA a -prettyExprA a0 = - prettyExprB a0 - -prettyExprB :: Pretty a => Expr s a -> Doc Ann -prettyExprB a0@(Lam _ _ _) = arrows (fmap duplicate (docs a0)) +prettyExpression :: Pretty a => Expr s a -> Doc Ann +prettyExpression a0@(Lam _ _ _) = arrows (fmap duplicate (docs a0)) where docs (Lam a b c) = Pretty.group (Pretty.flatAlt long short) : docs c where @@ -369,7 +350,7 @@ <> prettyLabel a <> Pretty.hardline <> (colon <> space) - <> prettyExprA b + <> prettyExpression b <> Pretty.hardline <> rparen ) @@ -377,56 +358,54 @@ short = (lambda <> lparen) <> prettyLabel a <> (space <> colon <> space) - <> prettyExprA b + <> prettyExpression b <> rparen docs (Note _ c) = docs c - docs c = [ prettyExprB c ] -prettyExprB a0@(BoolIf _ _ _) = - enclose' "" " " (space <> keyword "else" <> space) (Pretty.hardline <> keyword "else" <> " ") (fmap duplicate (docs a0)) + docs c = [ prettyExpression c ] +prettyExpression a0@(BoolIf _ _ _) = + Pretty.group (Pretty.flatAlt long short) where - docs (BoolIf a b c) = - Pretty.group (Pretty.flatAlt long short) : docs c - where - long = - Pretty.align - ( (keyword "if" <> " ") - <> prettyExprA a - <> Pretty.hardline - <> (keyword "then" <> " ") - <> prettyExprA b - ) + prefixesLong = + " " + : cycle + [ Pretty.hardline <> keyword "then" <> " " + , Pretty.hardline <> keyword "else" <> " " + ] - short = (keyword "if" <> " ") - <> prettyExprA a - <> (space <> keyword "then" <> space) - <> prettyExprA b - docs (Note _ c) = docs c - docs c = [ prettyExprB c ] -prettyExprB a0@(Pi _ _ _) = - arrows (fmap duplicate (docs a0)) - where - docs (Pi "_" b c) = prettyExprC b : docs c - docs (Pi a b c) = Pretty.group (Pretty.flatAlt long short) : docs c + prefixesShort = + "" + : cycle + [ space <> keyword "then" <> space + , space <> keyword "else" <> space + ] + + longLines = zipWith (<>) prefixesLong (docsLong a0) + + long = + Pretty.align (mconcat (Data.List.intersperse Pretty.hardline longLines)) + + short = mconcat (zipWith (<>) prefixesShort (docsShort a0)) + + docsLong (BoolIf a b c) = + docLong ++ docsLong c where - long = forall <> space - <> Pretty.align - ( lparen <> space - <> prettyLabel a - <> Pretty.hardline - <> colon <> space - <> prettyExprA b - <> Pretty.hardline - <> rparen - ) + docLong = + [ keyword "if" <> " " <> prettyExpression a + , prettyExpression b + ] + docsLong (Note _ c) = docsLong c + docsLong c = [ prettyExpression c ] - short = forall <> lparen - <> prettyLabel a - <> space <> colon <> space - <> prettyExprA b - <> rparen - docs (Note _ c) = docs c - docs c = [ prettyExprB c ] -prettyExprB a0@(Let _ _ _ _) = + docsShort (BoolIf a b c) = + docShort ++ docsShort c + where + docShort = + [ keyword "if" <> " " <> prettyExpression a + , prettyExpression b + ] + docsShort (Note _ c) = docsShort c + docsShort c = [ prettyExpression c ] +prettyExpression a0@(Let _ _ _ _) = enclose' "" " " (space <> keyword "in" <> space) (Pretty.hardline <> keyword "in" <> " ") (fmap duplicate (docs a0)) where @@ -439,13 +418,13 @@ <> space <> equals <> Pretty.hardline <> " " - <> prettyExprA c + <> prettyExpression c ) short = keyword "let" <> space <> prettyLabel a <> (space <> equals <> space) - <> prettyExprA c + <> prettyExpression c docs (Let a (Just b) c d) = Pretty.group (Pretty.flatAlt long short) : docs d where @@ -454,328 +433,381 @@ ( prettyLabel a <> Pretty.hardline <> colon <> space - <> prettyExprA b + <> prettyExpression b <> Pretty.hardline <> equals <> space - <> prettyExprA c + <> prettyExpression c ) short = keyword "let" <> space <> prettyLabel a <> space <> colon <> space - <> prettyExprA b + <> prettyExpression b <> space <> equals <> space - <> prettyExprA c + <> prettyExpression c docs (Note _ d) = docs d docs d = - [ prettyExprB d ] -prettyExprB (ListLit Nothing b) = - list (map prettyExprA (Data.Foldable.toList b)) -prettyExprB (ListLit (Just a) b) = - list (map prettyExprA (Data.Foldable.toList b)) - <> " : " - <> prettyExprD (App List a) -prettyExprB (OptionalLit a b) = - list (map prettyExprA (Data.Foldable.toList b)) - <> " : " - <> prettyExprD (App Optional a) -prettyExprB (Merge a b (Just c)) = + [ prettyExpression d ] +prettyExpression a0@(Pi _ _ _) = + arrows (fmap duplicate (docs a0)) + where + docs (Pi "_" b c) = prettyOperatorExpression b : docs c + docs (Pi a b c) = Pretty.group (Pretty.flatAlt long short) : docs c + where + long = forall <> space + <> Pretty.align + ( lparen <> space + <> prettyLabel a + <> Pretty.hardline + <> colon <> space + <> prettyExpression b + <> Pretty.hardline + <> rparen + ) + + short = forall <> lparen + <> prettyLabel a + <> space <> colon <> space + <> prettyExpression b + <> rparen + docs (Note _ c) = docs c + docs c = [ prettyExpression c ] +prettyExpression (Note _ a) = + prettyExpression a +prettyExpression a0 = + prettyAnnotatedExpression a0 + +prettyAnnotatedExpression :: Pretty a => Expr s a -> Doc Ann +prettyAnnotatedExpression (Merge a b (Just c)) = Pretty.group (Pretty.flatAlt long short) where long = Pretty.align ( keyword "merge" <> Pretty.hardline - <> prettyExprE a + <> prettyImportExpression a <> Pretty.hardline - <> prettyExprE b + <> prettyImportExpression b <> Pretty.hardline <> colon <> space - <> prettyExprD c + <> prettyApplicationExpression c ) short = keyword "merge" <> space - <> prettyExprE a + <> prettyImportExpression a <> " " - <> prettyExprE b + <> prettyImportExpression b <> space <> colon <> space - <> prettyExprD c -prettyExprB (Merge a b Nothing) = + <> prettyApplicationExpression c +prettyAnnotatedExpression (Merge a b Nothing) = Pretty.group (Pretty.flatAlt long short) where long = Pretty.align ( keyword "merge" <> Pretty.hardline - <> prettyExprE a + <> prettyImportExpression a <> Pretty.hardline - <> prettyExprE b + <> prettyImportExpression b ) short = keyword "merge" <> space - <> prettyExprE a + <> prettyImportExpression a <> " " - <> prettyExprE b -prettyExprB (Note _ b) = - prettyExprB b -prettyExprB a = - prettyExprC a + <> prettyImportExpression b +prettyAnnotatedExpression a0@(Annot _ _) = + enclose' + "" + " " + (" " <> colon <> " ") + (colon <> space) + (fmap duplicate (docs a0)) + where + docs (Annot a b) = prettyOperatorExpression a : docs b + docs (Note _ b) = docs b + docs b = [ prettyExpression b ] +prettyAnnotatedExpression (ListLit (Just a) b) = + list (map prettyExpression (Data.Foldable.toList b)) + <> " : " + <> prettyApplicationExpression (App List a) +prettyAnnotatedExpression (OptionalLit a b) = + list (map prettyExpression (Data.Foldable.toList b)) + <> " : " + <> prettyApplicationExpression (App Optional a) +prettyAnnotatedExpression (Note _ a) = + prettyAnnotatedExpression a +prettyAnnotatedExpression a0 = + prettyOperatorExpression a0 -prettyExprC :: Pretty a => Expr s a -> Doc Ann -prettyExprC = prettyExprC0 +prettyOperatorExpression :: Pretty a => Expr s a -> Doc Ann +prettyOperatorExpression = prettyOrExpression -prettyExprC0 :: Pretty a => Expr s a -> Doc Ann -prettyExprC0 a0@(BoolOr _ _) = +prettyOrExpression :: Pretty a => Expr s a -> Doc Ann +prettyOrExpression a0@(BoolOr _ _) = enclose' "" " " (space <> operator "||" <> space) (operator "||" <> " ") (fmap duplicate (docs a0)) where - docs (BoolOr a b) = prettyExprC1 a : docs b + docs (BoolOr a b) = prettyPlusExpression a : docs b docs (Note _ b) = docs b - docs b = [ prettyExprC1 b ] -prettyExprC0 (Note _ a) = - prettyExprC0 a -prettyExprC0 a0 = - prettyExprC1 a0 - -prettyExprC1 :: Pretty a => Expr s a -> Doc Ann -prettyExprC1 a0@(TextAppend _ _) = - enclose' "" " " (" " <> operator "++" <> " ") (operator "++" <> " ") (fmap duplicate (docs a0)) - where - docs (TextAppend a b) = prettyExprC2 a : docs b - docs (Note _ b) = docs b - docs b = [ prettyExprC2 b ] -prettyExprC1 (Note _ a) = - prettyExprC1 a -prettyExprC1 a0 = - prettyExprC2 a0 + docs b = [ prettyPlusExpression b ] +prettyOrExpression (Note _ a) = + prettyOrExpression a +prettyOrExpression a0 = + prettyPlusExpression a0 -prettyExprC2 :: Pretty a => Expr s a -> Doc Ann -prettyExprC2 a0@(NaturalPlus _ _) = +prettyPlusExpression :: Pretty a => Expr s a -> Doc Ann +prettyPlusExpression a0@(NaturalPlus _ _) = enclose' "" " " (" " <> operator "+" <> " ") (operator "+" <> " ") (fmap duplicate (docs a0)) where - docs (NaturalPlus a b) = prettyExprC3 a : docs b + docs (NaturalPlus a b) = prettyTextAppendExpression a : docs b docs (Note _ b) = docs b - docs b = [ prettyExprC3 b ] -prettyExprC2 (Note _ a) = - prettyExprC2 a -prettyExprC2 a0 = - prettyExprC3 a0 + docs b = [ prettyTextAppendExpression b ] +prettyPlusExpression (Note _ a) = + prettyPlusExpression a +prettyPlusExpression a0 = + prettyTextAppendExpression a0 -prettyExprC3 :: Pretty a => Expr s a -> Doc Ann -prettyExprC3 a0@(ListAppend _ _) = +prettyTextAppendExpression :: Pretty a => Expr s a -> Doc Ann +prettyTextAppendExpression a0@(TextAppend _ _) = + enclose' "" " " (" " <> operator "++" <> " ") (operator "++" <> " ") (fmap duplicate (docs a0)) + where + docs (TextAppend a b) = prettyListAppendExpression a : docs b + docs (Note _ b) = docs b + docs b = [ prettyListAppendExpression b ] +prettyTextAppendExpression (Note _ a) = + prettyTextAppendExpression a +prettyTextAppendExpression a0 = + prettyListAppendExpression a0 + +prettyListAppendExpression :: Pretty a => Expr s a -> Doc Ann +prettyListAppendExpression a0@(ListAppend _ _) = enclose' "" " " (" " <> operator "#" <> " ") (operator "#" <> " ") (fmap duplicate (docs a0)) where - docs (ListAppend a b) = prettyExprC4 a : docs b + docs (ListAppend a b) = prettyAndExpression a : docs b docs (Note _ b) = docs b - docs b = [ prettyExprC4 b ] -prettyExprC3 (Note _ a) = - prettyExprC3 a -prettyExprC3 a0 = - prettyExprC4 a0 + docs b = [ prettyAndExpression b ] +prettyListAppendExpression (Note _ a) = + prettyListAppendExpression a +prettyListAppendExpression a0 = + prettyAndExpression a0 -prettyExprC4 :: Pretty a => Expr s a -> Doc Ann -prettyExprC4 a0@(BoolAnd _ _) = +prettyAndExpression :: Pretty a => Expr s a -> Doc Ann +prettyAndExpression a0@(BoolAnd _ _) = enclose' "" " " (" " <> operator "&&" <> " ") (operator "&&" <> " ") (fmap duplicate (docs a0)) where - docs (BoolAnd a b) = prettyExprC5 a : docs b + docs (BoolAnd a b) = prettyCombineExpression a : docs b docs (Note _ b) = docs b - docs b = [ prettyExprC5 b ] -prettyExprC4 (Note _ a) = - prettyExprC4 a -prettyExprC4 a0 = - prettyExprC5 a0 + docs b = [ prettyCombineExpression b ] +prettyAndExpression (Note _ a) = + prettyAndExpression a +prettyAndExpression a0 = + prettyCombineExpression a0 -prettyExprC5 :: Pretty a => Expr s a -> Doc Ann -prettyExprC5 a0@(Combine _ _) = +prettyCombineExpression :: Pretty a => Expr s a -> Doc Ann +prettyCombineExpression a0@(Combine _ _) = enclose' "" " " (" " <> operator "∧" <> " ") (operator "∧" <> " ") (fmap duplicate (docs a0)) where - docs (Combine a b) = prettyExprC6 a : docs b + docs (Combine a b) = prettyPreferExpression a : docs b docs (Note _ b) = docs b - docs b = [ prettyExprC6 b ] -prettyExprC5 (Note _ a) = - prettyExprC5 a -prettyExprC5 a0 = - prettyExprC6 a0 + docs b = [ prettyPreferExpression b ] +prettyCombineExpression (Note _ a) = + prettyCombineExpression a +prettyCombineExpression a0 = + prettyPreferExpression a0 -prettyExprC6 :: Pretty a => Expr s a -> Doc Ann -prettyExprC6 a0@(Prefer _ _) = +prettyPreferExpression :: Pretty a => Expr s a -> Doc Ann +prettyPreferExpression a0@(Prefer _ _) = enclose' "" " " (" " <> operator "⫽" <> " ") (operator "⫽" <> " ") (fmap duplicate (docs a0)) where - docs (Prefer a b) = prettyExprC7 a : docs b + docs (Prefer a b) = prettyCombineTypesExpression a : docs b docs (Note _ b) = docs b - docs b = [ prettyExprC7 b ] -prettyExprC6 (Note _ a) = - prettyExprC6 a -prettyExprC6 a0 = - prettyExprC7 a0 + docs b = [ prettyCombineTypesExpression b ] +prettyPreferExpression (Note _ a) = + prettyPreferExpression a +prettyPreferExpression a0 = + prettyCombineTypesExpression a0 -prettyExprC7 :: Pretty a => Expr s a -> Doc Ann -prettyExprC7 a0@(CombineTypes _ _) = +prettyCombineTypesExpression :: Pretty a => Expr s a -> Doc Ann +prettyCombineTypesExpression a0@(CombineTypes _ _) = enclose' "" " " (" " <> operator "⩓" <> " ") (operator "⩓" <> " ") (fmap duplicate (docs a0)) where - docs (CombineTypes a b) = prettyExprC8 a : docs b + docs (CombineTypes a b) = prettyTimesExpression a : docs b docs (Note _ b) = docs b - docs b = [ prettyExprC8 b ] -prettyExprC7 (Note _ a) = - prettyExprC7 a -prettyExprC7 a0 = - prettyExprC8 a0 + docs b = [ prettyTimesExpression b ] +prettyCombineTypesExpression (Note _ a) = + prettyCombineTypesExpression a +prettyCombineTypesExpression a0 = + prettyTimesExpression a0 -prettyExprC8 :: Pretty a => Expr s a -> Doc Ann -prettyExprC8 a0@(NaturalTimes _ _) = +prettyTimesExpression :: Pretty a => Expr s a -> Doc Ann +prettyTimesExpression a0@(NaturalTimes _ _) = enclose' "" " " (" " <> operator "*" <> " ") (operator "*" <> " ") (fmap duplicate (docs a0)) where - docs (NaturalTimes a b) = prettyExprC9 a : docs b + docs (NaturalTimes a b) = prettyEqualExpression a : docs b docs (Note _ b) = docs b - docs b = [ prettyExprC9 b ] -prettyExprC8 (Note _ a) = - prettyExprC8 a -prettyExprC8 a0 = - prettyExprC9 a0 + docs b = [ prettyEqualExpression b ] +prettyTimesExpression (Note _ a) = + prettyTimesExpression a +prettyTimesExpression a0 = + prettyEqualExpression a0 -prettyExprC9 :: Pretty a => Expr s a -> Doc Ann -prettyExprC9 a0@(BoolEQ _ _) = +prettyEqualExpression :: Pretty a => Expr s a -> Doc Ann +prettyEqualExpression a0@(BoolEQ _ _) = enclose' "" " " (" " <> operator "==" <> " ") (operator "==" <> " ") (fmap duplicate (docs a0)) where - docs (BoolEQ a b) = prettyExprC10 a : docs b + docs (BoolEQ a b) = prettyNotEqualExpression a : docs b docs (Note _ b) = docs b - docs b = [ prettyExprC10 b ] -prettyExprC9 (Note _ a) = - prettyExprC9 a -prettyExprC9 a0 = - prettyExprC10 a0 + docs b = [ prettyNotEqualExpression b ] +prettyEqualExpression (Note _ a) = + prettyEqualExpression a +prettyEqualExpression a0 = + prettyNotEqualExpression a0 -prettyExprC10 :: Pretty a => Expr s a -> Doc Ann -prettyExprC10 a0@(BoolNE _ _) = +prettyNotEqualExpression :: Pretty a => Expr s a -> Doc Ann +prettyNotEqualExpression a0@(BoolNE _ _) = enclose' "" " " (" " <> operator "!=" <> " ") (operator "!=" <> " ") (fmap duplicate (docs a0)) where - docs (BoolNE a b) = prettyExprD a : docs b + docs (BoolNE a b) = prettyApplicationExpression a : docs b docs (Note _ b) = docs b - docs b = [ prettyExprD b ] -prettyExprC10 (Note _ a) = - prettyExprC10 a -prettyExprC10 a0 = - prettyExprD a0 + docs b = [ prettyApplicationExpression b ] +prettyNotEqualExpression (Note _ a) = + prettyNotEqualExpression a +prettyNotEqualExpression a0 = + prettyApplicationExpression a0 -prettyExprD :: Pretty a => Expr s a -> Doc Ann -prettyExprD a0 = case a0 of +prettyApplicationExpression :: Pretty a => Expr s a -> Doc Ann +prettyApplicationExpression a0 = case a0 of App _ _ -> result Constructors _ -> result - Note _ b -> prettyExprD b - _ -> prettyExprE a0 + Note _ b -> prettyApplicationExpression b + _ -> prettyImportExpression a0 where result = enclose' "" "" " " "" (fmap duplicate (reverse (docs a0))) - docs (App a b) = prettyExprE b : docs a - docs (Constructors b) = [ prettyExprE b , keyword "constructors" ] + docs (App a b) = prettyImportExpression b : docs a + docs (Constructors b) = [ prettyImportExpression b , keyword "constructors" ] docs (Note _ b) = docs b - docs b = [ prettyExprE b ] + docs b = [ prettyImportExpression b ] -prettyExprE :: Pretty a => Expr s a -> Doc Ann -prettyExprE (Field a b) = prettyExprE a <> dot <> prettyLabel b -prettyExprE (Project a b) = prettyExprE a <> dot <> prettyLabels b -prettyExprE (Note _ b) = prettyExprE b -prettyExprE a = prettyExprF a +prettyImportExpression :: Pretty a => Expr s a -> Doc Ann +prettyImportExpression (Embed a) = + Pretty.pretty a +prettyImportExpression (Note _ a) = + prettyImportExpression a +prettyImportExpression a0 = + prettySelectorExpression a0 -prettyExprF :: Pretty a => Expr s a -> Doc Ann -prettyExprF (Var a) = +prettySelectorExpression :: Pretty a => Expr s a -> Doc Ann +prettySelectorExpression (Field a b) = + prettySelectorExpression a <> dot <> prettyLabel b +prettySelectorExpression (Project a b) = + prettySelectorExpression a <> dot <> prettyLabels b +prettySelectorExpression (Note _ b) = + prettySelectorExpression b +prettySelectorExpression a0 = + prettyPrimitiveExpression a0 + +prettyPrimitiveExpression :: Pretty a => Expr s a -> Doc Ann +prettyPrimitiveExpression (Var a) = prettyVar a -prettyExprF (Const k) = +prettyPrimitiveExpression (Const k) = prettyConst k -prettyExprF Bool = +prettyPrimitiveExpression Bool = builtin "Bool" -prettyExprF Natural = +prettyPrimitiveExpression Natural = builtin "Natural" -prettyExprF NaturalFold = +prettyPrimitiveExpression NaturalFold = builtin "Natural/fold" -prettyExprF NaturalBuild = +prettyPrimitiveExpression NaturalBuild = builtin "Natural/build" -prettyExprF NaturalIsZero = +prettyPrimitiveExpression NaturalIsZero = builtin "Natural/isZero" -prettyExprF NaturalEven = +prettyPrimitiveExpression NaturalEven = builtin "Natural/even" -prettyExprF NaturalOdd = +prettyPrimitiveExpression NaturalOdd = builtin "Natural/odd" -prettyExprF NaturalToInteger = +prettyPrimitiveExpression NaturalToInteger = builtin "Natural/toInteger" -prettyExprF NaturalShow = +prettyPrimitiveExpression NaturalShow = builtin "Natural/show" -prettyExprF Integer = +prettyPrimitiveExpression Integer = builtin "Integer" -prettyExprF IntegerShow = +prettyPrimitiveExpression IntegerShow = builtin "Integer/show" -prettyExprF Double = +prettyPrimitiveExpression IntegerToDouble = + builtin "Integer/toDouble" +prettyPrimitiveExpression Double = builtin "Double" -prettyExprF DoubleShow = +prettyPrimitiveExpression DoubleShow = builtin "Double/show" -prettyExprF Text = +prettyPrimitiveExpression Text = builtin "Text" -prettyExprF List = +prettyPrimitiveExpression List = builtin "List" -prettyExprF ListBuild = +prettyPrimitiveExpression ListBuild = builtin "List/build" -prettyExprF ListFold = +prettyPrimitiveExpression ListFold = builtin "List/fold" -prettyExprF ListLength = +prettyPrimitiveExpression ListLength = builtin "List/length" -prettyExprF ListHead = +prettyPrimitiveExpression ListHead = builtin "List/head" -prettyExprF ListLast = +prettyPrimitiveExpression ListLast = builtin "List/last" -prettyExprF ListIndexed = +prettyPrimitiveExpression ListIndexed = builtin "List/indexed" -prettyExprF ListReverse = +prettyPrimitiveExpression ListReverse = builtin "List/reverse" -prettyExprF Optional = +prettyPrimitiveExpression Optional = builtin "Optional" -prettyExprF OptionalFold = +prettyPrimitiveExpression OptionalFold = builtin "Optional/fold" -prettyExprF OptionalBuild = +prettyPrimitiveExpression OptionalBuild = builtin "Optional/build" -prettyExprF (BoolLit True) = +prettyPrimitiveExpression (BoolLit True) = builtin "True" -prettyExprF (BoolLit False) = +prettyPrimitiveExpression (BoolLit False) = builtin "False" -prettyExprF (IntegerLit a) +prettyPrimitiveExpression (IntegerLit a) | 0 <= a = literal "+" <> prettyNumber a | otherwise = prettyNumber a -prettyExprF (NaturalLit a) = +prettyPrimitiveExpression (NaturalLit a) = prettyNatural a -prettyExprF (DoubleLit a) = +prettyPrimitiveExpression (DoubleLit a) = prettyScientific a -prettyExprF (TextLit a) = +prettyPrimitiveExpression (TextLit a) = prettyChunks a -prettyExprF (Record a) = +prettyPrimitiveExpression (Record a) = prettyRecord a -prettyExprF (RecordLit a) = +prettyPrimitiveExpression (RecordLit a) = prettyRecordLit a -prettyExprF (Union a) = +prettyPrimitiveExpression (Union a) = prettyUnion a -prettyExprF (UnionLit a b c) = +prettyPrimitiveExpression (UnionLit a b c) = prettyUnionLit a b c -prettyExprF (ListLit Nothing b) = - list (map prettyExprA (Data.Foldable.toList b)) -prettyExprF (Embed a) = - Pretty.pretty a -prettyExprF (Note _ b) = - prettyExprF b -prettyExprF a = +prettyPrimitiveExpression (ListLit Nothing b) = + list (map prettyExpression (Data.Foldable.toList b)) +prettyPrimitiveExpression (Note _ b) = + prettyPrimitiveExpression b +prettyPrimitiveExpression a = Pretty.group (Pretty.flatAlt long short) where - long = Pretty.align (lparen <> space <> prettyExprA a <> Pretty.hardline <> rparen) + long = + Pretty.align + (lparen <> space <> prettyExpression a <> Pretty.hardline <> rparen) - short = lparen <> prettyExprA a <> rparen + short = lparen <> prettyExpression a <> rparen prettyKeyValue :: Pretty a => Doc Ann -> (Text, Expr s a) -> (Doc Ann, Doc Ann) prettyKeyValue separator (key, value) = - ( prettyLabel key <> " " <> separator <> " " <> prettyExprA value + ( prettyLabel key <> " " <> separator <> " " <> prettyExpression value , prettyLabel key <> " " <> separator <> long ) where - long = Pretty.hardline <> " " <> prettyExprA value + long = Pretty.hardline <> " " <> prettyExpression value prettyRecord :: Pretty a => InsOrdHashMap Text (Expr s a) -> Doc Ann prettyRecord = @@ -803,56 +835,27 @@ -- | Pretty-print a value pretty :: Pretty a => a -> Text -pretty = Pretty.renderLazy . Pretty.layoutPretty options . Pretty.pretty +pretty = Pretty.renderStrict . Pretty.layoutPretty options . Pretty.pretty where options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded } --- | Builder corresponding to the @label@ token in "Dhall.Parser" -buildLabel :: Text -> Builder -buildLabel l = case Text.uncons l of - Just (h, t) - | headCharacter h && Text.all tailCharacter t && not (Data.HashSet.member l reservedIdentifiers) - -> build l - _ -> "`" <> build l <> "`" - - --- | Builder corresponding to the @number@ token in "Dhall.Parser" -buildNumber :: Integer -> Builder -buildNumber a = build (show a) - --- | Builder corresponding to the @natural@ token in "Dhall.Parser" -buildNatural :: Natural -> Builder -buildNatural a = build (show a) - --- | Builder corresponding to the @double@ token in "Dhall.Parser" -buildScientific :: Scientific -> Builder -buildScientific = build . show - --- | Builder corresponding to the @text@ token in "Dhall.Parser" -buildChunks :: Buildable a => Chunks s a -> Builder -buildChunks (Chunks a b) = "\"" <> foldMap buildChunk a <> escapeText b <> "\"" - where - buildChunk (c, d) = escapeText c <> "${" <> buildExprA d <> "}" - --- | Escape a `Builder` literal using Dhall's escaping rules for single-quoted +-- | Escape a `Text` literal using Dhall's escaping rules for single-quoted -- @Text@ -escapeSingleQuotedText :: Builder -> Builder +escapeSingleQuotedText :: Text -> Text escapeSingleQuotedText inputBuilder = outputBuilder where - inputText = Builder.toLazyText inputBuilder - - outputText = substitute "${" "''${" (substitute "''" "'''" inputText) + outputText = substitute "${" "''${" (substitute "''" "'''" inputBuilder) - outputBuilder = Builder.fromLazyText outputText + outputBuilder = outputText substitute before after = Text.intercalate after . Text.splitOn before -{-| Escape a `Builder` literal using Dhall's escaping rules - +{-| Escape a `Text` literal using Dhall's escaping rules + Note that the result does not include surrounding quotes -} -escapeText :: Builder -> Builder -escapeText a = Builder.fromLazyText (Text.concatMap adapt text) +escapeText :: Text -> Text +escapeText text = Text.concatMap adapt text where adapt c | '\x20' <= c && c <= '\x21' = Text.singleton c @@ -882,331 +885,16 @@ | n < 10 = Data.Char.chr (Data.Char.ord '0' + n) | otherwise = Data.Char.chr (Data.Char.ord 'A' + n - 10) - text = Builder.toLazyText a - --- | Builder corresponding to the @expr@ parser in "Dhall.Parser" -buildExpr :: Buildable a => Expr s a -> Builder -buildExpr = buildExprA - --- | Builder corresponding to the @exprA@ parser in "Dhall.Parser" -buildExprA :: Buildable a => Expr s a -> Builder -buildExprA (Annot a b) = buildExprB a <> " : " <> buildExprA b -buildExprA (Note _ b) = buildExprA b -buildExprA a = buildExprB a - --- | Builder corresponding to the @exprB@ parser in "Dhall.Parser" -buildExprB :: Buildable a => Expr s a -> Builder -buildExprB (Lam a b c) = - "λ(" - <> buildLabel a - <> " : " - <> buildExprA b - <> ") → " - <> buildExprB c -buildExprB (BoolIf a b c) = - "if " - <> buildExprA a - <> " then " - <> buildExprA b - <> " else " - <> buildExprA c -buildExprB (Pi "_" b c) = - buildExprC b - <> " → " - <> buildExprB c -buildExprB (Pi a b c) = - "∀(" - <> buildLabel a - <> " : " - <> buildExprA b - <> ") → " - <> buildExprB c -buildExprB (Let a Nothing c d) = - "let " - <> buildLabel a - <> " = " - <> buildExprA c - <> " in " - <> buildExprB d -buildExprB (Let a (Just b) c d) = - "let " - <> buildLabel a - <> " : " - <> buildExprA b - <> " = " - <> buildExprA c - <> " in " - <> buildExprB d -buildExprB (ListLit Nothing b) = - "[" <> buildElems (Data.Foldable.toList b) <> "]" -buildExprB (ListLit (Just a) b) = - "[" <> buildElems (Data.Foldable.toList b) <> "] : List " <> buildExprE a -buildExprB (OptionalLit a b) = - "[" <> buildElems (Data.Foldable.toList b) <> "] : Optional " <> buildExprE a -buildExprB (Merge a b (Just c)) = - "merge " <> buildExprE a <> " " <> buildExprE b <> " : " <> buildExprD c -buildExprB (Merge a b Nothing) = - "merge " <> buildExprE a <> " " <> buildExprE b -buildExprB (Note _ b) = - buildExprB b -buildExprB a = - buildExprC a - --- | Builder corresponding to the @exprC@ parser in "Dhall.Parser" -buildExprC :: Buildable a => Expr s a -> Builder -buildExprC = buildExprC0 - --- | Builder corresponding to the @exprC0@ parser in "Dhall.Parser" -buildExprC0 :: Buildable a => Expr s a -> Builder -buildExprC0 (BoolOr a b) = buildExprC1 a <> " || " <> buildExprC0 b -buildExprC0 (Note _ b) = buildExprC0 b -buildExprC0 a = buildExprC1 a - --- | Builder corresponding to the @exprC1@ parser in "Dhall.Parser" -buildExprC1 :: Buildable a => Expr s a -> Builder -buildExprC1 (TextAppend a b) = buildExprC2 a <> " ++ " <> buildExprC1 b -buildExprC1 (Note _ b) = buildExprC1 b -buildExprC1 a = buildExprC2 a - --- | Builder corresponding to the @exprC2@ parser in "Dhall.Parser" -buildExprC2 :: Buildable a => Expr s a -> Builder -buildExprC2 (NaturalPlus a b) = buildExprC3 a <> " + " <> buildExprC2 b -buildExprC2 (Note _ b) = buildExprC2 b -buildExprC2 a = buildExprC3 a - --- | Builder corresponding to the @exprC3@ parser in "Dhall.Parser" -buildExprC3 :: Buildable a => Expr s a -> Builder -buildExprC3 (ListAppend a b) = buildExprC4 a <> " # " <> buildExprC3 b -buildExprC3 (Note _ b) = buildExprC3 b -buildExprC3 a = buildExprC4 a - --- | Builder corresponding to the @exprC4@ parser in "Dhall.Parser" -buildExprC4 :: Buildable a => Expr s a -> Builder -buildExprC4 (BoolAnd a b) = buildExprC5 a <> " && " <> buildExprC4 b -buildExprC4 (Note _ b) = buildExprC4 b -buildExprC4 a = buildExprC5 a - --- | Builder corresponding to the @exprC5@ parser in "Dhall.Parser" -buildExprC5 :: Buildable a => Expr s a -> Builder -buildExprC5 (Combine a b) = buildExprC6 a <> " ∧ " <> buildExprC5 b -buildExprC5 (Note _ b) = buildExprC5 b -buildExprC5 a = buildExprC6 a - --- | Builder corresponding to the @exprC6@ parser in "Dhall.Parser" -buildExprC6 :: Buildable a => Expr s a -> Builder -buildExprC6 (Prefer a b) = buildExprC7 a <> " ⫽ " <> buildExprC6 b -buildExprC6 (Note _ b) = buildExprC6 b -buildExprC6 a = buildExprC7 a - --- | Builder corresponding to the @exprC7@ parser in "Dhall.Parser" -buildExprC7 :: Buildable a => Expr s a -> Builder -buildExprC7 (CombineTypes a b) = buildExprC8 a <> " ⩓ " <> buildExprC7 b -buildExprC7 (Note _ b) = buildExprC7 b -buildExprC7 a = buildExprC8 a - --- | Builder corresponding to the @exprC8@ parser in "Dhall.Parser" -buildExprC8 :: Buildable a => Expr s a -> Builder -buildExprC8 (NaturalTimes a b) = buildExprC9 a <> " * " <> buildExprC8 b -buildExprC8 (Note _ b) = buildExprC8 b -buildExprC8 a = buildExprC9 a - --- | Builder corresponding to the @exprC9@ parser in "Dhall.Parser" -buildExprC9 :: Buildable a => Expr s a -> Builder -buildExprC9 (BoolEQ a b) = buildExprC10 a <> " == " <> buildExprC9 b -buildExprC9 (Note _ b) = buildExprC9 b -buildExprC9 a = buildExprC10 a - --- | Builder corresponding to the @exprC10@ parser in "Dhall.Parser" -buildExprC10 :: Buildable a => Expr s a -> Builder -buildExprC10 (BoolNE a b) = buildExprD a <> " != " <> buildExprC10 b -buildExprC10 (Note _ b) = buildExprC10 b -buildExprC10 a = buildExprD a - --- | Builder corresponding to the @exprD@ parser in "Dhall.Parser" -buildExprD :: Buildable a => Expr s a -> Builder -buildExprD (App a b) = buildExprD a <> " " <> buildExprE b -buildExprD (Constructors b) = "constructors " <> buildExprE b -buildExprD (Note _ b) = buildExprD b -buildExprD a = buildExprE a - --- | Builder corresponding to the @exprE@ parser in "Dhall.Parser" -buildExprE :: Buildable a => Expr s a -> Builder -buildExprE (Field a b) = buildExprE a <> "." <> buildLabel b -buildExprE (Note _ b) = buildExprE b -buildExprE a = buildExprF a - --- | Builder corresponding to the @exprF@ parser in "Dhall.Parser" -buildExprF :: Buildable a => Expr s a -> Builder -buildExprF (Var a) = - buildVar a -buildExprF (Const k) = - buildConst k -buildExprF Bool = - "Bool" -buildExprF Natural = - "Natural" -buildExprF NaturalFold = - "Natural/fold" -buildExprF NaturalBuild = - "Natural/build" -buildExprF NaturalIsZero = - "Natural/isZero" -buildExprF NaturalEven = - "Natural/even" -buildExprF NaturalOdd = - "Natural/odd" -buildExprF NaturalToInteger = - "Natural/toInteger" -buildExprF NaturalShow = - "Natural/show" -buildExprF Integer = - "Integer" -buildExprF IntegerShow = - "Integer/show" -buildExprF Double = - "Double" -buildExprF DoubleShow = - "Double/show" -buildExprF Text = - "Text" -buildExprF List = - "List" -buildExprF ListBuild = - "List/build" -buildExprF ListFold = - "List/fold" -buildExprF ListLength = - "List/length" -buildExprF ListHead = - "List/head" -buildExprF ListLast = - "List/last" -buildExprF ListIndexed = - "List/indexed" -buildExprF ListReverse = - "List/reverse" -buildExprF Optional = - "Optional" -buildExprF OptionalFold = - "Optional/fold" -buildExprF OptionalBuild = - "Optional/build" -buildExprF (BoolLit True) = - "True" -buildExprF (BoolLit False) = - "False" -buildExprF (IntegerLit a) - | 0 <= a = "+" <> buildNumber a - | otherwise = buildNumber a -buildExprF (NaturalLit a) = - buildNatural a -buildExprF (DoubleLit a) = - buildScientific a -buildExprF (TextLit a) = - buildChunks a -buildExprF (Record a) = - buildRecord a -buildExprF (RecordLit a) = - buildRecordLit a -buildExprF (Union a) = - buildUnion a -buildExprF (UnionLit a b c) = - buildUnionLit a b c -buildExprF (ListLit Nothing b) = - "[" <> buildElems (Data.Foldable.toList b) <> "]" -buildExprF (Embed a) = - build a -buildExprF (Note _ b) = - buildExprF b -buildExprF a = - "(" <> buildExprA a <> ")" - --- | Builder corresponding to the @const@ parser in "Dhall.Parser" -buildConst :: Const -> Builder -buildConst Type = "Type" -buildConst Kind = "Kind" - --- | Builder corresponding to the @var@ parser in "Dhall.Parser" -buildVar :: Var -> Builder -buildVar (V x 0) = buildLabel x -buildVar (V x n) = buildLabel x <> "@" <> buildNumber n - --- | Builder corresponding to the @elems@ parser in "Dhall.Parser" -buildElems :: Buildable a => [Expr s a] -> Builder -buildElems [] = "" -buildElems [a] = buildExprA a -buildElems (a:bs) = buildExprA a <> ", " <> buildElems bs - --- | Builder corresponding to the @recordLit@ parser in "Dhall.Parser" -buildRecordLit :: Buildable a => InsOrdHashMap Text (Expr s a) -> Builder -buildRecordLit a | Data.HashMap.Strict.InsOrd.null a = - "{=}" -buildRecordLit a = - "{ " <> buildFieldValues (Data.HashMap.Strict.InsOrd.toList a) <> " }" - --- | Builder corresponding to the @fieldValues@ parser in "Dhall.Parser" -buildFieldValues :: Buildable a => [(Text, Expr s a)] -> Builder -buildFieldValues [] = "" -buildFieldValues [a] = buildFieldValue a -buildFieldValues (a:bs) = buildFieldValue a <> ", " <> buildFieldValues bs - --- | Builder corresponding to the @fieldValue@ parser in "Dhall.Parser" -buildFieldValue :: Buildable a => (Text, Expr s a) -> Builder -buildFieldValue (a, b) = buildLabel a <> " = " <> buildExprA b - --- | Builder corresponding to the @record@ parser in "Dhall.Parser" -buildRecord :: Buildable a => InsOrdHashMap Text (Expr s a) -> Builder -buildRecord a | Data.HashMap.Strict.InsOrd.null a = - "{}" -buildRecord a = - "{ " <> buildFieldTypes (Data.HashMap.Strict.InsOrd.toList a) <> " }" - --- | Builder corresponding to the @fieldTypes@ parser in "Dhall.Parser" -buildFieldTypes :: Buildable a => [(Text, Expr s a)] -> Builder -buildFieldTypes [] = "" -buildFieldTypes [a] = buildFieldType a -buildFieldTypes (a:bs) = buildFieldType a <> ", " <> buildFieldTypes bs - --- | Builder corresponding to the @fieldType@ parser in "Dhall.Parser" -buildFieldType :: Buildable a => (Text, Expr s a) -> Builder -buildFieldType (a, b) = buildLabel a <> " : " <> buildExprA b - --- | Builder corresponding to the @union@ parser in "Dhall.Parser" -buildUnion :: Buildable a => InsOrdHashMap Text (Expr s a) -> Builder -buildUnion a | Data.HashMap.Strict.InsOrd.null a = - "<>" -buildUnion a = - "< " <> buildAlternativeTypes (Data.HashMap.Strict.InsOrd.toList a) <> " >" - --- | Builder corresponding to the @alternativeTypes@ parser in "Dhall.Parser" -buildAlternativeTypes :: Buildable a => [(Text, Expr s a)] -> Builder -buildAlternativeTypes [] = - "" -buildAlternativeTypes [a] = - buildAlternativeType a -buildAlternativeTypes (a:bs) = - buildAlternativeType a <> " | " <> buildAlternativeTypes bs +prettyToString :: Pretty a => a -> String +prettyToString = + Pretty.renderString . Pretty.layoutPretty options . Pretty.pretty + where + options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded } --- | Builder corresponding to the @alternativeType@ parser in "Dhall.Parser" -buildAlternativeType :: Buildable a => (Text, Expr s a) -> Builder -buildAlternativeType (a, b) = buildLabel a <> " : " <> buildExprA b +docToStrictText :: Doc ann -> Text.Text +docToStrictText = Pretty.renderStrict . Pretty.layoutPretty options + where + options = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded } --- | Builder corresponding to the @unionLit@ parser in "Dhall.Parser" -buildUnionLit - :: Buildable a - => Text -> Expr s a -> InsOrdHashMap Text (Expr s a) -> Builder -buildUnionLit a b c - | Data.HashMap.Strict.InsOrd.null c = - "< " - <> buildLabel a - <> " = " - <> buildExprA b - <> " >" - | otherwise = - "< " - <> buildLabel a - <> " = " - <> buildExprA b - <> " | " - <> buildAlternativeTypes (Data.HashMap.Strict.InsOrd.toList c) - <> " >" +prettyToStrictText :: Pretty a => a -> Text.Text +prettyToStrictText = docToStrictText . Pretty.pretty diff --git a/src/Dhall/Pretty/Internal.hs-boot b/src/Dhall/Pretty/Internal.hs-boot --- a/src/Dhall/Pretty/Internal.hs-boot +++ b/src/Dhall/Pretty/Internal.hs-boot @@ -1,31 +1,18 @@ module Dhall.Pretty.Internal where -import Data.Scientific (Scientific) -import Data.Text.Lazy (Text) -import Data.Text.Lazy.Builder (Builder) +import Data.Text (Text) import Data.Text.Prettyprint.Doc (Pretty, Doc) -import Formatting.Buildable (Buildable) -import Numeric.Natural (Natural) -import Prelude import {-# SOURCE #-} Dhall.Core data Ann -buildConst :: Const -> Builder - -buildVar :: Var -> Builder +prettyVar :: Var -> Doc Ann -buildExpr :: Buildable a => Expr s a -> Builder +prettyConst :: Const -> Doc Ann prettyExpr :: Pretty a => Expr s a -> Doc Ann -buildNatural :: Natural -> Builder - -buildNumber :: Integer -> Builder - -buildScientific :: Scientific -> Builder - pretty :: Pretty a => a -> Text -escapeText :: Builder -> Builder +escapeText :: Text -> Text diff --git a/src/Dhall/Repl.hs b/src/Dhall/Repl.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/Repl.hs @@ -0,0 +1,258 @@ +{-# language FlexibleContexts #-} +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} + +module Dhall.Repl ( repl ) where + +import Control.Exception ( SomeException(SomeException), displayException, throwIO ) +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import Control.Monad.State.Class ( MonadState, get, modify ) +import Control.Monad.State.Strict ( evalStateT ) +import Data.List ( foldl' ) + +import qualified Data.Text as Text +import qualified Data.Text.Prettyprint.Doc as Pretty +import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Pretty ( renderIO ) +import qualified Dhall +import qualified Dhall.Context +import qualified Dhall.Core as Dhall ( Var(V), Expr, normalize ) +import qualified Dhall.Pretty +import qualified Dhall.Core as Expr ( Expr(..) ) +import qualified Dhall.Import as Dhall +import qualified Dhall.Parser as Dhall +import qualified Dhall.TypeCheck as Dhall +import qualified System.Console.ANSI +import qualified System.Console.Haskeline.MonadException as Haskeline +import qualified System.Console.Repline as Repline +import qualified System.IO + + +repl :: Bool -> IO () +repl explain = if explain then Dhall.detailed io else io + where + io = + evalStateT + ( Repline.evalRepl + "⊢ " + ( dontCrash . eval ) + options + ( Repline.Word completer ) + greeter + ) + (emptyEnv { explain }) + + +data Env = Env + { envBindings :: Dhall.Context.Context Binding + , envIt :: Maybe Binding + , explain :: Bool + } + + +emptyEnv :: Env +emptyEnv = + Env + { envBindings = Dhall.Context.empty + , envIt = Nothing + , explain = False + } + + +data Binding = Binding + { bindingExpr :: Dhall.Expr Dhall.Src Dhall.X + , bindingType :: Dhall.Expr Dhall.Src Dhall.X + } + + +envToContext :: Env -> Dhall.Context.Context Binding +envToContext Env{ envBindings, envIt } = + case envIt of + Nothing -> + envBindings + + Just it -> + Dhall.Context.insert "it" it envBindings + + +parseAndLoad + :: ( MonadIO m, MonadState Env m ) + => String -> m ( Dhall.Expr Dhall.Src Dhall.X ) +parseAndLoad src = do + parsed <- + case Dhall.exprFromText "(stdin)" ( Text.pack src ) of + Left e -> + liftIO ( throwIO e ) + + Right a -> + return a + + liftIO ( Dhall.load parsed ) + + +eval :: ( MonadIO m, MonadState Env m ) => String -> m () +eval src = do + loaded <- + parseAndLoad src + + exprType <- + typeCheck loaded + + expr <- + normalize loaded + + modify ( \e -> e { envIt = Just ( Binding expr exprType ) } ) + + output System.IO.stdout expr + + + +typeOf :: ( MonadIO m, MonadState Env m ) => [String] -> m () +typeOf [] = + liftIO ( putStrLn ":type requires an argument to check the type of" ) + + +typeOf srcs = do + loaded <- + parseAndLoad ( unwords srcs ) + + exprType <- + typeCheck loaded + + exprType' <- + normalize exprType + + output System.IO.stdout exprType' + + + +normalize + :: MonadState Env m + => Dhall.Expr Dhall.Src Dhall.X -> m ( Dhall.Expr t Dhall.X ) +normalize e = do + env <- + get + + return + ( Dhall.normalize + ( foldl' + ( \a (k, Binding { bindingType, bindingExpr }) -> + Expr.Let k ( Just bindingType ) bindingExpr a + ) + e + ( Dhall.Context.toList ( envToContext env ) ) + ) + ) + + +typeCheck + :: ( MonadIO m, MonadState Env m ) + => Dhall.Expr Dhall.Src Dhall.X -> m ( Dhall.Expr Dhall.Src Dhall.X ) +typeCheck expr = do + env <- + get + + let wrap = if explain env then Dhall.detailed else id + + case Dhall.typeWith ( bindingType <$> envToContext env ) expr of + Left e -> + liftIO ( wrap (throwIO e) ) + + Right a -> + return a + + +addBinding :: ( MonadIO m, MonadState Env m ) => [String] -> m () +addBinding (k : "=" : srcs) = do + let + varName = + Text.pack k + + loaded <- + parseAndLoad ( unwords srcs ) + + t <- + typeCheck loaded + + expr <- + normalize loaded + + modify + ( \e -> + e + { envBindings = + Dhall.Context.insert + varName + Binding { bindingType = t, bindingExpr = expr } + ( envBindings e ) + } + ) + + output + System.IO.stdout + ( Expr.Annot ( Expr.Var ( Dhall.V varName 0 ) ) t ) + +addBinding _ = + liftIO ( fail ":let should be of the form `:let x = y`" ) + +saveBinding :: ( MonadIO m, MonadState Env m ) => [String] -> m () +saveBinding (file : "=" : tokens) = do + loadedExpression <- parseAndLoad (unwords tokens) + + _ <- typeCheck loadedExpression + + normalizedExpression <- normalize loadedExpression + + let handler handle = output handle normalizedExpression + + liftIO (System.IO.withFile file System.IO.WriteMode handler) +saveBinding _ = fail ":save should be of the form `:save x = y`" + + +options + :: ( Haskeline.MonadException m, MonadIO m, MonadState Env m ) + => Repline.Options m +options = + [ ( "type", dontCrash . typeOf ) + , ( "let", dontCrash . addBinding ) + , ( "save", dontCrash . saveBinding ) + ] + + +completer :: Monad m => Repline.WordCompleter m +completer _ = + return [] + + +greeter :: MonadIO m => m () +greeter = + return () + + +dontCrash :: ( MonadIO m, Haskeline.MonadException m ) => m () -> m () +dontCrash m = + Haskeline.catch + m + ( \ e@SomeException{} -> liftIO ( putStrLn ( displayException e ) ) ) + + +output + :: (Pretty.Pretty a, MonadIO m) + => System.IO.Handle -> Dhall.Expr s a -> m () +output handle expr = do + liftIO (System.IO.hPutStrLn handle "") -- Visual spacing + + let opts = + Pretty.defaultLayoutOptions + { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 } + + let stream = Pretty.layoutSmart opts (Dhall.Pretty.prettyExpr expr) + supportsANSI <- liftIO (System.Console.ANSI.hSupportsANSI handle) + let ansiStream = + if supportsANSI + then fmap Dhall.Pretty.annToAnsiStyle stream + else Pretty.unAnnotateS stream + + liftIO (Pretty.renderIO handle ansiStream) + liftIO (System.IO.hPutStrLn handle "") -- Pretty printing doesn't end with a new line + + liftIO (System.IO.hPutStrLn handle "") -- Visual spacing diff --git a/src/Dhall/TH.hs b/src/Dhall/TH.hs new file mode 100644 --- /dev/null +++ b/src/Dhall/TH.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TemplateHaskell #-} + +{-| This module provides `staticDhallExpression` which can be used to resolve + all of an expression’s imports at compile time, allowing one to reference + Dhall expressions from Haskell without having a runtime dependency on the + location of Dhall files. + + For example, given a file “Some/Type.dhall” containing + + < This : Natural | Other : ../Other/Type.dhall > + + rather than duplicating the AST manually in a Haskell `Type`, you can do + + Dhall.Type + (\case + UnionLit "This" _ _ -> ... + UnionLit "Other" _ _ -> ...) + $(staticDhallExpression "../../Some/Type.dhall") + + This would create the Dhall Expr AST from the `Type.dhall` file at compile + time with all imports resolved, making it easy to keep your Dhall configs + and Haskell interpreters in sync. +-} +module Dhall.TH where + +import Control.Monad +import Data.Typeable +import Language.Haskell.TH.Quote (dataToExpQ) -- 7.10 compatibility. +import Language.Haskell.TH.Syntax + +import qualified Data.Text as Text +import qualified Dhall + +-- | This fully resolves, type checks, and normalizes the expression, so the +-- resulting AST is self-contained. +staticDhallExpression :: Text.Text -> Q Exp +staticDhallExpression = + dataToExpQ (\a -> liftText <$> cast a) <=< runIO . Dhall.inputExpr + where + -- A workaround for a problem in TemplateHaskell (see + -- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable) + liftText = fmap (AppE (VarE 'Text.pack)) . lift . Text.unpack + + diff --git a/src/Dhall/Tutorial.hs b/src/Dhall/Tutorial.hs --- a/src/Dhall/Tutorial.hs +++ b/src/Dhall/Tutorial.hs @@ -423,26 +423,26 @@ -- > Cyclic import: ./file1 -- -- You can also import expressions by URL. For example, you can find a Dhall --- expression hosted at this URL using @ipfs@: +-- expression hosted at this GitHub URL: -- --- +-- -- --- > $ curl https://ipfs.io/ipfs/QmVf6hhTCXc9y2pRvhUmLk3AZYEgjeAz5PNwjt1GBYqsVB +-- > $ curl https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True -- > True -- -- ... and you can reference that expression either directly: -- --- > >>> input auto "https://ipfs.io/ipfs/QmVf6hhTCXc9y2pRvhUmLk3AZYEgjeAz5PNwjt1GBYqsVB" :: IO Bool +-- > >>> input auto "https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True" :: IO Bool -- > True -- -- ... or inside of a larger expression: -- --- > >>> input auto "False == https://ipfs.io/ipfs/QmVf6hhTCXc9y2pRvhUmLk3AZYEgjeAz5PNwjt1GBYqsVB" :: IO Bool +-- > >>> input auto "False == https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True" :: IO Bool -- > False -- --- You're not limited to hosting Dhall expressions on @ipfs@. You can host a --- Dhall expression anywhere that you can host UTF8-encoded text on the web, such --- as Github, a pastebin, or your own web server. +-- You're not limited to hosting Dhall expressions on GitHub. You can host a +-- Dhall expression anywhere that you can host UTF8-encoded text on the web, +-- as a pastebin, or your own web server. -- -- You can also import Dhall expressions from environment variables, too: -- @@ -483,12 +483,12 @@ -- -- __Exercise:__ There is a @not@ function hosted online here: -- --- +-- -- -- Visit that link and read the documentation. Then try to guess what this -- code returns: -- --- > >>> input auto "https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/Bool/not https://ipfs.io/ipfs/QmVf6hhTCXc9y2pRvhUmLk3AZYEgjeAz5PNwjt1GBYqsVB" :: IO Bool +-- > >>> input auto "https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/Bool/not https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True" :: IO Bool -- > ??? -- -- Run the code to test your guess @@ -1017,7 +1017,7 @@ -- You can also use @let@ expressions to rename imports, like this: -- -- > $ dhall --- > let not = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/Bool/not +-- > let not = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/Bool/not -- > in not True -- > -- > Bool @@ -1375,7 +1375,7 @@ -- complex example: -- -- > $ dhall --- > let Prelude/List/map = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/map +-- > let Prelude/List/map = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/map -- > in λ(f : Natural → Natural) → Prelude/List/map Natural Natural f [1, 2, 3] -- > -- > ∀(f : Natural → Natural) → List Natural @@ -1399,11 +1399,11 @@ -- __Exercise__: The Dhall Prelude provides a @replicate@ function which you can -- find here: -- --- +-- -- -- Test what the following Dhall expression normalizes to: -- --- > let replicate = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/replicate +-- > let replicate = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/replicate -- > in replicate 10 -- -- __Exercise__: If you have a lot of spare time, try to \"break the compiler\" by @@ -1503,10 +1503,10 @@ -- > -- > 1 -- --- You can compute the Hash for any import by using the @dhall-hash@ utility --- installed by this package. For example: +-- You can compute the Hash for any import by using the hash subcommand +-- of this package. For example: -- --- > dhall-hash <<< './bar' +-- > dhall hash <<< './bar' -- > sha256:6b86b273ff34fce19d6b804eff5a3f5747ada4eaa22f1d49c01e52ddb7875b4b -- -- Then you can paste that output into your code after the import @@ -1551,7 +1551,26 @@ -- behavior-preserving. This provides an easy way to detect refactoring errors -- that you might accidentally introduce. The hash not only protects you -- from attackers, but also protects against human error, too! - +-- +-- If you have a file which either doesn't already use hashed imports, +-- or you changed some of the imports and want to update the hashes you can use the +-- freeze command to either add or update hashes: +-- +-- > cat foo.dhall +-- '' +-- let replicate = +-- https://raw.githubusercontent.com/dhall-lang/Prelude/c79c2bc3c46f129cc5b6d594ce298a381bcae92c/List/replicate +-- +-- in replicate 5 +-- '' +-- > dhall freeze --inplace ./foo.dhall +-- > cat ./foo.dhall +-- '' +-- let replicate = +-- https://raw.githubusercontent.com/dhall-lang/Prelude/c79c2bc3c46f129cc5b6d594ce298a381bcae92c/List/replicate sha256:b0e3ec1797b32c80c0bcb7e8254b08c7e9e35e75e6b410c7ac21477ab90167ad +-- in replicate 5 +-- '' +-- -- $rawText -- -- Sometimes you want to import the contents of a raw text file as a Dhall @@ -1599,7 +1618,7 @@ -- $format -- --- This package also provides a @dhall-format@ executable that you can use to +-- A format subcommand is also available that you can use to -- automatically format Dhall expressions. For example, we can take the -- following unformatted Dhall expression: -- @@ -1616,9 +1635,9 @@ -- > z) (y.diff (n + List/length { index : Natural, value : a } kvs)) }) { count = -- > 0, diff = λ(_ : Natural) → nil }).diff 0) -- --- ... and run the expression through the @dhall-format@ executable: +-- ... and run the expression through the the formatter: -- --- > $ dhall-format < ./unformatted +-- > $ dhall format < ./unformatted -- > λ(a : Type) -- > → λ(kvss : List (List { index : Natural, value : a })) -- > → List/build @@ -1654,12 +1673,12 @@ -- The executable formats expressions without resolving, type-checking, or -- normalizing them: -- --- > $ dhall-format --- > let replicate = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/replicate +-- > $ dhall format +-- > let replicate = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/replicate -- > in replicate 5 (List (List Natural)) (replicate 5 (List Natural) (replicate 5 Natural 1)) -- > -- > let replicate = --- > https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/replicate +-- > https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/replicate -- > -- > in replicate -- > 5 @@ -1669,7 +1688,7 @@ -- You can also use the formatter to modify files in place using the -- @--inplace@ flag (i.e. for formatting source code): -- --- > $ dhall-format --inplace ./unformatted +-- > $ dhall format --inplace ./unformatted -- > $ cat ./unformatted -- > λ(a : Type) -- > → λ(kvss : List (List { index : Natural, value : a })) @@ -1707,7 +1726,7 @@ -- Currently, the formatter only preserves leading comments and whitespace -- up until the last newline preceding the code. In other words: -- --- > $ dhall-format +-- > $ dhall format -- > {- This comment will be preserved by the formatter -} -- > -- ... and this comment will be preserved, too -- > {- This comment will *NOT* be preserved -} 1 @@ -1717,12 +1736,12 @@ -- > -- ... and this comment will be preserved, too -- > 1 -- --- Note that you do not need to use @dhall-format@ to format the output of the +-- Note that you do not need to format the output of the -- @dhall@ interpreter. The interpreter already automatically formats -- multi-line expressions, too: -- -- > $ dhall --- > let replicate = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/replicate +-- > let replicate = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/replicate -- > in replicate 5 (List (List Natural)) (replicate 5 (List Natural) (replicate 5 Natural 1)) -- > -- > List (List (List Natural)) @@ -2336,7 +2355,7 @@ -- -- Rules: -- --- > let Prelude/List/concat = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/concat +-- > let Prelude/List/concat = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/concat -- > -- > List/fold a (Prelude/List/concat a xss) b c -- > = List/fold (List a) xss b (λ(x : List a) → List/fold a x b c) @@ -2405,10 +2424,10 @@ -- -- Rules: -- --- > let Prelude/Optional/head = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/Optional/head --- > let Prelude/List/concat = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/concat --- > let Prelude/List/concatMap = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/concatMap --- > let Prelude/List/map = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/map +-- > let Prelude/Optional/head = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/Optional/head +-- > let Prelude/List/concat = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/concat +-- > let Prelude/List/concatMap = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/concatMap +-- > let Prelude/List/map = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/map -- > -- > List/head a (Prelude/List/concat a xss) = -- > Prelude/Optional/head a (Prelude/List/map (List a) (Optional a) (List/head a) xss) @@ -2436,10 +2455,10 @@ -- -- Rules: -- --- > let Prelude/Optional/last = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/Optional/last --- > let Prelude/List/concat = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/concat --- > let Prelude/List/concatMap = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/concatMap --- > let Prelude/List/map = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/map +-- > let Prelude/Optional/last = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/Optional/last +-- > let Prelude/List/concat = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/concat +-- > let Prelude/List/concatMap = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/concatMap +-- > let Prelude/List/map = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/map -- > -- > List/last a (Prelude/List/concat a xss) = -- > Prelude/Optional/last a (Prelude/List/map (List a) (Optional a) (List/last a) xss) @@ -2467,9 +2486,9 @@ -- -- Rules: -- --- > let Prelude/List/shifted = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/shifted --- > let Prelude/List/concat = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/concat --- > let Prelude/List/map = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/map +-- > let Prelude/List/shifted = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/shifted +-- > let Prelude/List/concat = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/concat +-- > let Prelude/List/map = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/map -- > -- > List/indexed a (Prelude/List/concat a xss) = -- > Prelude/List/shifted a (Prelude/List/map (List a) (List { index : Natural, value : a }) (List/indexed a) xss) @@ -2492,9 +2511,9 @@ -- -- Rules: -- --- > let Prelude/List/map = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/map --- > let Prelude/List/concat = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/concat --- > let Prelude/List/concatMap = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/List/concatMap +-- > let Prelude/List/map = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/map +-- > let Prelude/List/concat = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/concat +-- > let Prelude/List/concatMap = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/List/concatMap -- > -- > List/reverse a (Prelude/List/concat a xss) -- > = Prelude/List/concat a (List/reverse (List a) (Prelude/List/map (List a) (List a) (List/reverse a) xss)) @@ -2552,7 +2571,7 @@ -- -- ... which currenty redirects to: -- --- +-- -- -- There is nothing \"official\" or \"standard\" about this Prelude other than -- the fact that it is mentioned in this tutorial. The \"Prelude\" is just a @@ -2563,12 +2582,12 @@ -- subdirectories. For example, the @Bool@ subdirectory has a @not@ file -- located here: -- --- +-- -- -- The @not@ function is just a UTF8-encoded text file hosted online with the -- following contents -- --- > $ curl https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/Bool/not +-- > $ curl https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/Bool/not -- > {- -- > Flip the value of a `Bool` -- > @@ -2601,7 +2620,7 @@ -- You can use this @not@ function either directly: -- -- > $ dhall --- > https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/Bool/not True +-- > https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/Bool/not True -- > -- > Bool -- > @@ -2610,7 +2629,7 @@ -- ... or assign the URL to a shorter name: -- -- > $ dhall --- > let Bool/not = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/Bool/not +-- > let Bool/not = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/Bool/not -- > in Bool/not True -- > -- > Bool @@ -2621,7 +2640,7 @@ -- consistency and documentation, such as @Prelude\/Natural\/even@, which -- re-exports the built-in @Natural/even@ function: -- --- > $ curl https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/Natural/even +-- > $ curl https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/Natural/even -- > {- -- > Returns `True` if a number if even and returns `False` otherwise -- > @@ -2638,11 +2657,10 @@ -- > -- > in even -- --- You can also download the Prelude locally to your filesystem if you prefer --- using local relative paths instead of URLs. For example, you can use @wget@, --- like this: +-- You can also clone the Prelude locally to your filesystem if you prefer +-- using `git clone`, like this: -- --- > $ wget -np -nH -r --cut-dirs=2 https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/ +-- > $ git clone https://github.com/dhall-lang/Prelude.git -- > $ tree Prelude -- > Prelude -- > ├── Bool @@ -2653,16 +2671,20 @@ -- > │   ├── not -- > │   ├── odd -- > │   ├── or +-- > │   ├── package.dhall -- > │   └── show -- > ├── Double +-- > │   ├── package.dhall -- > │   └── show -- > ├── Integer +-- > │   ├── package.dhall -- > │   └── show -- > ├── List -- > │   ├── all -- > │   ├── any -- > │   ├── build -- > │   ├── concat +-- > │   ├── concatMap -- > │   ├── filter -- > │   ├── fold -- > │   ├── generate @@ -2673,6 +2695,7 @@ -- > │   ├── length -- > │   ├── map -- > │   ├── null +-- > │   ├── package.dhall -- > │   ├── replicate -- > │   ├── reverse -- > │   ├── shifted @@ -2685,33 +2708,46 @@ -- > │   ├── fold -- > │   ├── isZero -- > │   ├── odd +-- > │   ├── package.dhall -- > │   ├── product -- > │   ├── show -- > │   ├── sum -- > │   └── toInteger -- > ├── Optional +-- > │   ├── None +-- > │   ├── Some +-- > │   ├── all +-- > │   ├── any -- > │   ├── build -- > │   ├── concat +-- > │   ├── filter -- > │   ├── fold -- > │   ├── head -- > │   ├── last +-- > │   ├── length -- > │   ├── map +-- > │   ├── null +-- > │   ├── package.dhall -- > │   ├── toList -- > │   └── unzip +-- > ├── Record +-- > │   ├── keyText +-- > │   ├── keyValue +-- > │   └── package.dhall -- > ├── Text --- > │   └── concat --- > └── index.html --- --- ... or if you have an @ipfs@ daemon running, you can mount the Prelude --- locally like this: --- --- > $ ipfs mount --- > $ cd /ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude +-- > │   ├── concat +-- > │   ├── concatMap +-- > │   ├── concatMapSep +-- > │   ├── concatSep +-- > │   └── package.dhall +-- > └── package.dhall +-- > +-- > 8 directories, 70 files -- -- Browse the Prelude online to learn more by seeing what functions are -- available and reading their inline documentation: -- --- +-- -- -- __Exercise__: Try to use a new Prelude function that has not been covered -- previously in this tutorial @@ -2720,7 +2756,7 @@ -- convenience: -- -- > $ dhall --- > let Prelude = https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/package.dhall +-- > let Prelude = https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/package.dhall -- > -- > in λ(x : Text) -- > → Prelude.`List`.length Text (Prelude.`List`.replicate 10 Text x) @@ -2735,7 +2771,7 @@ -- -- __Exercise__: Browse the Prelude by running: -- --- > $ dhall <<< 'https://ipfs.io/ipfs/QmV5MMfZehF4Z1EC4hK1s4yjE81kZV5hxypcuqfh9qcDMB/Prelude/package.dhall' +-- > $ dhall <<< 'https://raw.githubusercontent.com/dhall-lang/Prelude/35deff0d41f2bf86c42089c6ca16665537f54d75/package.dhall' -- $conclusion -- diff --git a/src/Dhall/TypeCheck.hs b/src/Dhall/TypeCheck.hs --- a/src/Dhall/TypeCheck.hs +++ b/src/Dhall/TypeCheck.hs @@ -22,47 +22,43 @@ ) where import Control.Exception (Exception) +import Data.Data (Data(..)) import Data.Foldable (forM_, toList) import Data.Monoid ((<>)) import Data.Sequence (Seq, ViewL(..)) import Data.Set (Set) -import Data.Text.Lazy (Text) -import Data.Text.Lazy.Builder (Builder) +import Data.Text (Text) import Data.Text.Prettyprint.Doc (Doc, Pretty(..)) import Data.Traversable (forM) import Data.Typeable (Typeable) import Dhall.Core (Const(..), Chunks(..), Expr(..), Var(..)) import Dhall.Context (Context) -import Formatting.Buildable (Buildable(..)) +import Dhall.Pretty (Ann) import qualified Data.Foldable +import qualified Data.HashMap.Strict import qualified Data.HashMap.Strict.InsOrd import qualified Data.Sequence import qualified Data.Set -import qualified Data.Text.Lazy as Text -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Text.Prettyprint.Doc as Pretty -import qualified Data.Text.Prettyprint.Doc.Render.Text as Pretty +import qualified Data.Text as Text +import qualified Data.Text.Prettyprint.Doc as Pretty +import qualified Data.Text.Prettyprint.Doc.Render.String as Pretty import qualified Dhall.Context import qualified Dhall.Core import qualified Dhall.Diff -import qualified Dhall.Pretty import qualified Dhall.Pretty.Internal traverseWithIndex_ :: Applicative f => (Int -> a -> f b) -> Seq a -> f () traverseWithIndex_ k xs = Data.Foldable.sequenceA_ (Data.Sequence.mapWithIndex k xs) -docToLazyText :: Doc a -> Text -docToLazyText = Pretty.renderLazy . Pretty.layoutPretty opts - where - opts = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded } - axiom :: Const -> Either (TypeError s a) Const axiom Type = return Kind axiom Kind = Left (TypeError Dhall.Context.empty (Const Kind) Untyped) rule :: Const -> Const -> Either () Const +-- This forbids dependent types. If this ever changes, then the fast +-- path in the Let case of typeWithA will become unsound. rule Type Kind = Left () rule Type Type = return Type rule Kind Kind = return Kind @@ -74,6 +70,9 @@ `typeWith` does not necessarily normalize the type since full normalization is not necessary for just type-checking. If you actually care about the returned type then you may want to `Dhall.Core.normalize` it afterwards. + + The supplied `Context` records the types of the names in scope. If + these are ill-typed, the return value may be ill-typed. -} typeWith :: Context (Expr s X) -> Expr s X -> Either (TypeError s X) (Expr s X) typeWith ctx expr = do @@ -102,7 +101,8 @@ case Dhall.Context.lookup x n ctx of Nothing -> Left (TypeError ctx e (UnboundVariable x)) Just a -> do - _ <- loop ctx a + -- Note: no need to typecheck the value we're + -- returning; that is done at insertion time. return a loop ctx (Lam x _A b ) = do _ <- loop ctx _A @@ -154,11 +154,34 @@ then return () else Left (TypeError ctx e (AnnotMismatch a0 nf_A0 nf_A1)) Nothing -> return () + + t <- loop ctx _A1 + let a1 = Dhall.Core.normalize a0 let a2 = Dhall.Core.shift 1 (V x 0) a1 - let b1 = Dhall.Core.subst (V x 0) a2 b0 - let b2 = Dhall.Core.shift (-1) (V x 0) b1 - loop ctx b2 + + -- The catch-all branch directly implements the Dhall + -- specification as written; it is necessary to substitute in + -- types in order to get 'dependent let' behaviour and to + -- allow type synonyms (see #69). However, doing a full + -- substitution is slow if the value is large and used many + -- times. If the value being substitued in is a term (i.e., + -- its type is a Type), then we can get a very significant + -- speed-up by doing the type-checking once at binding-time, + -- as opposed to doing it at every use site (see #412). + case Dhall.Core.normalize t of + Const Type -> do + let ctx' = fmap (Dhall.Core.shift 1 (V x 0)) (Dhall.Context.insert x (Dhall.Core.normalize _A1) ctx) + _B0 <- loop ctx' b0 + let _B1 = Dhall.Core.subst (V x 0) a2 _B0 + let _B2 = Dhall.Core.shift (-1) (V x 0) _B1 + return _B2 + + _ -> do + let b1 = Dhall.Core.subst (V x 0) a2 b0 + let b2 = Dhall.Core.shift (-1) (V x 0) b1 + loop ctx b2 + loop ctx e@(Annot x t ) = do _ <- loop ctx t @@ -298,6 +321,8 @@ return Integer loop _ IntegerShow = do return (Pi "_" Integer Text) + loop _ IntegerToDouble = do + return (Pi "_" Integer Double) loop _ Double = do return (Const Type) loop _ (DoubleLit _ ) = do @@ -498,13 +523,19 @@ kts <- Data.HashMap.Strict.InsOrd.traverseWithKey process kvs return (Record kts) loop ctx e@(Union kts ) = do - let process (k, t) = do + let process k t = do s <- fmap Dhall.Core.normalize (loop ctx t) case s of Const Type -> return () Const Kind -> return () _ -> Left (TypeError ctx e (InvalidAlternativeType k t)) - mapM_ process (Data.HashMap.Strict.InsOrd.toList kts) + -- toList from insert-ordered-containers does some work to + -- ensure that the elements do follow insertion order. In this + -- instance, insertion order doesn't matter: we only need to + -- peek at each element to make sure it is well-typed. If + -- there are multiple type errors, it does not matter which + -- gets reported first here. + Data.HashMap.Strict.foldrWithKey (\ k t prev -> prev >> process k t) (Right ()) (Data.HashMap.Strict.InsOrd.toHashMap kts) return (Const Type) loop ctx e@(UnionLit k v kts) = do case Data.HashMap.Strict.InsOrd.lookup k kts of @@ -700,7 +731,7 @@ Just t' -> return t' Nothing -> Left (TypeError ctx e (MissingField x t)) _ -> do - let text = docToLazyText (Dhall.Pretty.Internal.prettyLabel x) + let text = Dhall.Pretty.Internal.docToStrictText (Dhall.Pretty.Internal.prettyLabel x) Left (TypeError ctx e (NotARecord text r t)) loop ctx e@(Project r xs ) = do t <- fmap Dhall.Core.normalize (loop ctx r) @@ -715,12 +746,14 @@ let adapt = Record . Data.HashMap.Strict.InsOrd.fromList fmap adapt (traverse process (Data.Set.toList xs)) _ -> do - let text = docToLazyText (Dhall.Pretty.Internal.prettyLabels xs) + let text = Dhall.Pretty.Internal.docToStrictText (Dhall.Pretty.Internal.prettyLabels xs) Left (TypeError ctx e (NotARecord text r t)) loop ctx (Note s e' ) = case loop ctx e' of Left (TypeError ctx' (Note s' e'') m) -> Left (TypeError ctx' (Note s' e'') m) Left (TypeError ctx' e'' m) -> Left (TypeError ctx' (Note s e'') m) Right r -> Right r + loop ctx (ImportAlt l _r ) = + fmap Dhall.Core.normalize (loop ctx l) loop _ (Embed p ) = Right $ tpa p {-| `typeOf` is the same as `typeWith` with an empty context, meaning that the @@ -739,8 +772,10 @@ instance Eq X where _ == _ = True -instance Buildable X where - build = absurd +instance Data X where + dataTypeOf = absurd + gunfold _ _ _ = undefined + toConstr = absurd instance Pretty X where pretty = absurd @@ -799,46 +834,37 @@ | NoDependentTypes (Expr s a) (Expr s a) deriving (Show) -shortTypeMessage :: (Buildable a, Eq a, Pretty a) => TypeMessage s a -> Builder +shortTypeMessage :: (Eq a, Pretty a) => TypeMessage s a -> Doc Ann shortTypeMessage msg = - "\ESC[1;31mError\ESC[0m: " <> build short <> "\n" + "\ESC[1;31mError\ESC[0m: " <> short <> "\n" where ErrorMessages {..} = prettyTypeMessage msg -longTypeMessage :: (Buildable a, Eq a, Pretty a) => TypeMessage s a -> Builder +longTypeMessage :: (Eq a, Pretty a) => TypeMessage s a -> Doc Ann longTypeMessage msg = - "\ESC[1;31mError\ESC[0m: " <> build short <> "\n" + "\ESC[1;31mError\ESC[0m: " <> short <> "\n" <> "\n" <> long where ErrorMessages {..} = prettyTypeMessage msg data ErrorMessages = ErrorMessages - { short :: Builder + { short :: Doc Ann -- ^ Default succinct 1-line explanation of what went wrong - , long :: Builder + , long :: Doc Ann -- ^ Longer and more detailed explanation of the error } -_NOT :: Builder +_NOT :: Doc ann _NOT = "\ESC[1mnot\ESC[0m" -prettyDiff :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Builder -prettyDiff exprL exprR = builder - where - doc = - fmap Dhall.Pretty.annToAnsiStyle (Dhall.Diff.diffNormalized exprL exprR) - - opts = Pretty.LayoutOptions { Pretty.layoutPageWidth = Pretty.Unbounded } - - stream = Pretty.layoutPretty opts doc - - lazyText = Pretty.renderLazy stream +insert :: Pretty a => a -> Doc Ann +insert expression = "↳ " <> Pretty.align (Pretty.pretty expression) - builder = Builder.fromLazyText lazyText +prettyDiff :: (Eq a, Pretty a) => Expr s a -> Expr s a -> Doc Ann +prettyDiff exprL exprR = Dhall.Diff.diffNormalized exprL exprR -prettyTypeMessage - :: (Buildable a, Eq a, Pretty a) => TypeMessage s a -> ErrorMessages +prettyTypeMessage :: (Eq a, Pretty a) => TypeMessage s a -> ErrorMessages prettyTypeMessage (UnboundVariable _) = ErrorMessages {..} -- We do not need to print variable name here. For the discussion see: -- https://github.com/dhall-lang/dhall-haskell/pull/116 @@ -942,7 +968,17 @@ \ │ (x : Bool) → Bool │ \n\ \ └────────────────────┘ \n\ \ ⇧ \n\ - \ A ❰∀❱ or ❰forall❱ here would transform this into a valid function type \n" + \ A ❰∀❱ or ❰forall❱ here would transform this into a valid function type \n\ + \ \n\ + \ \n\ + \● You forgot to prefix a file path with ❰./❱: \n\ + \ \n\ + \ \n\ + \ ┌────────────────────┐ \n\ + \ │ path/to/file.dhall │ \n\ + \ └────────────────────┘ \n\ + \ ⇧ \n\ + \ This should be ❰./path/to/file.dhall❱ \n" prettyTypeMessage (InvalidInputType expr) = ErrorMessages {..} where @@ -1007,11 +1043,11 @@ \ \n\ \You annotated a function input with the following expression: \n\ \ \n\ - \↳ " <> txt <> " \n\ + \" <> txt <> "\n\ \ \n\ \... which is neither a type nor a kind \n" where - txt = build expr + txt = insert expr prettyTypeMessage (InvalidOutputType expr) = ErrorMessages {..} where @@ -1086,11 +1122,11 @@ \ \n\ \You specified that your function outputs a: \n\ \ \n\ - \↳ " <> txt <> " \n\ + \" <> txt <> "\n\ \ \n\ \... which is neither a type nor a kind: \n" where - txt = build expr + txt = insert expr prettyTypeMessage (NotAFunction expr0 expr1) = ErrorMessages {..} where @@ -1219,16 +1255,16 @@ \ \n\ \You tried to use the following expression as a function: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... but this expression's type is: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... which is not a function type \n" where - txt0 = build expr0 - txt1 = build expr1 + txt0 = insert expr0 + txt1 = insert expr1 prettyTypeMessage (TypeMismatch expr0 expr1 expr2 expr3) = ErrorMessages {..} where @@ -1345,24 +1381,24 @@ \ \n\ \You tried to invoke the following function: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... which expects an argument of type or kind: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... on the following argument: \n\ \ \n\ - \↳ " <> txt2 <> " \n\ + \" <> txt2 <> "\n\ \ \n\ \... which has a different type or kind: \n\ \ \n\ - \↳ " <> txt3 <> " \n" + \" <> txt3 <> "\n" where - txt0 = build expr0 - txt1 = build expr1 - txt2 = build expr2 - txt3 = build expr3 + txt0 = insert expr0 + txt1 = insert expr1 + txt2 = insert expr2 + txt3 = insert expr3 prettyTypeMessage (AnnotMismatch expr0 expr1 expr2) = ErrorMessages {..} where @@ -1447,19 +1483,19 @@ \ \n\ \You or the interpreter annotated this expression: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... with this type or kind: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... but the inferred type or kind of the expression is actually: \n\ \ \n\ - \↳ " <> txt2 <> " \n" + \" <> txt2 <> "\n" where - txt0 = build expr0 - txt1 = build expr1 - txt2 = build expr2 + txt0 = insert expr0 + txt1 = insert expr1 + txt2 = insert expr2 prettyTypeMessage Untyped = ErrorMessages {..} where @@ -1547,16 +1583,16 @@ \ \n\ \Your ❰if❱ expression begins with the following predicate: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... that has type: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... but the predicate must instead have type ❰Bool❱ \n" where - txt0 = build expr0 - txt1 = build expr1 + txt0 = insert expr0 + txt1 = insert expr1 prettyTypeMessage (IfBranchMustBeTerm b expr0 expr1 expr2) = ErrorMessages {..} @@ -1628,22 +1664,22 @@ \ \n\ \Your ❰" <> txt0 <> "❱ branch of your ❰if❱ expression is: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... which has kind: \n\ \ \n\ - \↳ " <> txt2 <> " \n\ + \" <> txt2 <> "\n\ \ \n\ \... of sort: \n\ \ \n\ - \↳ " <> txt3 <> " \n\ + \" <> txt3 <> "\n\ \ \n\ \... and is not a term. Therefore your ❰if❱ expression is not valid \n" where txt0 = if b then "then" else "else" - txt1 = build expr0 - txt2 = build expr1 - txt3 = build expr2 + txt1 = insert expr0 + txt2 = insert expr1 + txt3 = insert expr2 prettyTypeMessage (IfBranchMismatch expr0 expr1 expr2 expr3) = ErrorMessages {..} @@ -1701,26 +1737,26 @@ \ \n\ \Your ❰if❱ expression has the following ❰then❱ branch: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... which has type: \n\ \ \n\ - \↳ " <> txt2 <> " \n\ + \" <> txt2 <> "\n\ \ \n\ \... and the following ❰else❱ branch: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... which has a different type: \n\ \ \n\ - \↳ " <> txt3 <> " \n\ + \" <> txt3 <> "\n\ \ \n\ \Fix your ❰then❱ and ❰else❱ branches to have matching types \n" where - txt0 = build expr0 - txt1 = build expr1 - txt2 = build expr2 - txt3 = build expr3 + txt0 = insert expr0 + txt1 = insert expr1 + txt2 = insert expr2 + txt3 = insert expr3 prettyTypeMessage (InvalidListType expr0) = ErrorMessages {..} where @@ -1766,11 +1802,11 @@ \ \n\ \You declared that the ❰List❱'s elements should have type: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... which is not a ❰Type❱ \n" where - txt0 = build expr0 + txt0 = insert expr0 prettyTypeMessage MissingListType = do ErrorMessages {..} @@ -1825,15 +1861,15 @@ \ \n\ \Your first ❰List❱ element has this type: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... but the element at index #" <> txt1 <> " has this type instead: \n\ \ \n\ - \↳ " <> txt3 <> " \n" + \" <> txt3 <> "\n" where - txt0 = build expr0 - txt1 = build i - txt3 = build expr2 + txt0 = insert expr0 + txt1 = pretty i + txt3 = insert expr2 prettyTypeMessage (InvalidListElement i expr0 _expr1 expr2) = ErrorMessages {..} @@ -1864,15 +1900,15 @@ \ \n\ \Your ❰List❱ elements should have this type: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... but the element at index #" <> txt1 <> " has this type instead: \n\ \ \n\ - \↳ " <> txt3 <> " \n" + \" <> txt3 <> "\n" where - txt0 = build expr0 - txt1 = build i - txt3 = build expr2 + txt0 = insert expr0 + txt1 = pretty i + txt3 = insert expr2 prettyTypeMessage (InvalidOptionalType expr0) = ErrorMessages {..} where @@ -1920,11 +1956,11 @@ \ \n\ \You declared that the ❰Optional❱ element should have type: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... which is not a ❰Type❱ \n" where - txt0 = build expr0 + txt0 = insert expr0 prettyTypeMessage (InvalidOptionalElement expr0 expr1 expr2) = ErrorMessages {..} where @@ -1953,19 +1989,19 @@ \ \n\ \Your ❰Optional❱ element should have this type: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... but the element you provided: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... has this type instead: \n\ \ \n\ - \↳ " <> txt2 <> " \n" + \" <> txt2 <> "\n" where - txt0 = build expr0 - txt1 = build expr1 - txt2 = build expr2 + txt0 = insert expr0 + txt1 = insert expr1 + txt2 = insert expr2 prettyTypeMessage (InvalidFieldType k expr0) = ErrorMessages {..} where @@ -1999,16 +2035,16 @@ \ \n\ \You provided a record type with a field named: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... annotated with the following expression: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... which is neither a ❰Type❱ nor a ❰Kind❱ \n" where - txt0 = build k - txt1 = build expr0 + txt0 = insert k + txt1 = insert expr0 prettyTypeMessage (FieldAnnotationMismatch k0 expr0 k1 expr1 c) = ErrorMessages {..} where @@ -2043,26 +2079,26 @@ \ \n\ \You provided a record type with a field named: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... annotated with the following expression: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... which is a " <> here <> " whereas another field named: \n\ \ \n\ - \↳ " <> txt2 <> " \n\ + \" <> txt2 <> "\n\ \ \n\ \... annotated with the following expression: \n\ \ \n\ - \↳ " <> txt3 <> " \n\ + \" <> txt3 <> "\n\ \ \n\ \... is a " <> there <> ", which does not match \n" where - txt0 = build k0 - txt1 = build expr0 - txt2 = build k1 - txt3 = build expr1 + txt0 = insert k0 + txt1 = insert expr0 + txt2 = insert k1 + txt3 = insert expr1 here = case c of Type -> "❰Type❱" @@ -2105,26 +2141,26 @@ \ \n\ \You provided a record with a field named: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... whose value was: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... which is a " <> here <> " whereas another field named: \n\ \ \n\ - \↳ " <> txt2 <> " \n\ + \" <> txt2 <> "\n\ \ \n\ \... whose value was: \n\ \ \n\ - \↳ " <> txt3 <> " \n\ + \" <> txt3 <> "\n\ \ \n\ \... is a " <> there <> ", which does not match \n" where - txt0 = build k0 - txt1 = build expr0 - txt2 = build k1 - txt3 = build expr1 + txt0 = insert k0 + txt1 = insert expr0 + txt2 = insert k1 + txt3 = insert expr1 here = case c of Type -> "term" @@ -2160,16 +2196,16 @@ \ \n\ \You provided a record literal with a field named: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... whose value is: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... which is not a term or ❰Type❱ \n" where - txt0 = build k - txt1 = build expr0 + txt0 = insert k + txt1 = insert expr0 prettyTypeMessage (InvalidAlternativeType k expr0) = ErrorMessages {..} where @@ -2222,16 +2258,16 @@ \ \n\ \You provided a union literal with an alternative named: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... whose value is: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... which is not a term \n" where - txt0 = build k - txt1 = build expr0 + txt0 = insert k + txt1 = insert expr0 prettyTypeMessage (InvalidAlternative k expr0) = ErrorMessages {..} where @@ -2284,14 +2320,14 @@ \ \n\ \You provided a union type with an alternative named: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... annotated with the following expression which is not a type: \n\ \ \n\ - \↳ " <> txt1 <> " \n" + \" <> txt1 <> "\n" where - txt0 = build k - txt1 = build expr0 + txt0 = insert k + txt1 = insert expr0 prettyTypeMessage (ListAppendMismatch expr0 expr1) = ErrorMessages {..} where @@ -2325,16 +2361,16 @@ \ \n\ \You tried to append a ❰List❱ thas has elements of type: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... with another ❰List❱ that has elements of type: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... and those two types do not match \n" where - txt0 = build expr0 - txt1 = build expr1 + txt0 = insert expr0 + txt1 = insert expr1 prettyTypeMessage (DuplicateAlternative k) = ErrorMessages {..} where @@ -2358,9 +2394,9 @@ \ \n\ \You have more than one alternative named: \n\ \ \n\ - \↳ " <> txt0 <> " \n" + \" <> txt0 <> "\n" where - txt0 = build k + txt0 = insert k prettyTypeMessage (MustCombineARecord c expr0 expr1) = ErrorMessages {..} where @@ -2408,15 +2444,15 @@ \ \n\ \You tried to combine the following value: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... which is not a record, but is actually a: \n\ \ \n\ - \↳ " <> txt1 <> " \n" + \" <> txt1 <> "\n" where - op = build c - txt0 = build expr0 - txt1 = build expr1 + op = pretty c + txt0 = insert expr0 + txt1 = insert expr1 prettyTypeMessage (CombineTypesRequiresRecordType expr0 expr1) = ErrorMessages {..} @@ -2446,16 +2482,16 @@ \ \n\ \You tried to supply the following argument: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... which normalized to: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... which is not a record type literal \n" where - txt0 = build expr0 - txt1 = build expr1 + txt0 = insert expr0 + txt1 = insert expr1 prettyTypeMessage (RecordTypeMismatch const0 const1 expr0 expr1) = ErrorMessages {..} @@ -2489,24 +2525,24 @@ \ \n\ \You tried to combine the following record type: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... with this record types: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... but the former record type is a: \n\ \ \n\ - \↳ " <> txt2 <> " \n\ + \" <> txt2 <> "\n\ \ \n\ \... but the latter record type is a: \n\ \ \n\ - \↳ " <> txt3 <> " \n" + \" <> txt3 <> "\n" where - txt0 = build expr0 - txt1 = build expr1 - txt2 = build const0 - txt3 = build const1 + txt0 = insert expr0 + txt1 = insert expr1 + txt2 = insert const0 + txt3 = insert const1 prettyTypeMessage (FieldCollision k) = ErrorMessages {..} where @@ -2579,11 +2615,11 @@ \ \n\ \You combined two records that share the following field: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... which is not allowed \n" where - txt0 = build k + txt0 = insert k prettyTypeMessage (MustMergeARecord expr0 expr1) = ErrorMessages {..} where @@ -2631,14 +2667,14 @@ \ \n\ \You provided the following handler: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... which is not a record, but is actually a value of type: \n\ \ \n\ - \↳ " <> txt1 <> " \n" + \" <> txt1 <> "\n" where - txt0 = build expr0 - txt1 = build expr1 + txt0 = insert expr0 + txt1 = insert expr1 prettyTypeMessage (MustMergeUnion expr0 expr1) = ErrorMessages {..} where @@ -2671,14 +2707,14 @@ \ \n\ \You tried to ❰merge❱ this expression: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... which is not a union, but is actually a value of type: \n\ \ \n\ - \↳ " <> txt1 <> " \n" + \" <> txt1 <> "\n" where - txt0 = build expr0 - txt1 = build expr1 + txt0 = insert expr0 + txt1 = insert expr1 prettyTypeMessage (UnusedHandler ks) = ErrorMessages {..} where @@ -2714,11 +2750,11 @@ \ \n\ \You provided the following handlers: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... which had no matching alternatives in the union you tried to ❰merge❱ \n" where - txt0 = build (Text.intercalate ", " (Data.Set.toList ks)) + txt0 = insert (Text.intercalate ", " (Data.Set.toList ks)) prettyTypeMessage (MissingHandler ks) = ErrorMessages {..} where @@ -2756,9 +2792,9 @@ \ \n\ \You need to supply the following handlers: \n\ \ \n\ - \↳ " <> txt0 <> " \n" + \" <> txt0 <> "\n" where - txt0 = build (Text.intercalate ", " (Data.Set.toList ks)) + txt0 = insert (Text.intercalate ", " (Data.Set.toList ks)) prettyTypeMessage MissingMergeType = ErrorMessages {..} @@ -2838,19 +2874,19 @@ \ \n\ \Your handler for the following alternative: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... needs to accept an input value of type: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... but actually accepts an input value of a different type: \n\ \ \n\ - \↳ " <> txt2 <> " \n" + \" <> txt2 <> "\n" where - txt0 = build expr0 - txt1 = build expr1 - txt2 = build expr2 + txt0 = insert expr0 + txt1 = insert expr1 + txt2 = insert expr2 prettyTypeMessage (InvalidHandlerOutputType expr0 expr1 expr2) = ErrorMessages {..} @@ -2902,19 +2938,19 @@ \ \n\ \Your handler for the following alternative: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... needs to return an output value of type: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... but actually returns an output value of a different type: \n\ \ \n\ - \↳ " <> txt2 <> " \n" + \" <> txt2 <> "\n" where - txt0 = build expr0 - txt1 = build expr1 - txt2 = build expr2 + txt0 = insert expr0 + txt1 = insert expr1 + txt2 = insert expr2 prettyTypeMessage (HandlerOutputTypeMismatch key0 expr0 key1 expr1) = ErrorMessages {..} @@ -2962,16 +2998,16 @@ \ \n\ \The handler for the ❰" <> txt0 <> "❱ alternative has this output type: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... but the handler for the ❰" <> txt2 <> "❱ alternative has this output type instead:\n\ \ \n\ - \↳ " <> txt3 <> " \n" + \" <> txt3 <> "\n" where - txt0 = build key0 - txt1 = build expr0 - txt2 = build key1 - txt3 = build expr1 + txt0 = pretty key0 + txt1 = insert expr0 + txt2 = pretty key1 + txt3 = insert expr1 prettyTypeMessage (HandlerNotAFunction k expr0) = ErrorMessages {..} where @@ -3003,16 +3039,16 @@ \ \n\ \Your handler for this alternative: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... has the following type: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... which is not the type of a function \n" where - txt0 = build k - txt1 = build expr0 + txt0 = insert k + txt1 = insert expr0 prettyTypeMessage (ConstructorsRequiresAUnionType expr0 expr1) = ErrorMessages {..} where @@ -3055,16 +3091,16 @@ \ \n\ \You tried to supply the following argument: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... which normalized to: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... which is not a union type literal \n" where - txt0 = build expr0 - txt1 = build expr1 + txt0 = insert expr0 + txt1 = insert expr1 prettyTypeMessage (NotARecord lazyText0 expr0 expr1) = ErrorMessages {..} where @@ -3113,19 +3149,19 @@ \ \n\ \You tried to access the field(s): \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... on the following expression which is not a record: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... but is actually an expression of type: \n\ \ \n\ - \↳ " <> txt2 <> " \n" + \" <> txt2 <> "\n" where - txt0 = build lazyText0 - txt1 = build expr0 - txt2 = build expr1 + txt0 = insert lazyText0 + txt1 = insert expr0 + txt2 = insert expr1 prettyTypeMessage (MissingField k expr0) = ErrorMessages {..} where @@ -3157,14 +3193,14 @@ \ \n\ \You tried to access a field named: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... but the field is missing because the record only defines the following fields:\n\ \ \n\ - \↳ " <> txt1 <> " \n" + \" <> txt1 <> "\n" where - txt0 = build k - txt1 = build expr0 + txt0 = insert k + txt1 = insert expr0 prettyTypeMessage (CantAnd expr0 expr1) = buildBooleanOperator "&&" expr0 expr1 @@ -3231,16 +3267,14 @@ \ \n\ \You interpolated this expression: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... which does not have type ❰Text❱ but instead has type: \n\ \ \n\ - \↳ " <> txt1 <> " \n" + \" <> txt1 <> "\n" where - txt0 = build expr0 - txt1 = build expr1 - - + txt0 = insert expr0 + txt1 = insert expr1 prettyTypeMessage (CantTextAppend expr0 expr1) = ErrorMessages {..} where @@ -3279,14 +3313,14 @@ \ \n\ \You provided this argument: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... which does not have type ❰Text❱ but instead has type: \n\ \ \n\ - \↳ " <> txt1 <> " \n" + \" <> txt1 <> "\n" where - txt0 = build expr0 - txt1 = build expr1 + txt0 = insert expr0 + txt1 = insert expr1 prettyTypeMessage (CantListAppend expr0 expr1) = ErrorMessages {..} where @@ -3307,14 +3341,14 @@ \ \n\ \You provided this argument: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... which is not a ❰List❱ but instead has type: \n\ \ \n\ - \↳ " <> txt1 <> " \n" + \" <> txt1 <> "\n" where - txt0 = build expr0 - txt1 = build expr1 + txt0 = insert expr0 + txt1 = insert expr1 prettyTypeMessage (CantAdd expr0 expr1) = buildNaturalOperator "+" expr0 expr1 @@ -3351,18 +3385,18 @@ \ \n\ \Your function type is invalid because the input has type: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... and the output has kind: \n\ \ \n\ - \↳ " <> txt1 <> " \n\ + \" <> txt1 <> "\n\ \ \n\ \... which makes this a forbidden dependent function type \n" where - txt0 = build expr0 - txt1 = build expr1 + txt0 = insert expr0 + txt1 = insert expr1 -buildBooleanOperator :: Buildable a => Text -> Expr s a -> Expr s a -> ErrorMessages +buildBooleanOperator :: Pretty a => Text -> Expr s a -> Expr s a -> ErrorMessages buildBooleanOperator operator expr0 expr1 = ErrorMessages {..} where short = "❰" <> txt2 <> "❱ only works on ❰Bool❱s" @@ -3380,18 +3414,18 @@ \ \n\ \You provided this argument: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... which does not have type ❰Bool❱ but instead has type: \n\ \ \n\ - \↳ " <> txt1 <> " \n" + \" <> txt1 <> "\n" where - txt0 = build expr0 - txt1 = build expr1 + txt0 = insert expr0 + txt1 = insert expr1 - txt2 = build operator + txt2 = pretty operator -buildNaturalOperator :: Buildable a => Text -> Expr s a -> Expr s a -> ErrorMessages +buildNaturalOperator :: Pretty a => Text -> Expr s a -> Expr s a -> ErrorMessages buildNaturalOperator operator expr0 expr1 = ErrorMessages {..} where short = "❰" <> txt2 <> "❱ only works on ❰Natural❱s" @@ -3441,50 +3475,55 @@ \ \n\ \You provided this argument: \n\ \ \n\ - \↳ " <> txt0 <> " \n\ + \" <> txt0 <> "\n\ \ \n\ \... which does not have type ❰Natural❱ but instead has type: \n\ \ \n\ - \↳ " <> txt1 <> " \n" + \" <> txt1 <> "\n" where - txt0 = build expr0 - txt1 = build expr1 + txt0 = insert expr0 + txt1 = insert expr1 - txt2 = build operator + txt2 = pretty operator -- | A structured type error that includes context data TypeError s a = TypeError { context :: Context (Expr s a) , current :: Expr s a , typeMessage :: TypeMessage s a - } deriving (Typeable) + } -instance (Buildable a, Buildable s, Eq a, Pretty a) => Show (TypeError s a) where - show = Text.unpack . Builder.toLazyText . build +instance (Eq a, Pretty s, Pretty a) => Show (TypeError s a) where + show = Pretty.renderString . Pretty.layoutPretty options . Pretty.pretty + where + options = + Pretty.LayoutOptions + { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 } -instance (Buildable a, Buildable s, Eq a, Pretty a, Typeable a, Typeable s) => Exception (TypeError s a) +instance (Eq a, Pretty s, Pretty a, Typeable s, Typeable a) => Exception (TypeError s a) -instance (Buildable a, Buildable s, Eq a, Pretty a) => Buildable (TypeError s a) where - build (TypeError ctx expr msg) - = "\n" - <> ( if Text.null (Builder.toLazyText (buildContext ctx)) - then "" - else buildContext ctx <> "\n" +instance (Eq a, Pretty s, Pretty a) => Pretty (TypeError s a) where + pretty (TypeError ctx expr msg) + = Pretty.unAnnotate + ("\n" + <> ( if null (Dhall.Context.toList ctx) + then "" + else prettyContext ctx <> "\n" + ) + <> shortTypeMessage msg <> "\n" + <> source ) - <> shortTypeMessage msg <> "\n" - <> source where - buildKV (key, val) = build key <> " : " <> build val + prettyKV (key, val) = pretty key <> " : " <> pretty val - buildContext = - build - . Text.unlines - . map (Builder.toLazyText . buildKV) + prettyContext = + Pretty.vsep + . map prettyKV . reverse . Dhall.Context.toList source = case expr of - Note s _ -> build s + Note s _ -> pretty s _ -> mempty {-| Newtype used to wrap error messages so that they render with a more @@ -3493,34 +3532,39 @@ newtype DetailedTypeError s a = DetailedTypeError (TypeError s a) deriving (Typeable) -instance (Buildable a, Buildable s, Eq a, Pretty a) => Show (DetailedTypeError s a) where - show = Text.unpack . Builder.toLazyText . build +instance (Eq a, Pretty s, Pretty a) => Show (DetailedTypeError s a) where + show = Pretty.renderString . Pretty.layoutPretty options . Pretty.pretty + where + options = + Pretty.LayoutOptions + { Pretty.layoutPageWidth = Pretty.AvailablePerLine 80 1.0 } -instance (Buildable a, Buildable s, Eq a, Pretty a, Typeable a, Typeable s) => Exception (DetailedTypeError s a) +instance (Eq a, Pretty s, Pretty a, Typeable s, Typeable a) => Exception (DetailedTypeError s a) -instance (Buildable a, Buildable s, Eq a, Pretty a) => Buildable (DetailedTypeError s a) where - build (DetailedTypeError (TypeError ctx expr msg)) - = "\n" - <> ( if Text.null (Builder.toLazyText (buildContext ctx)) - then "" - else buildContext ctx <> "\n" +instance (Eq a, Pretty s, Pretty a) => Pretty (DetailedTypeError s a) where + pretty (DetailedTypeError (TypeError ctx expr msg)) + = Pretty.unAnnotate + ( "\n" + <> ( if null (Dhall.Context.toList ctx) + then "" + else prettyContext ctx <> "\n" + ) + <> longTypeMessage msg <> "\n" + <> "────────────────────────────────────────────────────────────────────────────────\n" + <> "\n" + <> source ) - <> longTypeMessage msg <> "\n" - <> "────────────────────────────────────────────────────────────────────────────────\n" - <> "\n" - <> source where - buildKV (key, val) = build key <> " : " <> build val + prettyKV (key, val) = pretty key <> " : " <> pretty val - buildContext = - build - . Text.unlines - . map (Builder.toLazyText . buildKV) + prettyContext = + Pretty.vsep + . map prettyKV . reverse . Dhall.Context.toList source = case expr of - Note s _ -> build s + Note s _ -> pretty s _ -> mempty {-| This function verifies that a custom context is well-formed so that diff --git a/tests/Format.hs b/tests/Format.hs --- a/tests/Format.hs +++ b/tests/Format.hs @@ -8,7 +8,7 @@ import qualified Control.Exception import qualified Data.Text -import qualified Data.Text.Lazy.IO +import qualified Data.Text.IO import qualified Data.Text.Prettyprint.Doc import qualified Data.Text.Prettyprint.Doc.Render.Text import qualified Dhall.Parser @@ -36,6 +36,24 @@ , should "correctly format the empty record literal" "emptyRecord" + , should + "indent then/else to the same column" + "ifThenElse" + , should + "handle indenting long imports correctly without trailing space per line" + "importLines" + , should + "handle indenting small imports correctly without trailing space inline" + "importLines2" + , should + "not remove parentheses when accessing a field of a record" + "importAccess" + , should + "handle formatting sha256 imports correctly" + "sha256Printing" + , should + "handle formatting of Import suffix correctly" + "importSuffix" ] opts :: Data.Text.Prettyprint.Doc.LayoutOptions @@ -52,7 +70,7 @@ Data.Text.unpack ("./tests/format/" <> basename <> "A.dhall") let outputFile = Data.Text.unpack ("./tests/format/" <> basename <> "B.dhall") - inputText <- Data.Text.Lazy.IO.readFile inputFile + inputText <- Data.Text.IO.readFile inputFile expr <- case Dhall.Parser.exprFromText mempty inputText of Left err -> Control.Exception.throwIO err @@ -60,9 +78,9 @@ let doc = Data.Text.Prettyprint.Doc.pretty expr let docStream = Data.Text.Prettyprint.Doc.layoutSmart opts doc - let actualText = Data.Text.Prettyprint.Doc.Render.Text.renderLazy docStream + let actualText = Data.Text.Prettyprint.Doc.Render.Text.renderStrict docStream - expectedText <- Data.Text.Lazy.IO.readFile outputFile + expectedText <- Data.Text.IO.readFile outputFile let message = "The formatted expression did not match the expected output" diff --git a/tests/Import.hs b/tests/Import.hs new file mode 100644 --- /dev/null +++ b/tests/Import.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Import where + +import Data.Text (Text) +import Test.Tasty (TestTree) +import Dhall.Import (MissingImports(..)) +import Control.Exception (catch, throwIO) +import Data.Monoid ((<>)) + +import qualified Data.Text +import qualified Data.Text.IO +import qualified Dhall.Parser +import qualified Dhall.Import +import qualified Test.Tasty +import qualified Test.Tasty.HUnit + +importTests :: TestTree +importTests = + Test.Tasty.testGroup "import tests" + [ Test.Tasty.testGroup "import alternatives" + [ shouldFail + 3 + "alternative of several unset env variables" + "./tests/import/alternativeEnv.dhall" + , shouldFail + 1 + "alternative of env variable and missing" + "./tests/import/alternativeEnvMissing.dhall" + , shouldFail + 0 + "just missing" + "./tests/import/missing.dhall" + , shouldNotFail + "alternative of env variable, missing, and a Natural" + "./tests/import/alternativeEnvNatural.dhall" + , shouldNotFail + "alternative of env variable and a Natural" + "./tests/import/alternativeEnvSimple.dhall" + , shouldNotFail + "alternative of a Natural and missing" + "./tests/import/alternativeNatural.dhall" + ] + ] + +shouldNotFail :: Text -> FilePath -> TestTree +shouldNotFail name path = Test.Tasty.HUnit.testCase (Data.Text.unpack name) (do + text <- Data.Text.IO.readFile path + actualExpr <- case Dhall.Parser.exprFromText mempty text of + Left err -> throwIO err + Right expr -> return expr + _ <- Dhall.Import.load actualExpr + return ()) + +shouldFail :: Int -> Text -> FilePath -> TestTree +shouldFail failures name path = Test.Tasty.HUnit.testCase (Data.Text.unpack name) (do + text <- Data.Text.IO.readFile path + actualExpr <- case Dhall.Parser.exprFromText mempty text of + Left err -> throwIO err + Right expr -> return expr + catch + (do + _ <- Dhall.Import.load actualExpr + fail "Import should have failed, but it succeeds") + (\(MissingImports es) -> case length es == failures of + True -> pure () + False -> fail ("Should have failed " + <> show failures + <> " times, but failed with: \n" + <> show es)) ) diff --git a/tests/Normalization.hs b/tests/Normalization.hs --- a/tests/Normalization.hs +++ b/tests/Normalization.hs @@ -4,12 +4,12 @@ module Normalization (normalizationTests) where import Data.Monoid ((<>)) -import Data.Text.Lazy (Text) +import Data.Text (Text) import Dhall.Core (Expr) import Dhall.TypeCheck (X) import qualified Control.Exception -import qualified Data.Text.Lazy +import qualified Data.Text import qualified Dhall.Core import qualified Dhall.Import import qualified Dhall.Parser @@ -19,7 +19,7 @@ import Dhall.Context import Test.Tasty import Test.Tasty.HUnit -import Util +import Util normalizationTests :: TestTree normalizationTests = @@ -32,6 +32,7 @@ , shouldNormalize "Optional build/fold fusion" "optionalBuildFold" , customization , shouldNormalize "a remote-systems.conf builder" "remoteSystems" + , shouldNormalize "multi-line strings correctly" "multiLine" ] tutorialExamples :: TestTree @@ -68,6 +69,8 @@ , shouldNormalize "Double/show" "./examples/Double/show/1" , shouldNormalize "Integer/show" "./examples/Integer/show/0" , shouldNormalize "Integer/show" "./examples/Integer/show/1" + , shouldNormalize "Integer/toDouble" "./examples/Integer/toDouble/0" + , shouldNormalize "Integer/toDouble" "./examples/Integer/toDouble/1" , shouldNormalize "List/all" "./examples/List/all/0" , shouldNormalize "List/all" "./examples/List/all/1" , shouldNormalize "List/any" "./examples/List/any/0" @@ -87,6 +90,8 @@ , shouldNormalize "List/generate" "./examples/List/generate/1" , shouldNormalize "List/head" "./examples/List/head/0" , shouldNormalize "List/head" "./examples/List/head/1" + , shouldNormalize "List/indexed" "./examples/List/indexed/0" + , shouldNormalize "List/indexed" "./examples/List/indexed/1" , shouldNormalize "List/iterate" "./examples/List/iterate/0" , shouldNormalize "List/iterate" "./examples/List/iterate/1" , shouldNormalize "List/last" "./examples/List/last/0" @@ -124,6 +129,8 @@ , shouldNormalize "Natural/show" "./examples/Natural/show/1" , shouldNormalize "Natural/sum" "./examples/Natural/sum/0" , shouldNormalize "Natural/sum" "./examples/Natural/sum/1" + , shouldNormalize "Natural/toDouble" "./examples/Natural/toDouble/0" + , shouldNormalize "Natural/toDouble" "./examples/Natural/toDouble/1" , shouldNormalize "Natural/toInteger" "./examples/Natural/toInteger/0" , shouldNormalize "Natural/toInteger" "./examples/Natural/toInteger/1" , shouldNormalize "Optional/all" "./examples/Optional/all/0" @@ -199,11 +206,11 @@ simpleCustomization :: TestTree simpleCustomization = testCase "simpleCustomization" $ do - let tyCtx = insert "min" (Pi "_" Natural (Pi "_" Natural Natural)) empty + let tyCtx = insert "min" (Pi "_" Natural (Pi "_" Natural Natural)) empty valCtx e = case e of (App (App (Var (V "min" 0)) (NaturalLit x)) (NaturalLit y)) -> Just (NaturalLit (min x y)) _ -> Nothing - e <- codeWith tyCtx "min (min 11 12) 8 + 1" + e <- codeWith tyCtx "min (min 11 12) 8 + 1" assertNormalizesToWith valCtx e "9" nestedReduction :: TestTree @@ -215,7 +222,7 @@ valCtx e = case e of (App (App (Var (V "min" 0)) (NaturalLit x)) (NaturalLit y)) -> Just (NaturalLit (min x y)) (App (Var (V "wurble" 0)) (NaturalLit x)) -> Just - (App (Var (V "fiveorless" 0)) (NaturalPlus (NaturalLit x) (NaturalLit 2))) + (App (Var (V "fiveorless" 0)) (NaturalPlus (NaturalLit x) (NaturalLit 2))) (App (Var (V "fiveorless" 0)) (NaturalLit x)) -> Just (App (App (Var (V "min" 0)) (NaturalLit x)) (NaturalPlus (NaturalLit 3) (NaturalLit 2))) _ -> Nothing @@ -224,7 +231,7 @@ should :: Text -> Text -> TestTree should name basename = - Test.Tasty.HUnit.testCase (Data.Text.Lazy.unpack name) $ do + Test.Tasty.HUnit.testCase (Data.Text.unpack name) $ do let actualCode = "./tests/normalization/" <> basename <> "A.dhall" let expectedCode = "./tests/normalization/" <> basename <> "B.dhall" diff --git a/tests/Parser.hs b/tests/Parser.hs --- a/tests/Parser.hs +++ b/tests/Parser.hs @@ -7,7 +7,7 @@ import qualified Control.Exception import qualified Data.Text -import qualified Data.Text.Lazy.IO +import qualified Data.Text.IO import qualified Dhall.Parser import qualified Test.Tasty import qualified Test.Tasty.HUnit @@ -125,6 +125,9 @@ "builtins" "./tests/parser/builtins.dhall" , shouldParse + "import alternatives" + "./tests/parser/importAlt.dhall" + , shouldParse "large expression" "./tests/parser/largeExpression.dhall" , shouldParse @@ -133,12 +136,31 @@ , shouldParse "interpolated expressions with leading whitespace" "./tests/parser/template.dhall" + , shouldNotParse + "records with duplicate fields" + "./tests/parser/failure/duplicateFields.dhall" + , shouldParse + "collections with type annotations containing imports" + "./tests/parser/collectionImportType.dhall" + , shouldParse + "a parenthesized custom header import" + "./tests/parser/parenthesizeUsing.dhall" + , shouldNotParse + "accessing a field of an import without parentheses" + "./tests/parser/failure/importAccess.dhall" ] ] shouldParse :: Text -> FilePath -> TestTree shouldParse name path = Test.Tasty.HUnit.testCase (Data.Text.unpack name) (do - text <- Data.Text.Lazy.IO.readFile path + text <- Data.Text.IO.readFile path case Dhall.Parser.exprFromText mempty text of Left err -> Control.Exception.throwIO err Right _ -> return () ) + +shouldNotParse :: Text -> FilePath -> TestTree +shouldNotParse name path = Test.Tasty.HUnit.testCase (Data.Text.unpack name) (do + text <- Data.Text.IO.readFile path + case Dhall.Parser.exprFromText mempty text of + Left _ -> return () + Right _ -> fail "Unexpected successful parser" ) diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -6,6 +6,7 @@ import Tutorial (tutorialTests) import TypeCheck (typecheckTests) import Format (formatTests) +import Import (importTests) import Test.Tasty allTests :: TestTree @@ -17,6 +18,7 @@ , tutorialTests , formatTests , typecheckTests + , importTests ] main :: IO () diff --git a/tests/TypeCheck.hs b/tests/TypeCheck.hs --- a/tests/TypeCheck.hs +++ b/tests/TypeCheck.hs @@ -3,11 +3,11 @@ module TypeCheck where import Data.Monoid (mempty, (<>)) -import Data.Text.Lazy (Text) +import Data.Text (Text) import Test.Tasty (TestTree) import qualified Control.Exception -import qualified Data.Text.Lazy +import qualified Data.Text import qualified Dhall.Core import qualified Dhall.Import import qualified Dhall.Parser @@ -47,7 +47,7 @@ should :: Text -> Text -> TestTree should name basename = - Test.Tasty.HUnit.testCase (Data.Text.Lazy.unpack name) $ do + Test.Tasty.HUnit.testCase (Data.Text.unpack name) $ do let actualCode = "./tests/typecheck/" <> basename <> "A.dhall" let expectedCode = "./tests/typecheck/" <> basename <> "B.dhall" diff --git a/tests/Util.hs b/tests/Util.hs --- a/tests/Util.hs +++ b/tests/Util.hs @@ -16,7 +16,6 @@ import qualified Data.Functor import Data.Bifunctor (first) import Data.Text (Text) -import qualified Data.Text.Lazy import qualified Dhall.Core import Dhall.Core (Expr, Normalizer) import qualified Dhall.Context @@ -28,19 +27,18 @@ import Dhall.TypeCheck (X) import Test.Tasty.HUnit -normalize' :: Expr Src X -> Data.Text.Lazy.Text +normalize' :: Expr Src X -> Text normalize' = Dhall.Core.pretty . Dhall.Core.normalize -normalizeWith' :: Normalizer X -> Expr Src X -> Data.Text.Lazy.Text +normalizeWith' :: Normalizer X -> Expr Src X -> Text normalizeWith' ctx = Dhall.Core.pretty . Dhall.Core.normalizeWith ctx -code :: Data.Text.Text -> IO (Expr Src X) +code :: Text -> IO (Expr Src X) code = codeWith Dhall.Context.empty -codeWith :: Context (Expr Src X) -> Data.Text.Text -> IO (Expr Src X) -codeWith ctx strictText = do - let lazyText = Data.Text.Lazy.fromStrict strictText - expr0 <- case Dhall.Parser.exprFromText mempty lazyText of +codeWith :: Context (Expr Src X) -> Text -> IO (Expr Src X) +codeWith ctx expr = do + expr0 <- case Dhall.Parser.exprFromText mempty expr of Left parseError -> Control.Exception.throwIO parseError Right expr0 -> return expr0 expr1 <- Dhall.Import.load expr0 @@ -49,19 +47,19 @@ Right _ -> return () return expr1 -equivalent :: Data.Text.Text -> Data.Text.Text -> IO () +equivalent :: Text -> Text -> IO () equivalent text0 text1 = do expr0 <- fmap Dhall.Core.normalize (Util.code text0) :: IO (Expr X X) expr1 <- fmap Dhall.Core.normalize (Util.code text1) :: IO (Expr X X) assertEqual "Expressions are not equivalent" expr0 expr1 -assertNormalizesTo :: Expr Src X -> Data.Text.Lazy.Text -> IO () -assertNormalizesTo e expected = do +assertNormalizesTo :: Expr Src X -> Text -> IO () +assertNormalizesTo e expected = do assertBool msg (not $ Dhall.Core.isNormalized e) normalize' e @?= expected where msg = "Given expression is already in normal form" -assertNormalizesToWith :: Normalizer X -> Expr Src X -> Data.Text.Lazy.Text -> IO () +assertNormalizesToWith :: Normalizer X -> Expr Src X -> Text -> IO () assertNormalizesToWith ctx e expected = do assertBool msg (not $ Dhall.Core.isNormalizedWith ctx (first (const ()) e)) normalizeWith' ctx e @?= expected diff --git a/tests/format/ifThenElseA.dhall b/tests/format/ifThenElseA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/ifThenElseA.dhall @@ -0,0 +1,2 @@ +if True then if True then if True then 1 else 2 else if True then 3 else 4 +else if True then if True then 5 else 6 else if True then 7 else 8 diff --git a/tests/format/ifThenElseB.dhall b/tests/format/ifThenElseB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/ifThenElseB.dhall @@ -0,0 +1,13 @@ + if True + +then if True then if True then 1 else 2 else if True then 3 else 4 + +else if True + +then if True then 5 else 6 + +else if True + +then 7 + +else 8 diff --git a/tests/format/importAccessA.dhall b/tests/format/importAccessA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/importAccessA.dhall @@ -0,0 +1,1 @@ +(./testImport).hello diff --git a/tests/format/importAccessB.dhall b/tests/format/importAccessB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/importAccessB.dhall @@ -0,0 +1,1 @@ +(./testImport).hello diff --git a/tests/format/importLines2A.dhall b/tests/format/importLines2A.dhall new file mode 100644 --- /dev/null +++ b/tests/format/importLines2A.dhall @@ -0,0 +1,2 @@ +let _ = ./emptyRecordA.dhall +in let _ = ./emptyRecordA.dhall in 123 diff --git a/tests/format/importLines2B.dhall b/tests/format/importLines2B.dhall new file mode 100644 --- /dev/null +++ b/tests/format/importLines2B.dhall @@ -0,0 +1,1 @@ +let _ = ./emptyRecordA.dhall in let _ = ./emptyRecordA.dhall in 123 diff --git a/tests/format/importLinesA.dhall b/tests/format/importLinesA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/importLinesA.dhall @@ -0,0 +1,7 @@ +let _ = ./emptyRecordA.dhall +in let _ = ./emptyRecordA.dhall +in let _ = ./emptyRecordA.dhall +in let _ = ./emptyRecordA.dhall +in let _ = ./emptyRecordA.dhall +in let _ = ./emptyRecordA.dhall +in 123 diff --git a/tests/format/importLinesB.dhall b/tests/format/importLinesB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/importLinesB.dhall @@ -0,0 +1,13 @@ + let _ = ./emptyRecordA.dhall + +in let _ = ./emptyRecordA.dhall + +in let _ = ./emptyRecordA.dhall + +in let _ = ./emptyRecordA.dhall + +in let _ = ./emptyRecordA.dhall + +in let _ = ./emptyRecordA.dhall + +in 123 diff --git a/tests/format/importSuffixA.dhall b/tests/format/importSuffixA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/importSuffixA.dhall @@ -0,0 +1,1 @@ +let a = env:AAA as Text in a diff --git a/tests/format/importSuffixB.dhall b/tests/format/importSuffixB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/importSuffixB.dhall @@ -0,0 +1,1 @@ +let a = env:AAA as Text in a diff --git a/tests/format/sha256PrintingA.dhall b/tests/format/sha256PrintingA.dhall new file mode 100644 --- /dev/null +++ b/tests/format/sha256PrintingA.dhall @@ -0,0 +1,2 @@ +let replicate = + https://raw.githubusercontent.com/dhall-lang/Prelude/c79c2bc3c46f129cc5b6d594ce298a381bcae92c/List/replicate sha256:b0e3ec1797b32c80c0bcb7e8254b08c7e9e35e75e6b410c7ac21477ab90167ad in replicate 5 diff --git a/tests/format/sha256PrintingB.dhall b/tests/format/sha256PrintingB.dhall new file mode 100644 --- /dev/null +++ b/tests/format/sha256PrintingB.dhall @@ -0,0 +1,4 @@ + let replicate = + https://raw.githubusercontent.com/dhall-lang/Prelude/c79c2bc3c46f129cc5b6d594ce298a381bcae92c/List/replicate sha256:b0e3ec1797b32c80c0bcb7e8254b08c7e9e35e75e6b410c7ac21477ab90167ad + +in replicate 5 diff --git a/tests/import/alternativeEnv.dhall b/tests/import/alternativeEnv.dhall new file mode 100644 --- /dev/null +++ b/tests/import/alternativeEnv.dhall @@ -0,0 +1,1 @@ +env:UNSET1 as Text ? env:UNSET2 ? missing ? env:UNSET3 diff --git a/tests/import/alternativeEnvMissing.dhall b/tests/import/alternativeEnvMissing.dhall new file mode 100644 --- /dev/null +++ b/tests/import/alternativeEnvMissing.dhall @@ -0,0 +1,1 @@ +env:UNSET ? missing diff --git a/tests/import/alternativeEnvNatural.dhall b/tests/import/alternativeEnvNatural.dhall new file mode 100644 --- /dev/null +++ b/tests/import/alternativeEnvNatural.dhall @@ -0,0 +1,1 @@ +env:UNSET1 as Text ? env:UNSET2 ? missing ? env:UNSET3 ? 2 diff --git a/tests/import/alternativeEnvSimple.dhall b/tests/import/alternativeEnvSimple.dhall new file mode 100644 --- /dev/null +++ b/tests/import/alternativeEnvSimple.dhall @@ -0,0 +1,1 @@ +env:UNSET ? 3 diff --git a/tests/import/alternativeNatural.dhall b/tests/import/alternativeNatural.dhall new file mode 100644 --- /dev/null +++ b/tests/import/alternativeNatural.dhall @@ -0,0 +1,1 @@ +4 ? missing diff --git a/tests/import/missing.dhall b/tests/import/missing.dhall new file mode 100644 --- /dev/null +++ b/tests/import/missing.dhall @@ -0,0 +1,1 @@ +missing diff --git a/tests/normalization/examples/Integer/toDouble/0A.dhall b/tests/normalization/examples/Integer/toDouble/0A.dhall new file mode 100644 --- /dev/null +++ b/tests/normalization/examples/Integer/toDouble/0A.dhall @@ -0,0 +1,1 @@ +../../../../../Prelude/Integer/toDouble -3 diff --git a/tests/normalization/examples/Integer/toDouble/0B.dhall b/tests/normalization/examples/Integer/toDouble/0B.dhall new file mode 100644 --- /dev/null +++ b/tests/normalization/examples/Integer/toDouble/0B.dhall @@ -0,0 +1,1 @@ +-3.0 diff --git a/tests/normalization/examples/Integer/toDouble/1A.dhall b/tests/normalization/examples/Integer/toDouble/1A.dhall new file mode 100644 --- /dev/null +++ b/tests/normalization/examples/Integer/toDouble/1A.dhall @@ -0,0 +1,1 @@ +../../../../../Prelude/Integer/toDouble +2 diff --git a/tests/normalization/examples/Integer/toDouble/1B.dhall b/tests/normalization/examples/Integer/toDouble/1B.dhall new file mode 100644 --- /dev/null +++ b/tests/normalization/examples/Integer/toDouble/1B.dhall @@ -0,0 +1,1 @@ +2.0 diff --git a/tests/normalization/examples/List/indexed/0A.dhall b/tests/normalization/examples/List/indexed/0A.dhall --- a/tests/normalization/examples/List/indexed/0A.dhall +++ b/tests/normalization/examples/List/indexed/0A.dhall @@ -1,1 +1,1 @@ -../../../../../Prelude/List/indexed Bool ([] : List Bool) +../../../../../Prelude/List/indexed Bool [ True, False, True ] diff --git a/tests/normalization/examples/List/indexed/0B.dhall b/tests/normalization/examples/List/indexed/0B.dhall --- a/tests/normalization/examples/List/indexed/0B.dhall +++ b/tests/normalization/examples/List/indexed/0B.dhall @@ -1,4 +1,4 @@ -[ { index = +0, value = True } -, { index = +1, value = False } -, { index = +2, valu;e = True } +[ { index = 0, value = True } +, { index = 1, value = False } +, { index = 2, value = True } ] diff --git a/tests/normalization/examples/Natural/toDouble/0A.dhall b/tests/normalization/examples/Natural/toDouble/0A.dhall new file mode 100644 --- /dev/null +++ b/tests/normalization/examples/Natural/toDouble/0A.dhall @@ -0,0 +1,1 @@ +../../../../../Prelude/Natural/toDouble 3 diff --git a/tests/normalization/examples/Natural/toDouble/0B.dhall b/tests/normalization/examples/Natural/toDouble/0B.dhall new file mode 100644 --- /dev/null +++ b/tests/normalization/examples/Natural/toDouble/0B.dhall @@ -0,0 +1,1 @@ +3.0 diff --git a/tests/normalization/examples/Natural/toDouble/1A.dhall b/tests/normalization/examples/Natural/toDouble/1A.dhall new file mode 100644 --- /dev/null +++ b/tests/normalization/examples/Natural/toDouble/1A.dhall @@ -0,0 +1,1 @@ +../../../../../Prelude/Natural/toDouble 0 diff --git a/tests/normalization/examples/Natural/toDouble/1B.dhall b/tests/normalization/examples/Natural/toDouble/1B.dhall new file mode 100644 --- /dev/null +++ b/tests/normalization/examples/Natural/toDouble/1B.dhall @@ -0,0 +1,1 @@ +0.0 diff --git a/tests/normalization/multiLineA.dhall b/tests/normalization/multiLineA.dhall new file mode 100644 --- /dev/null +++ b/tests/normalization/multiLineA.dhall @@ -0,0 +1,4 @@ +'' + foo +bar +'' diff --git a/tests/normalization/multiLineB.dhall b/tests/normalization/multiLineB.dhall new file mode 100644 --- /dev/null +++ b/tests/normalization/multiLineB.dhall @@ -0,0 +1,4 @@ +'' + foo +bar +'' diff --git a/tests/parser/collectionImportType.dhall b/tests/parser/collectionImportType.dhall new file mode 100644 --- /dev/null +++ b/tests/parser/collectionImportType.dhall @@ -0,0 +1,3 @@ +{ example0 = [] : Optional ./type.dhall +, example1 = [] : List ./type.dhall +} diff --git a/tests/parser/failure/duplicateFields.dhall b/tests/parser/failure/duplicateFields.dhall new file mode 100644 --- /dev/null +++ b/tests/parser/failure/duplicateFields.dhall @@ -0,0 +1,1 @@ +{ a = 1, a = 2 } diff --git a/tests/parser/failure/importAccess.dhall b/tests/parser/failure/importAccess.dhall new file mode 100644 --- /dev/null +++ b/tests/parser/failure/importAccess.dhall @@ -0,0 +1,1 @@ +./testImport .hello diff --git a/tests/parser/importAlt.dhall b/tests/parser/importAlt.dhall new file mode 100644 --- /dev/null +++ b/tests/parser/importAlt.dhall @@ -0,0 +1,1 @@ +env:UNSET1 as Text ? env:UNSET2 ? missing ? env:UNSET3 ? 2 diff --git a/tests/parser/parenthesizeUsing.dhall b/tests/parser/parenthesizeUsing.dhall new file mode 100644 --- /dev/null +++ b/tests/parser/parenthesizeUsing.dhall @@ -0,0 +1,1 @@ +https://raw.githubusercontent.com/dhall-lang/Prelude/c79c2bc3c46f129cc5b6d594ce298a381bcae92c/List/replicate using (./a.dhall sha256:16173e984d35ee3ffd8b6b79167df89480e67d1cd03ea5d0fc93689e4d928e61) sha256:b0e3ec1797b32c80c0bcb7e8254b08c7e9e35e75e6b410c7ac21477ab90167ad diff --git a/tests/parser/urls.dhall b/tests/parser/urls.dhall --- a/tests/parser/urls.dhall +++ b/tests/parser/urls.dhall @@ -2,6 +2,7 @@ , https://john:doe@example.com:8080/foo/bar?qux=0#xyzzy , http://prelude.dhall-lang.org/package.dhall , https://ipfs.io/ipfs/QmQ8w5PLcsNz56dMvRtq54vbuPe9cNnCCUXAQp6xLc6Ccx/Prelude +, https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True , https://127.0.0.1/index.dhall , https://[::]/index.dhall , https://[2001:0db8:85a3:0000:0000:8a2e:0370:7334]/tutorial.dhall