diff --git a/autoapply.cabal b/autoapply.cabal --- a/autoapply.cabal +++ b/autoapply.cabal @@ -1,13 +1,13 @@ cabal-version: 1.24 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: adce22696e9593f56e72a791f5f8ef22dcc139f9909ff91a4034795112ed4ed2 +-- hash: 8ee53363c7e4d90277a3ca258c64ba2e7a9cb984cd139b5f7cfdd9d0f664bb2a name: autoapply -version: 0.4.1 +version: 0.4.1.1 synopsis: Template Haskell to automatically pass values to functions description: See readme.md category: Template Haskell @@ -22,6 +22,7 @@ readme.md default.nix changelog.md + package.yaml source-repository head type: git @@ -40,14 +41,30 @@ Paths_autoapply hs-source-dirs: src - default-extensions: DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies FlexibleContexts KindSignatures LambdaCase PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables TemplateHaskellQuotes TupleSections TypeApplications TypeFamilies ViewPatterns + default-extensions: + DeriveFoldable + DeriveFunctor + DeriveTraversable + DerivingStrategies + FlexibleContexts + KindSignatures + LambdaCase + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + TemplateHaskellQuotes + TupleSections + TypeApplications + TypeFamilies + ViewPatterns ghc-options: -Wall build-depends: base >=4.12 && <5 , logict , mtl , template-haskell - , th-desugar >=1.11 && <1.12 + , th-desugar ==1.12.* , transformers , unification-fd default-language: Haskell2010 @@ -59,7 +76,23 @@ Types hs-source-dirs: test - default-extensions: DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies FlexibleContexts KindSignatures LambdaCase PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables TemplateHaskellQuotes TupleSections TypeApplications TypeFamilies ViewPatterns + default-extensions: + DeriveFoldable + DeriveFunctor + DeriveTraversable + DerivingStrategies + FlexibleContexts + KindSignatures + LambdaCase + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + TemplateHaskellQuotes + TupleSections + TypeApplications + TypeFamilies + ViewPatterns ghc-options: -Wall build-depends: autoapply diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -2,6 +2,9 @@ ## WIP +## [0.4.1.1] - 2021-10-17 + - Bump th-desugar version + ## [0.4.1] - 2020-08-26 - Fix tests in dist diff --git a/default.nix b/default.nix --- a/default.nix +++ b/default.nix @@ -1,42 +1,17 @@ -{ pkgs ? import { }, compiler ? "ghc884", hoogle ? true }: +{ pkgs ? import ./nixpkgs.nix, compiler ? null +, extraOverrides ? _: _: { }, modifier ? x: x }: let - src = pkgs.nix-gitignore.gitignoreSource [ ] ./.; - - compiler' = if compiler != null then - compiler + haskellPackages = if compiler == null then + pkgs.haskellPackages else - "ghc" + pkgs.lib.concatStrings - (pkgs.lib.splitVersion pkgs.haskellPackages.ghc.version); - - # Any overrides we require to the specified haskell package set - haskellPackages = with pkgs.haskell.lib; - pkgs.haskell.packages.${compiler'}.override { - overrides = self: super: - { - th-desugar = self.th-desugar_1_11; - } // pkgs.lib.optionalAttrs hoogle { - ghc = super.ghc // { withPackages = super.ghc.withHoogle; }; - ghcWithPackages = self.ghc.withPackages; - }; - }; - - # Any packages to appear in the environment provisioned by nix-shell - extraEnvPackages = with haskellPackages; [ ]; - - # Generate a haskell derivation using the cabal2nix tool on `package.yaml` - drv = let old = haskellPackages.callCabal2nix "" src { }; - in old // { - # Insert the extra environment packages into the environment generated by - # cabal2nix - env = pkgs.lib.overrideDerivation old.env (attrs: - { - buildInputs = attrs.buildInputs ++ extraEnvPackages; - } // pkgs.lib.optionalAttrs hoogle { - shellHook = attrs.shellHook + '' - export HIE_HOOGLE_DATABASE="$(cat $(${pkgs.which}/bin/which hoogle) | sed -n -e 's|.*--database \(.*\.hoo\).*|\1|p')" - ''; - }); - }; + pkgs.haskell.packages.${compiler}; -in if pkgs.lib.inNixShell then drv.env else drv +in haskellPackages.developPackage { + name = ""; + root = pkgs.nix-gitignore.gitignoreSource [ ] ./.; + overrides = with pkgs.haskell.lib; + pkgs.lib.composeExtensions + (self: _super: { th-desugar = self.th-desugar_1_12; }) extraOverrides; + inherit modifier; +} diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,62 @@ +name: autoapply +version: "0.4.1.1" +synopsis: Template Haskell to automatically pass values to functions +description: See readme.md +category: Template Haskell +maintainer: Joe Hermaszewski +copyright: (c) 2020 Joe Hermaszewski +github: expipiplus1/autoapply +extra-source-files: + - readme.md + - default.nix + - changelog.md + - package.yaml + +library: + source-dirs: src + dependencies: + - base >= 4.12 && < 5 + - logict + - mtl + - template-haskell + - th-desugar >= 1.12 && < 1.13 + - transformers + - unification-fd + +tests: + doctests: + main: Doctests.hs + other-modules: Types + source-dirs: + - test + dependencies: + - base + - doctest + - autoapply + +custom-setup: + dependencies: + - base + - Cabal + - cabal-doctest >= 1 && <1.1 + +ghc-options: + - -Wall + +default-extensions: + - DeriveFoldable + - DeriveFunctor + - DeriveTraversable + - DerivingStrategies + - FlexibleContexts + - KindSignatures + - LambdaCase + - PatternSynonyms + - RankNTypes + - RecordWildCards + - ScopedTypeVariables + - TemplateHaskellQuotes + - TupleSections + - TypeApplications + - TypeFamilies + - ViewPatterns diff --git a/src/AutoApply.hs b/src/AutoApply.hs --- a/src/AutoApply.hs +++ b/src/AutoApply.hs @@ -260,7 +260,7 @@ BoundPure _ (Given _ n _) -> DVarE n Argument n _ -> DVarE n ) - exp' <- dsDoStmts (bs <> [NoBindS (sweeten ret')]) + exp' <- dsDoStmts Nothing (bs <> [NoBindS (sweeten ret')]) -- Typing the arguments here is important, if we don't then some skolems -- might escape! @@ -336,20 +336,20 @@ ArrowF -> DArrowT LitF l -> DLitT l -varBndrName :: DTyVarBndr -> Name +varBndrName :: DTyVarBndrUnit -> Name varBndrName = \case - DPlainTV n -> n - DKindedTV n _ -> n + DPlainTV n () -> n + DKindedTV n () _ -> n -- | Raise foralls on the spine of the function type to the top -- -- For example @forall a. a -> forall b. b@ becomes @forall a b. a -> b@ raiseForalls :: DType -> DType raiseForalls = go >>> \case - (vs, ctx, t) -> DForallT ForallVis vs . DConstrainedT ctx $ t + (vs, ctx, t) -> DForallT (DForallVis vs) . DConstrainedT ctx $ t where go = \case - DForallT _ vs t -> let (vs', ctx', t') = go t in (vs <> vs', ctx', t') + DForallT vs t -> let (vs', ctx', t') = go t in (telescopeBndrs vs <> vs', ctx', t') DConstrainedT ctx t -> let (vs', ctx', t') = go t in (vs', ctx <> ctx', t') l :~> r -> let (vs, ctx, r') = go r in (vs, ctx, l :~> r') @@ -391,20 +391,26 @@ stripForall :: DType -> ([Name], DType) stripForall = raiseForalls >>> \case - DForallT _ vs (DConstrainedT _ ty) -> (varBndrName <$> vs, ty) - DForallT _ vs ty -> (varBndrName <$> vs, ty) + DForallT vs (DConstrainedT _ ty) -> (varBndrName <$> telescopeBndrs vs, ty) + DForallT vs ty -> (varBndrName <$> telescopeBndrs vs, ty) DConstrainedT _ ty -> ([], ty) ty -> ([], ty) -unravel :: DType -> ([DTyVarBndr], [DPred], [DType], DType) +telescopeBndrs :: DForallTelescope -> [DTyVarBndrUnit] +telescopeBndrs = \case + DForallVis vs -> vs + DForallInvis vs -> (() <$) <$> vs + +unravel :: DType -> ([DTyVarBndrUnit], [DPred], [DType], DType) unravel t = let (argList, ret) = unravelDType t go = \case DFANil -> ([], [], []) - DFAForalls _ vs as -> (vs, [], []) <> go as + DFAForalls vs as -> (telescopeBndrs vs, [], []) <> go as DFACxt preds as -> ([], preds, []) <> go as DFAAnon a as -> ([], [], [a]) <> go as in let (vs, preds, args) = go argList in (vs, preds, args, ret) note :: MonadFail m => String -> Maybe a -> m a note s = maybe (fail s) pure + diff --git a/test/Types.hs b/test/Types.hs --- a/test/Types.hs +++ b/test/Types.hs @@ -131,7 +131,7 @@ -- >>> :t x -- x :: () test6 :: (forall a b. a -> b) -> () -test6 = const () +test6 = \x -> const () x autoapplyDecs (<> "'") [] ['id] ['test6] test6' :: (forall a b. a -> b) -> () @@ -141,7 +141,7 @@ -- >>> :t x -- x :: (forall a. a) -> () test7 :: (forall a. a) -> () -test7 = const () +test7 = \x -> const () x -- | 'id' is instantiated twice at different types -- >>> $(autoapply [] ['id] 'test8) @@ -313,7 +313,7 @@ -- -- >>> x = $(autoapply [] [] 'test23) -- --- :355:7: error: +-- :...: error: -- • "Impossible" Finding argument provenances failed (unless the function context containts a class with no instances) -- • In the untyped splice: $(autoapply [] [] 'test23) class MyClassWithNoInstances (a :: Type) where