From 5406b2d0526e1d0723602d168e18c4a5fda98b36 Mon Sep 17 00:00:00 2001 From: Sergei Winitzki Date: Sat, 21 Jun 2025 17:15:10 +0200 Subject: [PATCH 1/6] wip introduce ChooseCharSet and refactor code --- .../src/Dhall/LSP/Backend/Formatting.hs | 9 +++-- dhall-lsp-server/src/Dhall/LSP/State.hs | 2 +- dhall-openapi/openapi-to-dhall/Main.hs | 4 ++- dhall/src/.DS_Store | Bin 0 -> 8196 bytes dhall/src/Dhall/.DS_Store | Bin 0 -> 6148 bytes dhall/src/Dhall/DirectoryTree.hs | 7 ++-- dhall/src/Dhall/Format.hs | 8 ++--- dhall/src/Dhall/Freeze.hs | 13 ++++---- dhall/src/Dhall/Import/Headers.hs | 2 +- dhall/src/Dhall/Main.hs | 25 +++++++++----- dhall/src/Dhall/Marshal/Decode.hs | 2 +- dhall/src/Dhall/Marshal/Encode.hs | 9 ++--- dhall/src/Dhall/Parser/Combinators.hs | 2 +- dhall/src/Dhall/Parser/Expression.hs | 17 +++++----- dhall/src/Dhall/Pretty/Internal.hs | 31 ++++++++++++++---- dhall/src/Dhall/Pretty/Internal.hs-boot | 11 +++++++ dhall/src/Dhall/Schemas.hs | 8 ++--- dhall/src/Dhall/Syntax/Expr.hs | 14 ++++---- dhall/src/Dhall/Syntax/Operations.hs | 13 ++++---- 19 files changed, 110 insertions(+), 67 deletions(-) create mode 100644 dhall/src/.DS_Store create mode 100644 dhall/src/Dhall/.DS_Store diff --git a/dhall-lsp-server/src/Dhall/LSP/Backend/Formatting.hs b/dhall-lsp-server/src/Dhall/LSP/Backend/Formatting.hs index f858a2e2b..38e3e8808 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Backend/Formatting.hs +++ b/dhall-lsp-server/src/Dhall/LSP/Backend/Formatting.hs @@ -1,6 +1,5 @@ module Dhall.LSP.Backend.Formatting (formatExpr, formatExprWithHeader) where -import Data.Maybe (fromMaybe) import Data.Text (Text) import Dhall.Core (Expr) import Dhall.Parser (Header (..)) @@ -12,21 +11,21 @@ import qualified Prettyprinter as Pretty import qualified Prettyprinter.Render.Text as Pretty -- | Pretty-print the given Dhall expression. -formatExpr :: Pretty.Pretty b => Maybe CharacterSet -> Expr Src b -> Text +formatExpr :: Pretty.Pretty b => ChooseCharacterSet -> Expr Src b -> Text formatExpr chosenCharacterSet expr = Pretty.renderStrict . Dhall.Pretty.layout $ Dhall.Pretty.prettyCharacterSet charSet expr where - charSet = fromMaybe (Dhall.Pretty.detectCharacterSet expr) chosenCharacterSet + charSet = chooseCharsetOrUseDefault (Dhall.Pretty.detectCharacterSet expr) chosenCharacterSet -- | Pretty-print the given Dhall expression, prepending the given a "header" -- (usually consisting of comments and whitespace). -formatExprWithHeader :: Pretty.Pretty b => Maybe CharacterSet -> Expr Src b -> Header -> Text +formatExprWithHeader :: Pretty.Pretty b => ChooseCharacterSet -> Expr Src b -> Header -> Text formatExprWithHeader chosenCharacterSet expr (Header header) = Pretty.renderStrict (Dhall.Pretty.layout doc) where - charSet = fromMaybe (Dhall.Pretty.detectCharacterSet expr) chosenCharacterSet + charSet = chooseCharsetOrUseDefault (Dhall.Pretty.detectCharacterSet expr) chosenCharacterSet doc = Pretty.pretty header diff --git a/dhall-lsp-server/src/Dhall/LSP/State.hs b/dhall-lsp-server/src/Dhall/LSP/State.hs index ff02f2772..23d2dd1af 100644 --- a/dhall-lsp-server/src/Dhall/LSP/State.hs +++ b/dhall-lsp-server/src/Dhall/LSP/State.hs @@ -39,7 +39,7 @@ data Severity = Error -- ^ Log message, not displayed by default. data ServerConfig = ServerConfig - { chosenCharacterSet :: Maybe CharacterSet + { chosenCharacterSet :: ChooseCharacterSet } deriving Show instance Default ServerConfig where diff --git a/dhall-openapi/openapi-to-dhall/Main.hs b/dhall-openapi/openapi-to-dhall/Main.hs index 38c7e197d..aeb786657 100644 --- a/dhall-openapi/openapi-to-dhall/Main.hs +++ b/dhall-openapi/openapi-to-dhall/Main.hs @@ -36,6 +36,8 @@ import Dhall.Kubernetes.Types ) import System.FilePath (()) +import Dhall.Pretty.Internal (ChooseCharacterSet(..)) + import qualified Data.List as List import qualified Data.Map.Strict as Data.Map import qualified Data.Ord as Ord @@ -74,7 +76,7 @@ writeDhall path expr = do putStrLn $ "Writing file '" <> path <> "'" Text.writeFile path $ pretty expr <> "\n" - let chosenCharacterSet = Nothing -- Infer from input + let chosenCharacterSet = AutoInferCharSet let censor = Dhall.Util.NoCensor diff --git a/dhall/src/.DS_Store b/dhall/src/.DS_Store new file mode 100644 index 0000000000000000000000000000000000000000..7c3ad3345deb4389d4cdbb04a055f4f7edafda13 GIT binary patch literal 8196 zcmeHMTWl0n7(U;$rL!>7DYR0s1Dm!)Kw1k(TDc_KcB|ZrEVbK$w7WZFJ2;&wJG0v& zNE#Dg6udlXyhWb8MPk&d@x??1!AHdhjPU`ZQC~2@7nKM9bIue>3*p5W33HNj{{3&~ z%=ypv&&fZ_7(;u(T*X)oV@##asXm8>Yc#IseMVD4NjXuFKVyzFxGI(NhDT=DMuI2; zQ3Rq0L=lK05Jlks5dpfhc~h@*?@MhoMiGc2a7#vjzaQe%IZcFgTvGAsph1)XL`z95 z8vUj^K={N%nh5E*q{5Zvl+^=5SA-=7q&w;3+?;44q~nrGcLwRs5Uz}{LV;MF{Nlo# zAt7lrMiGc2Ff#(Yb}wT|HpDW_nO48gud=6U{bEPf@v@ASq_QK9?FY@x-$5xUEt^%Y z#%9maZZmq)y?uMMetlliwnn=~0^4)_2d%tMv|q3AhrH3vInUjhx46D1=Q)L8*YDRW za~UUBa590_<~S+)QHx|1elG7h&Q8y_`82)hz#0p&Cp@FahJB+r_HN+MjAG0&D!oqY}btG zzLc!d)*9VTCTlq{-IVLJYU_-iqKtn`-ztS0wQ3_xUulMEi+)VX+KdikA76G`#t*ti zESEphX{o!9bbbC%CU13(x>i1XqAes9M@n+;)M?s*CzKS89d(A$%cpBIO|geXH47_@ zl+mr~U#tDPZo5T0po5{KB2w_x`b6-oIGy^$3VBNPlZPb&U7u){e2gv%gRLgWZes&1 z&knI;>;-n5eZWq#Q|w#z1N)U-WPbvfg>uZs98_Tu8n6;;(Slaoi*|HjCw3u)y%>Ux z{qQk{gE)l4cmhx2DICMocpk6dRlJ7dcnk00eN5m(e2UXJgRk%n&f`b?gr9K%f8lRj zQp%JCN{zBmsZ&-ejY^Z!qO>aOl=aFErAtXG8D+oXDPwX2N_c~@hbA`|$`2Bqnu>mL zL?)YZ;@Zhpd;g}*TejXj$#!n8NUy5u+ZV)_uDJW2){SkKVJLAs3Dv0yAW(l*t_ai% zR7^wcS&@g@;w6)bcO?~NYIak)SYs;BTD?59u5VB&UG%b$UACOqt@k z{yN^kn|K@V5Y|7!$M^)F;|rX`mm%uEC(Qqbi_>tt{c0TJkE?M!>?M;D$4otP;mpLU z&rY>Xw=i#DF)}pevvT#je8DN1QcUGt$8!fsI+6vp2mK_W4dxN+Hd0x=$-lDcrAF~I}yA55qvfJR;Q2wuQbcmQ^~_Y%g1 zJ2xgSd~aqb^QhIhF~qz_X1;dj&G6%+?Jxj@!s=dzstCLpD?mH!e~yFmBTqs zh+`Fwpn*P)p^rLXBx-z<&Tv^apAwdZd0d+8EXJd5iKhT3mZt+FPILUR*zdBuza%Vd z4wob=hjY|t9CS5J@O8~OHl~&%>32CU-x!CJGyi_FayW-)IBK{uog+m9t~f`jra7E` zm*aJ>H@lV#z;fmsSvia&r>|FHS%$zho1$1UDz!Ku4u}JZ1N40Gu#oyzW25@fftB6@ zpyshz2OgK{0M)bVTaArk4~8;BQO!_gw;0L{$9B)=`Br12W;iIj`B3(qmEEBz{q8uw zr_(|CMx_=9!~yQWia9OQ`hSqU|L23`OdJpg{*?nNAJl>>ek8lLram04wH}r_77EIX ojp`v-+2vRt&{9nQE9k&Jj}B0MtFcjR!H^#U+6Jk_fj@QN6BXat5&!@I literal 0 HcmV?d00001 diff --git a/dhall/src/Dhall/DirectoryTree.hs b/dhall/src/Dhall/DirectoryTree.hs index aeaa20698..1c112c50c 100644 --- a/dhall/src/Dhall/DirectoryTree.hs +++ b/dhall/src/Dhall/DirectoryTree.hs @@ -50,6 +50,7 @@ import qualified Dhall.Core as Core import qualified Dhall.Map as Map import qualified Dhall.Marshal.Decode as Decode import qualified Dhall.Pretty +import Dhall.Pretty.Internal (ChooseCharacterSet(..)) import qualified Dhall.TypeCheck as TypeCheck import qualified Dhall.Util as Util import qualified Prettyprinter as Pretty @@ -252,8 +253,8 @@ decodeDirectoryTree expr = Exception.throwIO $ FilesystemError $ Core.denote exp -- | The type of a fixpoint directory tree expression. directoryTreeType :: Expector (Expr Src Void) -directoryTreeType = Pi Nothing "tree" (Const Type) - <$> (Pi Nothing "make" <$> makeType <*> pure (App List (Var (V "tree" 0)))) +directoryTreeType = Pi AutoInferCharSet "tree" (Const Type) + <$> (Pi AutoInferCharSet "make" <$> makeType <*> pure (App List (Var (V "tree" 0)))) -- | The type of make part of a fixpoint directory tree expression. makeType :: Expector (Expr Src Void) @@ -265,7 +266,7 @@ makeType = Record . Map.fromList <$> sequenceA where makeConstructor :: Text -> Decoder b -> Expector (Text, RecordField Src Void) makeConstructor name dec = (name,) . Core.makeRecordField - <$> (Pi Nothing "_" <$> expected dec <*> pure (Var (V "tree" 0))) + <$> (Pi AutoInferCharSet "_" <$> expected dec <*> pure (Var (V "tree" 0))) -- | Resolve a `User` to a numerical id. getUser :: User -> IO UserID diff --git a/dhall/src/Dhall/Format.hs b/dhall/src/Dhall/Format.hs index 7dde23213..5cdcd7195 100644 --- a/dhall/src/Dhall/Format.hs +++ b/dhall/src/Dhall/Format.hs @@ -11,8 +11,7 @@ module Dhall.Format import Data.Foldable (for_) import Data.List.NonEmpty (NonEmpty) -import Data.Maybe (fromMaybe) -import Dhall.Pretty (CharacterSet, annToAnsiStyle, detectCharacterSet) +import Dhall.Pretty (annToAnsiStyle, detectCharacterSet) import Dhall.Util ( Censor , CheckFailed (..) @@ -34,10 +33,11 @@ import qualified System.AtomicWrite.Writer.LazyText as AtomicWrite.LazyText import qualified System.Console.ANSI import qualified System.FilePath import qualified System.IO +import Dhall.Pretty.Internal (ChooseCharacterSet(..), chooseCharsetOrUseDefault) -- | Arguments to the `format` subcommand data Format = Format - { chosenCharacterSet :: Maybe CharacterSet + { chosenCharacterSet :: ChooseCharacterSet , censor :: Censor , transitivity :: Transitivity , inputs :: NonEmpty Input @@ -59,7 +59,7 @@ format (Format { inputs = inputs0, transitivity = transitivity0, ..}) = let status = Dhall.Import.emptyStatus directory let layoutHeaderAndExpr (Header header, expr) = - let characterSet = fromMaybe (detectCharacterSet expr) chosenCharacterSet + let characterSet = chooseCharsetOrUseDefault (detectCharacterSet expr) chosenCharacterSet in Dhall.Pretty.layout ( Pretty.pretty header diff --git a/dhall/src/Dhall/Freeze.hs b/dhall/src/Dhall/Freeze.hs index f6bdb22a6..564148f95 100644 --- a/dhall/src/Dhall/Freeze.hs +++ b/dhall/src/Dhall/Freeze.hs @@ -31,9 +31,10 @@ module Dhall.Freeze import Data.Foldable (for_) import Data.List.NonEmpty (NonEmpty) -import Data.Maybe (fromMaybe) import Dhall (EvaluateSettings) -import Dhall.Pretty (CharacterSet, detectCharacterSet) +import Dhall.Pretty (detectCharacterSet) +import Dhall.Pretty.Internal (ChooseCharacterSet(..), chooseCharsetOrUseDefault) + import Dhall.Syntax ( Expr (..) , Import (..) @@ -128,7 +129,7 @@ freeze -> NonEmpty Input -> Scope -> Intent - -> Maybe CharacterSet + -> ChooseCharacterSet -> Censor -> IO () freeze = freezeWithSettings Dhall.defaultEvaluateSettings @@ -141,7 +142,7 @@ freezeWithManager -> NonEmpty Input -> Scope -> Intent - -> Maybe CharacterSet + -> ChooseCharacterSet -> Censor -> IO () freezeWithManager newManager = freezeWithSettings (set Dhall.newManager newManager Dhall.defaultEvaluateSettings) @@ -242,7 +243,7 @@ freezeWithSettings -> NonEmpty Input -> Scope -> Intent - -> Maybe CharacterSet + -> ChooseCharacterSet -> Censor -> IO () freezeWithSettings settings outputMode transitivity0 inputs scope intent chosenCharacterSet censor = @@ -270,7 +271,7 @@ freezeWithSettings settings outputMode transitivity0 inputs scope intent chosenC (Header header, parsedExpression) <- Util.getExpressionAndHeaderFromStdinText censor inputName originalText - let characterSet = fromMaybe (detectCharacterSet parsedExpression) chosenCharacterSet + let characterSet = chooseCharsetOrUseDefault (detectCharacterSet parsedExpression) chosenCharacterSet case transitivity of Transitive -> diff --git a/dhall/src/Dhall/Import/Headers.hs b/dhall/src/Dhall/Import/Headers.hs index 3d7c5beef..547127b06 100644 --- a/dhall/src/Dhall/Import/Headers.hs +++ b/dhall/src/Dhall/Import/Headers.hs @@ -10,7 +10,7 @@ module Dhall.Import.Headers , toOriginHeaders ) where -import Control.Applicative (Alternative (..), liftA2) +import Control.Applicative (Alternative (..)) import Control.Exception (SomeException) import Control.Monad.Catch (handle, throwM) import Data.Text (Text) diff --git a/dhall/src/Dhall/Main.hs b/dhall/src/Dhall/Main.hs index d23427609..d919f109a 100644 --- a/dhall/src/Dhall/Main.hs +++ b/dhall/src/Dhall/Main.hs @@ -99,6 +99,7 @@ import qualified Dhall.Lint import qualified Dhall.Map import qualified Dhall.Package import qualified Dhall.Pretty +import Dhall.Pretty.Internal (ChooseCharacterSet(..), chooseCharsetOrUseDefault) import qualified Dhall.Repl import qualified Dhall.Schemas import qualified Dhall.Tags @@ -122,7 +123,7 @@ data Options = Options { mode :: Mode , explain :: Bool , plain :: Bool - , chosenCharacterSet :: Maybe CharacterSet + , chosenCharacterSet :: ChooseCharacterSet , censor :: Censor } @@ -221,16 +222,16 @@ parseOptions = parseCharacterSet = Options.Applicative.flag' - (Just Unicode) + (Specify Unicode) ( Options.Applicative.long "unicode" <> Options.Applicative.help "Format code using only Unicode syntax" ) <|> Options.Applicative.flag' - (Just ASCII) + (Specify ASCII) ( Options.Applicative.long "ascii" <> Options.Applicative.help "Format code using only ASCII syntax" ) - <|> pure Nothing + <|> pure AutoInferCharSet subcommand :: Group -> String -> String -> Parser a -> Parser a subcommand group name description parser = @@ -634,7 +635,7 @@ command (Options {..}) = do let getExpressionAndCharacterSet file = do expr <- getExpression file - let characterSet = fromMaybe (detectCharacterSet expr) chosenCharacterSet + let characterSet = chooseCharsetOrUseDefault (detectCharacterSet expr) chosenCharacterSet return (expr, characterSet) @@ -833,7 +834,7 @@ command (Options {..}) = do Repl -> Dhall.Repl.repl - (fromMaybe Unicode chosenCharacterSet) -- Default to Unicode if no characterSet specified + (chooseCharsetOrUseDefault Unicode chosenCharacterSet) -- Default to Unicode if no characterSet specified explain Diff {..} -> do @@ -908,7 +909,7 @@ command (Options {..}) = do (Header header, parsedExpression) <- Dhall.Util.getExpressionAndHeaderFromStdinText censor inputName originalText - let characterSet = fromMaybe (detectCharacterSet parsedExpression) chosenCharacterSet + let characterSet = chooseCharsetOrUseDefault (detectCharacterSet parsedExpression) chosenCharacterSet case transitivity of Transitive -> @@ -994,7 +995,7 @@ command (Options {..}) = do else do let doc = Dhall.Pretty.prettyCharacterSet - (fromMaybe Unicode chosenCharacterSet) -- default to Unicode + (chooseCharsetOrUseDefault Unicode chosenCharacterSet) -- default to Unicode (Dhall.Core.renote expression :: Expr Src Import) renderDoc System.IO.stdout doc @@ -1060,10 +1061,16 @@ command (Options {..}) = do Package {..} -> do let options = appEndo - (maybe mempty (Endo . set Dhall.Package.characterSet) chosenCharacterSet + (maybe mempty (Endo . set Dhall.Package.characterSet) chosenCharacterSetAsMaybe <> packageOptions ) Dhall.Package.defaultOptions writePackage options packageFiles + where + chosenCharacterSetAsMaybe :: Maybe CharacterSet + chosenCharacterSetAsMaybe = case chosenCharacterSet of + AutoInferCharSet -> Nothing + Specify c -> Just c + -- | Entry point for the @dhall@ executable main :: IO () diff --git a/dhall/src/Dhall/Marshal/Decode.hs b/dhall/src/Dhall/Marshal/Decode.hs index 0dccee448..b232b631d 100644 --- a/dhall/src/Dhall/Marshal/Decode.hs +++ b/dhall/src/Dhall/Marshal/Decode.hs @@ -136,7 +136,7 @@ module Dhall.Marshal.Decode ) where -import Control.Applicative (empty, liftA2) +import Control.Applicative (empty) import Control.Exception (Exception) import Control.Monad (guard) import Control.Monad.Trans.State.Strict diff --git a/dhall/src/Dhall/Marshal/Encode.hs b/dhall/src/Dhall/Marshal/Encode.hs index 7fd6f9432..1e1527afe 100644 --- a/dhall/src/Dhall/Marshal/Encode.hs +++ b/dhall/src/Dhall/Marshal/Encode.hs @@ -94,6 +94,7 @@ import qualified Dhall.Core as Core import qualified Dhall.Map import Dhall.Marshal.Internal +import Dhall.Pretty.Internal (ChooseCharacterSet(..)) -- $setup -- >>> :set -XRecordWildCards @@ -530,13 +531,13 @@ instance forall f. (Functor f, ToDhall (f (Result f))) => ToDhall (Fix f) where injectWith inputNormalizer = Encoder {..} where embed fixf = - Lam Nothing (Core.makeFunctionBinding "result" (Const Core.Type)) $ - Lam Nothing (Core.makeFunctionBinding "Make" makeType) $ + Lam AutoInferCharSet (Core.makeFunctionBinding "result" (Const Core.Type)) $ + Lam AutoInferCharSet (Core.makeFunctionBinding "Make" makeType) $ embed' . fixToResult $ fixf - declared = Pi Nothing "result" (Const Core.Type) $ Pi Nothing "_" makeType "result" + declared = Pi AutoInferCharSet "result" (Const Core.Type) $ Pi AutoInferCharSet "_" makeType "result" - makeType = Pi Nothing "_" declared' "result" + makeType = Pi AutoInferCharSet "_" declared' "result" Encoder embed' _ = injectWith @(Dhall.Marshal.Internal.Result f) inputNormalizer Encoder _ declared' = injectWith @(f (Dhall.Marshal.Internal.Result f)) inputNormalizer diff --git a/dhall/src/Dhall/Parser/Combinators.hs b/dhall/src/Dhall/Parser/Combinators.hs index d0a72e826..352718891 100644 --- a/dhall/src/Dhall/Parser/Combinators.hs +++ b/dhall/src/Dhall/Parser/Combinators.hs @@ -23,7 +23,7 @@ module Dhall.Parser.Combinators ) where -import Control.Applicative (Alternative (..), liftA2) +import Control.Applicative (Alternative (..)) import Control.Exception (Exception) import Control.Monad (MonadPlus (..)) import Data.String (IsString (..)) diff --git a/dhall/src/Dhall/Parser/Expression.hs b/dhall/src/Dhall/Parser/Expression.hs index 0f75be90a..be97bb465 100644 --- a/dhall/src/Dhall/Parser/Expression.hs +++ b/dhall/src/Dhall/Parser/Expression.hs @@ -8,7 +8,7 @@ -- | Parsing Dhall expressions. module Dhall.Parser.Expression where -import Control.Applicative (Alternative (..), liftA2, optional) +import Control.Applicative (Alternative (..), optional) import Data.Foldable (foldl') import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) @@ -33,6 +33,7 @@ import qualified Text.Megaparsec import Dhall.Parser.Combinators import Dhall.Parser.Token +import {-# SOURCE #-} Dhall.Pretty.Internal (ChooseCharacterSet(..)) -- | Get the current source offset (in tokens) getOffset :: Text.Megaparsec.MonadParsec e s m => m Int @@ -315,7 +316,7 @@ parsers embedded = Parsers{..} cs' <- _arrow whitespace c <- expression - return (Lam (Just (cs <> cs')) (FunctionBinding (Just src0) a (Just src1) (Just src2) b) c) + return (Lam (Specify (cs <> cs')) (FunctionBinding (Just src0) a (Just src1) (Just src2) b) c) alternative1 = do try (_if *> nonemptyWhitespace) @@ -368,7 +369,7 @@ parsers embedded = Parsers{..} cs' <- _arrow whitespace c <- expression - return (Pi (Just (cs <> cs')) a b c) + return (Pi (Specify (cs <> cs')) a b c) alternative4 = do try (_assert *> whitespace *> _colon) @@ -418,7 +419,7 @@ parsers embedded = Parsers{..} whitespace b <- expression whitespace - return (Pi (Just cs) "_" a b) + return (Pi (Specify cs) "_" a b) let alternative5B1 = do _colon @@ -489,16 +490,16 @@ parsers embedded = Parsers{..} operatorParsers :: [Parser (Expr s a -> Expr s a -> Expr s a)] operatorParsers = - [ Equivalent . Just <$> _equivalent <* whitespace + [ Equivalent . Specify <$> _equivalent <* whitespace , ImportAlt <$ _importAlt <* nonemptyWhitespace , BoolOr <$ _or <* whitespace , NaturalPlus <$ _plus <* nonemptyWhitespace , TextAppend <$ _textAppend <* whitespace , ListAppend <$ _listAppend <* whitespace , BoolAnd <$ _and <* whitespace - , (\cs -> Combine (Just cs) Nothing) <$> _combine <* whitespace - , (\cs -> Prefer (Just cs) PreferFromSource) <$> _prefer <* whitespace - , CombineTypes . Just <$> _combineTypes <* whitespace + , (\cs -> Combine (Specify cs) Nothing) <$> _combine <* whitespace + , (\cs -> Prefer (Specify cs) PreferFromSource) <$> _prefer <* whitespace + , CombineTypes . Specify <$> _combineTypes <* whitespace , NaturalTimes <$ _times <* whitespace -- Make sure that `==` is not actually the prefix of `===` , BoolEQ <$ try (_doubleEqual <* Text.Megaparsec.notFollowedBy (char '=')) <* whitespace diff --git a/dhall/src/Dhall/Pretty/Internal.hs b/dhall/src/Dhall/Pretty/Internal.hs index fdd545d3c..19ddb8b37 100644 --- a/dhall/src/Dhall/Pretty/Internal.hs +++ b/dhall/src/Dhall/Pretty/Internal.hs @@ -20,6 +20,8 @@ module Dhall.Pretty.Internal ( , prettySrcExpr , CharacterSet(..) + , ChooseCharacterSet(..) + , chooseCharsetOrUseDefault , defaultCharacterSet , detectCharacterSet , prettyCharacterSet @@ -161,6 +163,23 @@ instance FromJSON CharacterSet where defaultCharacterSet :: CharacterSet defaultCharacterSet = Unicode +data ChooseCharacterSet = AutoInferCharSet | Specify CharacterSet + deriving (Eq, Ord, Show, Data, Generic, Lift, NFData) + +instance Semigroup ChooseCharacterSet where + AutoInferCharSet <> other = other + other <> AutoInferCharSet = other + Specify x <> Specify y = Specify (x <> y) + +instance Monoid ChooseCharacterSet where + mempty = AutoInferCharSet + +chooseCharsetOrUseDefault :: CharacterSet -> ChooseCharacterSet -> CharacterSet +chooseCharsetOrUseDefault c chooseCS = case chooseCS of + AutoInferCharSet -> c + Specify x -> x + + -- | Detect which character set is used for the syntax of an expression -- If any parts of the expression uses the Unicode syntax, the whole expression -- is deemed to be using the Unicode syntax. @@ -169,12 +188,12 @@ detectCharacterSet = foldMapOf (cosmosOf subExpressions) exprToCharacterSet where exprToCharacterSet = \case Embed _ -> mempty -- Don't go down the embed route, otherwise: <> - Lam (Just Unicode) _ _ -> Unicode - Pi (Just Unicode) _ _ _ -> Unicode - Combine (Just Unicode) _ _ _ -> Unicode - CombineTypes (Just Unicode) _ _ -> Unicode - Prefer (Just Unicode) _ _ _ -> Unicode - Equivalent (Just Unicode) _ _ -> Unicode + Lam (Specify Unicode) _ _ -> Unicode + Pi (Specify Unicode) _ _ _ -> Unicode + Combine (Specify Unicode) _ _ _ -> Unicode + CombineTypes (Specify Unicode) _ _ -> Unicode + Prefer (Specify Unicode) _ _ _ -> Unicode + Equivalent (Specify Unicode) _ _ -> Unicode _ -> mempty -- | Pretty print an expression diff --git a/dhall/src/Dhall/Pretty/Internal.hs-boot b/dhall/src/Dhall/Pretty/Internal.hs-boot index 35309ebbd..e08147e36 100644 --- a/dhall/src/Dhall/Pretty/Internal.hs-boot +++ b/dhall/src/Dhall/Pretty/Internal.hs-boot @@ -24,6 +24,17 @@ instance NFData CharacterSet instance Semigroup CharacterSet instance Monoid CharacterSet +data ChooseCharacterSet = AutoInferCharSet | Specify CharacterSet + +instance Eq ChooseCharacterSet +instance Data ChooseCharacterSet +instance Lift ChooseCharacterSet +instance NFData ChooseCharacterSet +instance Ord ChooseCharacterSet +instance Semigroup ChooseCharacterSet +instance Show ChooseCharacterSet +instance Monoid ChooseCharacterSet + prettyVar :: Var -> Doc Ann prettyConst :: Const -> Doc Ann diff --git a/dhall/src/Dhall/Schemas.hs b/dhall/src/Dhall/Schemas.hs index 328682045..9f7bb1ca2 100644 --- a/dhall/src/Dhall/Schemas.hs +++ b/dhall/src/Dhall/Schemas.hs @@ -16,12 +16,12 @@ module Dhall.Schemas import Control.Applicative (empty) import Control.Exception (Exception) -import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Void (Void) import Dhall.Crypto (SHA256Digest) import Dhall.Map (Map) -import Dhall.Pretty (CharacterSet (..), detectCharacterSet) +import Dhall.Pretty (detectCharacterSet) +import Dhall.Pretty.Internal (ChooseCharacterSet(..), chooseCharsetOrUseDefault) import Dhall.Src (Src) import Dhall.Syntax (Expr (..), Import, Var (..)) import Dhall.Util @@ -57,7 +57,7 @@ import qualified System.IO as IO -- | Arguments to the @rewrite-with-schemas@ subcommand data Schemas = Schemas - { chosenCharacterSet :: Maybe CharacterSet + { chosenCharacterSet :: ChooseCharacterSet , censor :: Censor , input :: Input , outputMode :: OutputMode @@ -73,7 +73,7 @@ schemasCommand Schemas{..} = do (Header header, expression) <- Util.getExpressionAndHeaderFromStdinText censor inputName originalText - let characterSet = fromMaybe (detectCharacterSet expression) chosenCharacterSet + let characterSet = chooseCharsetOrUseDefault (detectCharacterSet expression) chosenCharacterSet schemasRecord <- Core.throws (Parser.exprFromText "(schemas)" schemas) diff --git a/dhall/src/Dhall/Syntax/Expr.hs b/dhall/src/Dhall/Syntax/Expr.hs index 660e1ba05..854508838 100644 --- a/dhall/src/Dhall/Syntax/Expr.hs +++ b/dhall/src/Dhall/Syntax/Expr.hs @@ -13,7 +13,7 @@ import Data.String (IsString (..)) import Data.Text (Text) import Data.Traversable () import Dhall.Map (Map) -import {-# SOURCE #-} Dhall.Pretty.Internal (CharacterSet (..)) +import {-# SOURCE #-} Dhall.Pretty.Internal (ChooseCharacterSet(..)) import Dhall.Syntax.Binding import Dhall.Syntax.Chunks import Dhall.Syntax.Const @@ -51,10 +51,10 @@ data Expr s a -- > Var (V x n) ~ x@n | Var Var -- | > Lam _ (FunctionBinding _ "x" _ _ A) b ~ λ(x : A) -> b - | Lam (Maybe CharacterSet) (FunctionBinding s a) (Expr s a) + | Lam ChooseCharacterSet (FunctionBinding s a) (Expr s a) -- | > Pi _ "_" A B ~ A -> B -- > Pi _ x A B ~ ∀(x : A) -> B - | Pi (Maybe CharacterSet) Text (Expr s a) (Expr s a) + | Pi ChooseCharacterSet Text (Expr s a) (Expr s a) -- | > App f a ~ f a | App (Expr s a) (Expr s a) -- | > Let (Binding _ x _ Nothing _ r) e ~ let x = r in e @@ -227,11 +227,11 @@ data Expr s a -- > _ -- > (Combine (Just k) x y) -- > )] - | Combine (Maybe CharacterSet) (Maybe Text) (Expr s a) (Expr s a) + | Combine ChooseCharacterSet (Maybe Text) (Expr s a) (Expr s a) -- | > CombineTypes _ x y ~ x ⩓ y - | CombineTypes (Maybe CharacterSet) (Expr s a) (Expr s a) + | CombineTypes ChooseCharacterSet (Expr s a) (Expr s a) -- | > Prefer _ _ x y ~ x ⫽ y - | Prefer (Maybe CharacterSet) PreferAnnotation (Expr s a) (Expr s a) + | Prefer ChooseCharacterSet PreferAnnotation (Expr s a) (Expr s a) -- | > RecordCompletion x y ~ x::y | RecordCompletion (Expr s a) (Expr s a) -- | > Merge x y (Just t ) ~ merge x y : t @@ -250,7 +250,7 @@ data Expr s a -- | > Assert e ~ assert : e | Assert (Expr s a) -- | > Equivalent _ x y ~ x ≡ y - | Equivalent (Maybe CharacterSet) (Expr s a) (Expr s a) + | Equivalent ChooseCharacterSet (Expr s a) (Expr s a) -- | > With x y e ~ x with y = e | With (Expr s a) (NonEmpty WithComponent) (Expr s a) -- | > Note s x ~ e diff --git a/dhall/src/Dhall/Syntax/Operations.hs b/dhall/src/Dhall/Syntax/Operations.hs index d59a1eb41..57b06f978 100644 --- a/dhall/src/Dhall/Syntax/Operations.hs +++ b/dhall/src/Dhall/Syntax/Operations.hs @@ -35,6 +35,7 @@ import Dhall.Syntax.RecordField (RecordField (..), recordFieldExprs) import Dhall.Syntax.Types import Dhall.Syntax.Var import Unsafe.Coerce (unsafeCoerce) +import {-# SOURCE #-} Dhall.Pretty.Internal (ChooseCharacterSet(..)) import qualified Data.HashSet import qualified Data.Text @@ -171,15 +172,15 @@ denote = \case Note _ b -> denote b Let a b -> Let (denoteBinding a) (denote b) Embed a -> Embed a - Combine _ _ b c -> Combine Nothing Nothing (denote b) (denote c) - CombineTypes _ b c -> CombineTypes Nothing (denote b) (denote c) - Prefer _ a b c -> Lens.over unsafeSubExpressions denote $ Prefer Nothing a b c + Combine _ _ b c -> Combine AutoInferCharSet Nothing (denote b) (denote c) + CombineTypes _ b c -> CombineTypes AutoInferCharSet (denote b) (denote c) + Prefer _ a b c -> Lens.over unsafeSubExpressions denote $ Prefer AutoInferCharSet a b c Record a -> Record $ denoteRecordField <$> a RecordLit a -> RecordLit $ denoteRecordField <$> a - Lam _ a b -> Lam Nothing (denoteFunctionBinding a) (denote b) - Pi _ t a b -> Pi Nothing t (denote a) (denote b) + Lam _ a b -> Lam AutoInferCharSet (denoteFunctionBinding a) (denote b) + Pi _ t a b -> Pi AutoInferCharSet t (denote a) (denote b) Field a (FieldSelection _ b _) -> Field (denote a) (FieldSelection Nothing b Nothing) - Equivalent _ a b -> Equivalent Nothing (denote a) (denote b) + Equivalent _ a b -> Equivalent AutoInferCharSet (denote a) (denote b) expression -> Lens.over unsafeSubExpressions denote expression where denoteRecordField (RecordField _ e _ _) = RecordField Nothing (denote e) Nothing Nothing From 6225c705f59397f1f74c822131ce649476aac7cf Mon Sep 17 00:00:00 2001 From: Sergei Winitzki Date: Sat, 21 Jun 2025 17:15:35 +0200 Subject: [PATCH 2/6] remove extraneous files --- dhall/src/.DS_Store | Bin 8196 -> 0 bytes dhall/src/Dhall/.DS_Store | Bin 6148 -> 0 bytes 2 files changed, 0 insertions(+), 0 deletions(-) delete mode 100644 dhall/src/.DS_Store delete mode 100644 dhall/src/Dhall/.DS_Store diff --git a/dhall/src/.DS_Store b/dhall/src/.DS_Store deleted file mode 100644 index 7c3ad3345deb4389d4cdbb04a055f4f7edafda13..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 8196 zcmeHMTWl0n7(U;$rL!>7DYR0s1Dm!)Kw1k(TDc_KcB|ZrEVbK$w7WZFJ2;&wJG0v& zNE#Dg6udlXyhWb8MPk&d@x??1!AHdhjPU`ZQC~2@7nKM9bIue>3*p5W33HNj{{3&~ z%=ypv&&fZ_7(;u(T*X)oV@##asXm8>Yc#IseMVD4NjXuFKVyzFxGI(NhDT=DMuI2; zQ3Rq0L=lK05Jlks5dpfhc~h@*?@MhoMiGc2a7#vjzaQe%IZcFgTvGAsph1)XL`z95 z8vUj^K={N%nh5E*q{5Zvl+^=5SA-=7q&w;3+?;44q~nrGcLwRs5Uz}{LV;MF{Nlo# zAt7lrMiGc2Ff#(Yb}wT|HpDW_nO48gud=6U{bEPf@v@ASq_QK9?FY@x-$5xUEt^%Y z#%9maZZmq)y?uMMetlliwnn=~0^4)_2d%tMv|q3AhrH3vInUjhx46D1=Q)L8*YDRW za~UUBa590_<~S+)QHx|1elG7h&Q8y_`82)hz#0p&Cp@FahJB+r_HN+MjAG0&D!oqY}btG zzLc!d)*9VTCTlq{-IVLJYU_-iqKtn`-ztS0wQ3_xUulMEi+)VX+KdikA76G`#t*ti zESEphX{o!9bbbC%CU13(x>i1XqAes9M@n+;)M?s*CzKS89d(A$%cpBIO|geXH47_@ zl+mr~U#tDPZo5T0po5{KB2w_x`b6-oIGy^$3VBNPlZPb&U7u){e2gv%gRLgWZes&1 z&knI;>;-n5eZWq#Q|w#z1N)U-WPbvfg>uZs98_Tu8n6;;(Slaoi*|HjCw3u)y%>Ux z{qQk{gE)l4cmhx2DICMocpk6dRlJ7dcnk00eN5m(e2UXJgRk%n&f`b?gr9K%f8lRj zQp%JCN{zBmsZ&-ejY^Z!qO>aOl=aFErAtXG8D+oXDPwX2N_c~@hbA`|$`2Bqnu>mL zL?)YZ;@Zhpd;g}*TejXj$#!n8NUy5u+ZV)_uDJW2){SkKVJLAs3Dv0yAW(l*t_ai% zR7^wcS&@g@;w6)bcO?~NYIak)SYs;BTD?59u5VB&UG%b$UACOqt@k z{yN^kn|K@V5Y|7!$M^)F;|rX`mm%uEC(Qqbi_>tt{c0TJkE?M!>?M;D$4otP;mpLU z&rY>Xw=i#DF)}pevvT#je8DN1QcUGt$8!fsI+6vp2mK_W4dxN+Hd0x=$-lDcrAF~I}yA55qvfJR;Q2wuQbcmQ^~_Y%g1 zJ2xgSd~aqb^QhIhF~qz_X1;dj&G6%+?Jxj@!s=dzstCLpD?mH!e~yFmBTqs zh+`Fwpn*P)p^rLXBx-z<&Tv^apAwdZd0d+8EXJd5iKhT3mZt+FPILUR*zdBuza%Vd z4wob=hjY|t9CS5J@O8~OHl~&%>32CU-x!CJGyi_FayW-)IBK{uog+m9t~f`jra7E` zm*aJ>H@lV#z;fmsSvia&r>|FHS%$zho1$1UDz!Ku4u}JZ1N40Gu#oyzW25@fftB6@ zpyshz2OgK{0M)bVTaArk4~8;BQO!_gw;0L{$9B)=`Br12W;iIj`B3(qmEEBz{q8uw zr_(|CMx_=9!~yQWia9OQ`hSqU|L23`OdJpg{*?nNAJl>>ek8lLram04wH}r_77EIX ojp`v-+2vRt&{9nQE9k&Jj}B0MtFcjR!H^#U+6Jk_fj@QN6BXat5&!@I From a75cef69c60519ec0def5b39bb5778419dd59b47 Mon Sep 17 00:00:00 2001 From: Sergei Winitzki Date: Sat, 21 Jun 2025 18:46:59 +0200 Subject: [PATCH 3/6] code compiles after changes --- dhall-lsp-server/src/Dhall/LSP/Backend/Formatting.hs | 2 +- dhall-lsp-server/src/Dhall/LSP/Backend/Parsing.hs | 5 +++-- dhall-lsp-server/src/Dhall/LSP/State.hs | 6 +++--- dhall-openapi/openapi-to-dhall/Main.hs | 2 +- dhall/src/Dhall/Pretty.hs | 3 +++ dhall/src/Dhall/Pretty/Internal.hs | 8 +++++++- 6 files changed, 18 insertions(+), 8 deletions(-) diff --git a/dhall-lsp-server/src/Dhall/LSP/Backend/Formatting.hs b/dhall-lsp-server/src/Dhall/LSP/Backend/Formatting.hs index 38e3e8808..b0e55c1e7 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Backend/Formatting.hs +++ b/dhall-lsp-server/src/Dhall/LSP/Backend/Formatting.hs @@ -3,7 +3,7 @@ module Dhall.LSP.Backend.Formatting (formatExpr, formatExprWithHeader) where import Data.Text (Text) import Dhall.Core (Expr) import Dhall.Parser (Header (..)) -import Dhall.Pretty (CharacterSet (..)) +import Dhall.Pretty (ChooseCharacterSet (..), chooseCharsetOrUseDefault) import Dhall.Src (Src) import qualified Dhall.Pretty diff --git a/dhall-lsp-server/src/Dhall/LSP/Backend/Parsing.hs b/dhall-lsp-server/src/Dhall/LSP/Backend/Parsing.hs index 7e32b9846..446a0d5c4 100644 --- a/dhall-lsp-server/src/Dhall/LSP/Backend/Parsing.hs +++ b/dhall-lsp-server/src/Dhall/LSP/Backend/Parsing.hs @@ -24,6 +24,7 @@ import Dhall.Core import Dhall.Parser import Dhall.Parser.Expression (importHash_, importType_, localOnly) import Dhall.Parser.Token hiding (text) +import Dhall.Pretty ( ChooseCharacterSet(Specify) ) import Text.Megaparsec ( SourcePos (..) , anySingle @@ -295,7 +296,7 @@ binderExprFromText txt = <|> (do cs' <- skipManyTill anySingle _arrow; return (cs', holeExpr)) whitespace inner <- parseBinderExpr - return (Pi (Just (cs <> cs')) name typ inner) + return (Pi (Specify (cs <> cs')) name typ inner) lambdaBinder = do cs <- _lambda @@ -312,4 +313,4 @@ binderExprFromText txt = <|> (do cs' <- skipManyTill anySingle _arrow; return (cs', holeExpr)) whitespace inner <- parseBinderExpr - return (Lam (Just (cs <> cs')) (makeFunctionBinding name typ) inner) + return (Lam (Specify (cs <> cs')) (makeFunctionBinding name typ) inner) diff --git a/dhall-lsp-server/src/Dhall/LSP/State.hs b/dhall-lsp-server/src/Dhall/LSP/State.hs index 23d2dd1af..f773cf16c 100644 --- a/dhall-lsp-server/src/Dhall/LSP/State.hs +++ b/dhall-lsp-server/src/Dhall/LSP/State.hs @@ -18,7 +18,7 @@ import Data.Dynamic (Dynamic) import Data.Map.Strict (Map, empty) import Data.Text (Text) import Dhall.LSP.Backend.Dhall (Cache, DhallError, emptyCache) -import Dhall.Pretty (CharacterSet) +import Dhall.Pretty (ChooseCharacterSet(..)) import Language.LSP.Server (LspT) import qualified Language.LSP.Protocol.Types as J @@ -43,7 +43,7 @@ data ServerConfig = ServerConfig } deriving Show instance Default ServerConfig where - def = ServerConfig { chosenCharacterSet = Nothing } + def = ServerConfig { chosenCharacterSet = AutoInferCharSet } -- We need to derive the FromJSON instance manually in order to provide defaults -- for absent fields. @@ -51,7 +51,7 @@ instance FromJSON ServerConfig where parseJSON = withObject "settings" $ \v -> do s <- v .: "vscode-dhall-lsp-server" flip (withObject "vscode-dhall-lsp-server") s $ \o -> ServerConfig - <$> o .:? "character-set" .!= Nothing + <$> o .:? "character-set" .!= AutoInferCharSet data ServerState = ServerState { _importCache :: Cache -- ^ The dhall import cache diff --git a/dhall-openapi/openapi-to-dhall/Main.hs b/dhall-openapi/openapi-to-dhall/Main.hs index aeb786657..76e7ce598 100644 --- a/dhall-openapi/openapi-to-dhall/Main.hs +++ b/dhall-openapi/openapi-to-dhall/Main.hs @@ -36,7 +36,7 @@ import Dhall.Kubernetes.Types ) import System.FilePath (()) -import Dhall.Pretty.Internal (ChooseCharacterSet(..)) +import Dhall.Pretty (ChooseCharacterSet(..)) import qualified Data.List as List import qualified Data.Map.Strict as Data.Map diff --git a/dhall/src/Dhall/Pretty.hs b/dhall/src/Dhall/Pretty.hs index 2894c7590..2abac7ffe 100644 --- a/dhall/src/Dhall/Pretty.hs +++ b/dhall/src/Dhall/Pretty.hs @@ -12,6 +12,9 @@ module Dhall.Pretty , detectCharacterSet , prettyCharacterSet + , ChooseCharacterSet(..) + , chooseCharsetOrUseDefault + , Dhall.Pretty.Internal.layout , Dhall.Pretty.Internal.layoutOpts diff --git a/dhall/src/Dhall/Pretty/Internal.hs b/dhall/src/Dhall/Pretty/Internal.hs index 19ddb8b37..d2cb8ac64 100644 --- a/dhall/src/Dhall/Pretty/Internal.hs +++ b/dhall/src/Dhall/Pretty/Internal.hs @@ -115,6 +115,7 @@ import qualified Prettyprinter.Render.String as Pretty import qualified Prettyprinter.Render.Terminal as Terminal import qualified Prettyprinter.Render.Text as Pretty import qualified Text.Printf as Printf +import Data.Aeson (Value(Null)) {-| Annotation type used to tag elements in a pretty-printed document for syntax highlighting purposes @@ -173,7 +174,12 @@ instance Semigroup ChooseCharacterSet where instance Monoid ChooseCharacterSet where mempty = AutoInferCharSet - + +instance FromJSON ChooseCharacterSet where + parseJSON Null = pure mempty + parseJSON v@(String _) = fmap Specify (parseJSON v) + parseJSON v = typeMismatch "String" v + chooseCharsetOrUseDefault :: CharacterSet -> ChooseCharacterSet -> CharacterSet chooseCharsetOrUseDefault c chooseCS = case chooseCS of AutoInferCharSet -> c From 648e842314c963c1685f247e59f3266d4a902faf Mon Sep 17 00:00:00 2001 From: Sergei Winitzki Date: Sat, 21 Jun 2025 19:40:08 +0200 Subject: [PATCH 4/6] restore import of liftA2 for compatibility with older GHC --- dhall/src/Dhall/Import/Headers.hs | 2 +- dhall/src/Dhall/Marshal/Decode.hs | 2 +- dhall/src/Dhall/Parser/Combinators.hs | 2 +- dhall/src/Dhall/Parser/Expression.hs | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/dhall/src/Dhall/Import/Headers.hs b/dhall/src/Dhall/Import/Headers.hs index 547127b06..3d7c5beef 100644 --- a/dhall/src/Dhall/Import/Headers.hs +++ b/dhall/src/Dhall/Import/Headers.hs @@ -10,7 +10,7 @@ module Dhall.Import.Headers , toOriginHeaders ) where -import Control.Applicative (Alternative (..)) +import Control.Applicative (Alternative (..), liftA2) import Control.Exception (SomeException) import Control.Monad.Catch (handle, throwM) import Data.Text (Text) diff --git a/dhall/src/Dhall/Marshal/Decode.hs b/dhall/src/Dhall/Marshal/Decode.hs index b232b631d..0dccee448 100644 --- a/dhall/src/Dhall/Marshal/Decode.hs +++ b/dhall/src/Dhall/Marshal/Decode.hs @@ -136,7 +136,7 @@ module Dhall.Marshal.Decode ) where -import Control.Applicative (empty) +import Control.Applicative (empty, liftA2) import Control.Exception (Exception) import Control.Monad (guard) import Control.Monad.Trans.State.Strict diff --git a/dhall/src/Dhall/Parser/Combinators.hs b/dhall/src/Dhall/Parser/Combinators.hs index 352718891..d0a72e826 100644 --- a/dhall/src/Dhall/Parser/Combinators.hs +++ b/dhall/src/Dhall/Parser/Combinators.hs @@ -23,7 +23,7 @@ module Dhall.Parser.Combinators ) where -import Control.Applicative (Alternative (..)) +import Control.Applicative (Alternative (..), liftA2) import Control.Exception (Exception) import Control.Monad (MonadPlus (..)) import Data.String (IsString (..)) diff --git a/dhall/src/Dhall/Parser/Expression.hs b/dhall/src/Dhall/Parser/Expression.hs index be97bb465..b2d93b9b0 100644 --- a/dhall/src/Dhall/Parser/Expression.hs +++ b/dhall/src/Dhall/Parser/Expression.hs @@ -8,7 +8,7 @@ -- | Parsing Dhall expressions. module Dhall.Parser.Expression where -import Control.Applicative (Alternative (..), optional) +import Control.Applicative (Alternative (..), liftA2, optional) import Data.Foldable (foldl') import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) From cecf09139452abaa3eb5e668c43b68a57b8fdda8 Mon Sep 17 00:00:00 2001 From: Sergei Winitzki Date: Sat, 21 Jun 2025 20:32:55 +0200 Subject: [PATCH 5/6] Fixing imports and adding Arbitrary instance for tests --- dhall/src/Dhall/DirectoryTree.hs | 2 +- dhall/src/Dhall/Format.hs | 3 +-- dhall/src/Dhall/Marshal/Encode.hs | 2 +- dhall/src/Dhall/Pretty/Internal.hs | 2 +- dhall/src/Dhall/Schemas.hs | 3 +-- dhall/tests/Dhall/Test/QuickCheck.hs | 8 +++++++- 6 files changed, 12 insertions(+), 8 deletions(-) diff --git a/dhall/src/Dhall/DirectoryTree.hs b/dhall/src/Dhall/DirectoryTree.hs index 1c112c50c..766bd6413 100644 --- a/dhall/src/Dhall/DirectoryTree.hs +++ b/dhall/src/Dhall/DirectoryTree.hs @@ -30,6 +30,7 @@ import Data.Text (Text) import Data.Void (Void) import Dhall.DirectoryTree.Types import Dhall.Marshal.Decode (Decoder (..), Expector) +import Dhall.Pretty (ChooseCharacterSet(..)) import Dhall.Src (Src) import Dhall.Syntax ( Chunks (..) @@ -50,7 +51,6 @@ import qualified Dhall.Core as Core import qualified Dhall.Map as Map import qualified Dhall.Marshal.Decode as Decode import qualified Dhall.Pretty -import Dhall.Pretty.Internal (ChooseCharacterSet(..)) import qualified Dhall.TypeCheck as TypeCheck import qualified Dhall.Util as Util import qualified Prettyprinter as Pretty diff --git a/dhall/src/Dhall/Format.hs b/dhall/src/Dhall/Format.hs index 5cdcd7195..e9c41e7cf 100644 --- a/dhall/src/Dhall/Format.hs +++ b/dhall/src/Dhall/Format.hs @@ -11,7 +11,7 @@ module Dhall.Format import Data.Foldable (for_) import Data.List.NonEmpty (NonEmpty) -import Dhall.Pretty (annToAnsiStyle, detectCharacterSet) +import Dhall.Pretty (annToAnsiStyle, detectCharacterSet, ChooseCharacterSet(..), chooseCharsetOrUseDefault) import Dhall.Util ( Censor , CheckFailed (..) @@ -33,7 +33,6 @@ import qualified System.AtomicWrite.Writer.LazyText as AtomicWrite.LazyText import qualified System.Console.ANSI import qualified System.FilePath import qualified System.IO -import Dhall.Pretty.Internal (ChooseCharacterSet(..), chooseCharsetOrUseDefault) -- | Arguments to the `format` subcommand data Format = Format diff --git a/dhall/src/Dhall/Marshal/Encode.hs b/dhall/src/Dhall/Marshal/Encode.hs index 1e1527afe..f2bbd860a 100644 --- a/dhall/src/Dhall/Marshal/Encode.hs +++ b/dhall/src/Dhall/Marshal/Encode.hs @@ -65,6 +65,7 @@ import Control.Monad.Trans.State.Strict import Data.Functor.Contravariant (Contravariant (..), Op (..), (>$<)) import Data.Functor.Contravariant.Divisible (Divisible (..), divided) import Dhall.Parser (Src (..)) +import Dhall.Pretty (ChooseCharacterSet(..)) import Dhall.Syntax ( Chunks (..) , DhallDouble (..) @@ -94,7 +95,6 @@ import qualified Dhall.Core as Core import qualified Dhall.Map import Dhall.Marshal.Internal -import Dhall.Pretty.Internal (ChooseCharacterSet(..)) -- $setup -- >>> :set -XRecordWildCards diff --git a/dhall/src/Dhall/Pretty/Internal.hs b/dhall/src/Dhall/Pretty/Internal.hs index d2cb8ac64..5bbb93ba0 100644 --- a/dhall/src/Dhall/Pretty/Internal.hs +++ b/dhall/src/Dhall/Pretty/Internal.hs @@ -177,7 +177,7 @@ instance Monoid ChooseCharacterSet where instance FromJSON ChooseCharacterSet where parseJSON Null = pure mempty - parseJSON v@(String _) = fmap Specify (parseJSON v) + parseJSON v@(String _) = Specify <$> (parseJSON v) parseJSON v = typeMismatch "String" v chooseCharsetOrUseDefault :: CharacterSet -> ChooseCharacterSet -> CharacterSet diff --git a/dhall/src/Dhall/Schemas.hs b/dhall/src/Dhall/Schemas.hs index 9f7bb1ca2..5d3b69458 100644 --- a/dhall/src/Dhall/Schemas.hs +++ b/dhall/src/Dhall/Schemas.hs @@ -20,8 +20,7 @@ import Data.Text (Text) import Data.Void (Void) import Dhall.Crypto (SHA256Digest) import Dhall.Map (Map) -import Dhall.Pretty (detectCharacterSet) -import Dhall.Pretty.Internal (ChooseCharacterSet(..), chooseCharsetOrUseDefault) +import Dhall.Pretty (detectCharacterSet, ChooseCharacterSet(..), chooseCharsetOrUseDefault) import Dhall.Src (Src) import Dhall.Syntax (Expr (..), Import, Var (..)) import Dhall.Util diff --git a/dhall/tests/Dhall/Test/QuickCheck.hs b/dhall/tests/Dhall/Test/QuickCheck.hs index b73156be3..6814364ac 100644 --- a/dhall/tests/Dhall/Test/QuickCheck.hs +++ b/dhall/tests/Dhall/Test/QuickCheck.hs @@ -60,7 +60,7 @@ import Data.Functor.Identity (Identity (..)) import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable, typeRep) import Dhall.Parser (Header (..), createHeader) -import Dhall.Pretty (CharacterSet (..)) +import Dhall.Pretty (CharacterSet (..), ChooseCharacterSet (..)) import Dhall.Set (Set) import Dhall.Src (Src (..)) import Dhall.Test.Format (format) @@ -215,6 +215,12 @@ shrinkWhitespace _ = [""] instance Arbitrary CharacterSet where arbitrary = Test.QuickCheck.elements [ ASCII, Unicode ] +instance Arbitrary ChooseCharacterSet where + arbitrary = Test.QuickCheck.oneof [ + return AutoInferCharSet + , Specify <$> arbitrary + ] + instance Arbitrary Header where arbitrary = createHeader <$> whitespace From f626a044887babb10dd484265d46aa2fdef2545e Mon Sep 17 00:00:00 2001 From: Sergei Winitzki Date: Sat, 21 Jun 2025 21:15:44 +0200 Subject: [PATCH 6/6] fix test fixture --- dhall/src/Dhall/Normalize.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dhall/src/Dhall/Normalize.hs b/dhall/src/Dhall/Normalize.hs index c51377dfd..65425f438 100644 --- a/dhall/src/Dhall/Normalize.hs +++ b/dhall/src/Dhall/Normalize.hs @@ -116,7 +116,7 @@ boundedType _ = False >>> mfb = Syntax.makeFunctionBinding >>> alphaNormalize (Lam mempty (mfb "a" (Const Type)) (Lam mempty (mfb "b" (Const Type)) (Lam mempty (mfb "x" "a") (Lam mempty (mfb "y" "b") "x")))) -Lam Nothing (FunctionBinding {functionBindingSrc0 = Nothing, functionBindingVariable = "_", functionBindingSrc1 = Nothing, functionBindingSrc2 = Nothing, functionBindingAnnotation = Const Type}) (Lam Nothing (FunctionBinding {functionBindingSrc0 = Nothing, functionBindingVariable = "_", functionBindingSrc1 = Nothing, functionBindingSrc2 = Nothing, functionBindingAnnotation = Const Type}) (Lam Nothing (FunctionBinding {functionBindingSrc0 = Nothing, functionBindingVariable = "_", functionBindingSrc1 = Nothing, functionBindingSrc2 = Nothing, functionBindingAnnotation = Var (V "_" 1)}) (Lam Nothing (FunctionBinding {functionBindingSrc0 = Nothing, functionBindingVariable = "_", functionBindingSrc1 = Nothing, functionBindingSrc2 = Nothing, functionBindingAnnotation = Var (V "_" 1)}) (Var (V "_" 1))))) +Lam AutoInferCharSet (FunctionBinding {functionBindingSrc0 = Nothing, functionBindingVariable = "_", functionBindingSrc1 = Nothing, functionBindingSrc2 = Nothing, functionBindingAnnotation = Const Type}) (Lam AutoInferCharSet (FunctionBinding {functionBindingSrc0 = Nothing, functionBindingVariable = "_", functionBindingSrc1 = Nothing, functionBindingSrc2 = Nothing, functionBindingAnnotation = Const Type}) (Lam AutoInferCharSet (FunctionBinding {functionBindingSrc0 = Nothing, functionBindingVariable = "_", functionBindingSrc1 = Nothing, functionBindingSrc2 = Nothing, functionBindingAnnotation = Var (V "_" 1)}) (Lam AutoInferCharSet (FunctionBinding {functionBindingSrc0 = Nothing, functionBindingVariable = "_", functionBindingSrc1 = Nothing, functionBindingSrc2 = Nothing, functionBindingAnnotation = Var (V "_" 1)}) (Var (V "_" 1))))) α-normalization does not affect free variables: