From 3cf9506b3882c35fb11caa1455420a29d9a19962 Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Fri, 20 Dec 2024 03:35:49 +0000 Subject: [PATCH 1/3] Fix TyVar BndrVis (#2622) https://github.com/dhall-lang/dhall-haskell/pull/2542 allowed `dhall` to compile with template-haskell-2.21 and GHC-9.8 by adapting to the addition of a binder visibility field on type variables. Previously all binders were taken to be required, but in GHC-9.8 the possibility of invisible binders was introduced. The above patch mistakenly set all binders generated by Dhall to be invisible, rather than default value of required. This changes the semantics of the code and broke some examples in the test suite. This patch fixes this by correctly setting binders to be BndrReq. Resolves https://github.com/dhall-lang/dhall-haskell/issues/2567 --- dhall/src/Dhall/TH.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dhall/src/Dhall/TH.hs b/dhall/src/Dhall/TH.hs index a27e5f8c5..ab5e5ac88 100644 --- a/dhall/src/Dhall/TH.hs +++ b/dhall/src/Dhall/TH.hs @@ -265,7 +265,7 @@ toDeclaration generateOptions@GenerateOptions{..} haskellTypes typ = interpretOptions = generateToInterpretOptions generateOptions typ #if MIN_VERSION_template_haskell(2,21,0) - toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) Syntax.BndrInvis + toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) Syntax.BndrReq #elif MIN_VERSION_template_haskell(2,17,0) toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) () #else From e9f37ae8e2101d1d0c34c7d16f1d977bb1c8c4ca Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Fri, 20 Dec 2024 06:25:26 +0100 Subject: [PATCH 2/3] Dhall.TH: Call `addDependentFile` for each local import (#2620) * Dhall.TH: Import Template Haskell module qualified as TH * Dhall.TH: Register local imports for recompiliation checking We call Language.Haskell.TH.addDependentFile for each local import so that GHC rebuilds if those files changes. --- dhall/src/Dhall.hs | 20 ++++++++++--- dhall/src/Dhall/TH.hs | 65 +++++++++++++++++++++++++++++-------------- 2 files changed, 60 insertions(+), 25 deletions(-) diff --git a/dhall/src/Dhall.hs b/dhall/src/Dhall.hs index ca4d6a4b0..d6d4af53e 100644 --- a/dhall/src/Dhall.hs +++ b/dhall/src/Dhall.hs @@ -50,6 +50,7 @@ module Dhall -- * Individual phases , parseWithSettings , resolveWithSettings + , resolveAndStatusWithSettings , typecheckWithSettings , checkWithSettings , expectWithSettings @@ -63,7 +64,7 @@ import Control.Applicative (Alternative, empty) import Control.Monad.Catch (MonadThrow, throwM) import Data.Either.Validation (Validation (..)) import Data.Void (Void) -import Dhall.Import (Imported (..)) +import Dhall.Import (Imported (..), Status) import Dhall.Parser (Src (..)) import Dhall.Syntax (Expr (..), Import) import Dhall.TypeCheck (DetailedTypeError (..), TypeError) @@ -262,7 +263,16 @@ expectWithSettings settings Decoder{..} expression = do `InputSettings` -} resolveWithSettings :: InputSettings -> Expr Src Import -> IO (Expr Src Void) -resolveWithSettings settings expression = do +resolveWithSettings settings expression = + fst <$> resolveAndStatusWithSettings settings expression + +-- | A version of 'resolveWithSettings' that also returns the import 'Status' +-- together with the resolved expression. +resolveAndStatusWithSettings + :: InputSettings + -> Expr Src Import + -> IO (Expr Src Void, Status) +resolveAndStatusWithSettings settings expression = do let InputSettings{..} = settings let EvaluateSettings{..} = _evaluateSettings @@ -274,9 +284,11 @@ resolveWithSettings settings expression = do let status = transform (Dhall.Import.emptyStatusWithManager _newManager _rootDirectory) - resolved <- State.evalStateT (Dhall.Import.loadWith expression) status + (resolved, status') <- State.runStateT (Dhall.Import.loadWith expression) status + + let substituted = Dhall.Substitution.substitute resolved (view substitutions settings) - pure (Dhall.Substitution.substitute resolved (view substitutions settings)) + pure (substituted, status') -- | Normalize an expression, using the supplied `InputSettings` normalizeWithSettings :: InputSettings -> Expr Src Void -> Expr Src Void diff --git a/dhall/src/Dhall/TH.hs b/dhall/src/Dhall/TH.hs index ab5e5ac88..e5b47c7cb 100644 --- a/dhall/src/Dhall/TH.hs +++ b/dhall/src/Dhall/TH.hs @@ -20,12 +20,14 @@ module Dhall.TH , defaultGenerateOptions ) where +import Control.Monad (forM_) import Data.Bifunctor (first) import Data.Text (Text) import Dhall (FromDhall, ToDhall) import Dhall.Syntax (Expr (..), FunctionBinding (..), Var (..)) import GHC.Generics (Generic) import Language.Haskell.TH.Quote (QuasiQuoter (..), dataToExpQ) +import Lens.Family (view) import Prettyprinter (Pretty) import Language.Haskell.TH.Syntax @@ -52,11 +54,12 @@ import qualified Data.Time as Time import qualified Data.Typeable as Typeable import qualified Dhall import qualified Dhall.Core as Core +import qualified Dhall.Import import qualified Dhall.Map import qualified Dhall.Pretty import qualified Dhall.Util import qualified GHC.IO.Encoding -import qualified Language.Haskell.TH.Syntax as Syntax +import qualified Language.Haskell.TH.Syntax as TH import qualified Numeric.Natural import qualified Prettyprinter.Render.String as Pretty import qualified System.IO @@ -88,15 +91,35 @@ import qualified System.IO -} staticDhallExpression :: Text -> Q Exp staticDhallExpression text = do - Syntax.runIO (GHC.IO.Encoding.setLocaleEncoding System.IO.utf8) + TH.runIO (GHC.IO.Encoding.setLocaleEncoding System.IO.utf8) - expression <- Syntax.runIO (Dhall.inputExpr text) + (expression, status) <- TH.runIO $ do + parsed <- Dhall.parseWithSettings Dhall.defaultInputSettings text + + (resolved, status) <- Dhall.resolveAndStatusWithSettings Dhall.defaultInputSettings parsed + + _ <- Dhall.typecheckWithSettings Dhall.defaultInputSettings resolved + + let normalized = Dhall.normalizeWithSettings Dhall.defaultInputSettings resolved + + pure (normalized, status) + + forM_ (Dhall.Map.keys (view Dhall.Import.cache status)) $ \chained -> + case Dhall.Import.chainedImport chained of + Core.Import + { importHashed = Core.ImportHashed + { importType = Core.Local prefix file + } + } -> do + fp <- Dhall.Import.localToPath prefix file + TH.addDependentFile fp + _ -> return () dataToExpQ (fmap liftText . Typeable.cast) expression 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)) . Syntax.lift . Text.unpack + liftText = fmap (AppE (VarE 'Text.pack)) . TH.lift . Text.unpack {-| A quasi-quoter for Dhall expressions. @@ -207,14 +230,14 @@ toNestedHaskellType typeParams haskellTypes = loop Var v | Just (V param index) <- List.find (v ==) typeParams -> do - let name = Syntax.mkName $ (Text.unpack param) ++ (show index) + let name = TH.mkName $ (Text.unpack param) ++ (show index) return (VarT name) | otherwise -> fail $ message v _ | Just haskellType <- List.find (predicate dhallType) haskellTypes -> do - let name = Syntax.mkName (Text.unpack (typeName haskellType)) + let name = TH.mkName (Text.unpack (typeName haskellType)) return (ConT name) | otherwise -> fail $ message dhallType @@ -225,7 +248,7 @@ derivingGenericClause = DerivClause (Just StockStrategy) [ ConT ''Generic ] -- | Generates a `FromDhall` instances. fromDhallInstance - :: Syntax.Name -- ^ The name of the type the instances is for + :: TH.Name -- ^ The name of the type the instances is for -> Q Exp -- ^ A TH splice generating some `Dhall.InterpretOptions` -> Q [Dec] fromDhallInstance n interpretOptions = [d| @@ -235,7 +258,7 @@ fromDhallInstance n interpretOptions = [d| -- | Generates a `ToDhall` instances. toDhallInstance - :: Syntax.Name -- ^ The name of the type the instances is for + :: TH.Name -- ^ The name of the type the instances is for -> Q Exp -- ^ A TH splice generating some `Dhall.InterpretOptions` -> Q [Dec] toDhallInstance n interpretOptions = [d| @@ -265,15 +288,15 @@ toDeclaration generateOptions@GenerateOptions{..} haskellTypes typ = interpretOptions = generateToInterpretOptions generateOptions typ #if MIN_VERSION_template_haskell(2,21,0) - toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) Syntax.BndrReq + toTypeVar (V n i) = TH.PlainTV (TH.mkName (Text.unpack n ++ show i)) TH.BndrReq #elif MIN_VERSION_template_haskell(2,17,0) - toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) () + toTypeVar (V n i) = TH.PlainTV (TH.mkName (Text.unpack n ++ show i)) () #else - toTypeVar (V n i) = Syntax.PlainTV (Syntax.mkName (Text.unpack n ++ show i)) + toTypeVar (V n i) = TH.PlainTV (TH.mkName (Text.unpack n ++ show i)) #endif toDataD typeName typeParams constructors = do - let name = Syntax.mkName (Text.unpack typeName) + let name = TH.mkName (Text.unpack typeName) let params = fmap toTypeVar typeParams @@ -355,7 +378,7 @@ toConstructor -- ^ @(constructorName, fieldType)@ -> Q Con toConstructor typeParams GenerateOptions{..} haskellTypes outerTypeName (constructorName, maybeAlternativeType) = do - let name = Syntax.mkName (Text.unpack $ constructorModifier constructorName) + let name = TH.mkName (Text.unpack $ constructorModifier constructorName) let strictness = if makeStrict then SourceStrict else NoSourceStrictness @@ -368,7 +391,7 @@ toConstructor typeParams GenerateOptions{..} haskellTypes outerTypeName (constru && typeName haskellType /= outerTypeName , Just haskellType <- List.find predicate haskellTypes -> do let innerName = - Syntax.mkName (Text.unpack (typeName haskellType)) + TH.mkName (Text.unpack (typeName haskellType)) return (NormalC name [ (bang, ConT innerName) ]) @@ -376,7 +399,7 @@ toConstructor typeParams GenerateOptions{..} haskellTypes outerTypeName (constru let process (key, dhallFieldType) = do haskellFieldType <- toNestedHaskellType typeParams haskellTypes dhallFieldType - return (Syntax.mkName (Text.unpack $ fieldModifier key), bang, haskellFieldType) + return (TH.mkName (Text.unpack $ fieldModifier key), bang, haskellFieldType) varBangTypes <- traverse process (Dhall.Map.toList $ Core.recordFieldValue <$> kts) @@ -508,16 +531,16 @@ generateToInterpretOptions GenerateOptions{..} haskellType = [| Dhall.InterpretO mkMatch n = Match (textToPat $ f n) (NormalB $ textToExp n) [] nameE :: Exp - nameE = Syntax.VarE $ Syntax.mkName "n" + nameE = TH.VarE $ TH.mkName "n" nameP :: Pat - nameP = Syntax.VarP $ Syntax.mkName "n" + nameP = TH.VarP $ TH.mkName "n" textToExp :: Text -> Exp - textToExp = Syntax.LitE . Syntax.StringL . Text.unpack + textToExp = TH.LitE . TH.StringL . Text.unpack textToPat :: Text -> Pat - textToPat = Syntax.LitP . Syntax.StringL . Text.unpack + textToPat = TH.LitP . TH.StringL . Text.unpack -- | Generate a Haskell datatype declaration with one constructor from a Dhall -- type. @@ -605,8 +628,8 @@ makeHaskellTypes = makeHaskellTypesWith defaultGenerateOptions -- > makeHaskellTypes = makeHaskellTypesWith defaultGenerateOptions makeHaskellTypesWith :: GenerateOptions -> [HaskellType Text] -> Q [Dec] makeHaskellTypesWith generateOptions haskellTypes = do - Syntax.runIO (GHC.IO.Encoding.setLocaleEncoding System.IO.utf8) + TH.runIO (GHC.IO.Encoding.setLocaleEncoding System.IO.utf8) - haskellTypes' <- traverse (traverse (Syntax.runIO . Dhall.inputExpr)) haskellTypes + haskellTypes' <- traverse (traverse (TH.runIO . Dhall.inputExpr)) haskellTypes concat <$> traverse (toDeclaration generateOptions haskellTypes') haskellTypes' From 4f185b961cc9a461bdee5ceb7e778fb5d4879ceb Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Fri, 20 Dec 2024 01:23:09 -0600 Subject: [PATCH 3/3] Fix cross-compilation (exclude TH) (#2621) Co-authored-by: gabby --- dhall/dhall.cabal | 6 +++++- dhall/tests/Dhall/Test/Main.hs | 5 +++++ 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index 39ba80687..e0b7ad1f7 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -268,6 +268,8 @@ Common common if flag(network-tests) CPP-Options: -DNETWORK_TESTS + if flag(cross) + CPP-Options: -DCROSS GHC-Options: -Wall -Wcompat -Wincomplete-uni-patterns -optP-Wno-unicode-homoglyph @@ -432,10 +434,12 @@ Test-Suite tasty Dhall.Test.Schemas Dhall.Test.SemanticHash Dhall.Test.Substitution - Dhall.Test.TH Dhall.Test.Tutorial Dhall.Test.TypeInference Dhall.Test.Util + if !flag(cross) + Other-Modules: + Dhall.Test.TH Build-Depends: dhall , foldl < 1.5 , diff --git a/dhall/tests/Dhall/Test/Main.hs b/dhall/tests/Dhall/Test/Main.hs index 5e4ac206f..ee8b6c822 100644 --- a/dhall/tests/Dhall/Test/Main.hs +++ b/dhall/tests/Dhall/Test/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module Main where import System.FilePath (()) @@ -17,7 +18,9 @@ import qualified Dhall.Test.QuickCheck import qualified Dhall.Test.Regression import qualified Dhall.Test.Schemas import qualified Dhall.Test.SemanticHash +#ifndef CROSS import qualified Dhall.Test.TH +#endif import qualified Dhall.Test.Tags import qualified Dhall.Test.Tutorial import qualified Dhall.Test.TypeInference @@ -69,7 +72,9 @@ getAllTests = do , Dhall.Test.Tutorial.tests , Dhall.Test.QuickCheck.tests , Dhall.Test.Dhall.tests +#ifndef CROSS , Dhall.Test.TH.tests +#endif , Dhall.Test.Package.tests ]