diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +# v0.1.1.1 + +Enable use of `template-haskell` versions >= 2.15. + # v0.1.1 Added `projectGuard` and `NFData`/`NFData1` instances. diff --git a/fastsum.cabal b/fastsum.cabal --- a/fastsum.cabal +++ b/fastsum.cabal @@ -1,8 +1,10 @@ +cabal-version: 2.4 + name: fastsum -version: 0.1.1.0 +version: 0.1.1.1 synopsis: A fast open-union type suitable for 100+ contained alternatives homepage: https://github.com/patrickt/fastsum#readme -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Rob Rix, Josh Vera, Allele Dev, Patrick Thomson maintainer: patrickt@github.com @@ -11,10 +13,10 @@ build-type: Simple extra-source-files: README.md ChangeLog.md -cabal-version: >=1.10 tested-with: GHC == 8.2.2 GHC == 8.4.3 GHC == 8.6.3 + GHC == 8.8.1 description: This package provides Data.Sum, an open-union type, similar to the Union type that powers the implementation of Oleg Kiselyov's extensible-effects library. @@ -40,10 +42,10 @@ , deepseq >= 1.4 && <2 , ghc-prim >= 0.5 && <1 , hashable >= 1.2 && <2 - , template-haskell >= 2.12 && <3 + , template-haskell >= 2.12 && < 2.16 default-language: Haskell2010 -executable example +executable examples hs-source-dirs: examples main-is: Main.hs build-depends: base, fastsum diff --git a/src/Data/Sum.hs b/src/Data/Sum.hs --- a/src/Data/Sum.hs +++ b/src/Data/Sum.hs @@ -66,7 +66,7 @@ import GHC.TypeLits import Unsafe.Coerce(unsafeCoerce) -pure [mkElemIndexTypeFamily 200] +mkElemIndexTypeFamily 200 infixr 5 :< diff --git a/src/Data/Sum/Templates.hs b/src/Data/Sum/Templates.hs --- a/src/Data/Sum/Templates.hs +++ b/src/Data/Sum/Templates.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP, DataKinds, TemplateHaskell, QuasiQuotes, TypeApplications, TypeOperators #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_HADDOCK hide #-} module Data.Sum.Templates @@ -6,37 +6,67 @@ , mkApplyInstance ) where -import Language.Haskell.TH +import Control.Monad +import Data.Kind +import Data.Traversable +import Language.Haskell.TH hiding (Type) +import qualified Language.Haskell.TH as TH (Type) +import Language.Haskell.TH.Quote import Unsafe.Coerce (unsafeCoerce) +import GHC.TypeLits -mkElemIndexTypeFamily :: Integer -> Dec -mkElemIndexTypeFamily paramN = - ClosedTypeFamilyD (TypeFamilyHead elemIndex [KindedTV t functorK, KindedTV ts (AppT ListT functorK)] (KindSig (ConT nat)) Nothing) ((mkEquation <$> [0..pred paramN]) ++ errorCase) - where [elemIndex, t, ts, nat] = mkName <$> ["ElemIndex", "t", "ts", "Nat"] - functorK = AppT (AppT ArrowT StarT) StarT - mkT = VarT . mkName . ('t' :) . show - mkEquation i = TySynEqn [ mkT i, typeListT WildCardT (mkT <$> [0..i]) ] (LitT (NumTyLit i)) - typeErrN = mkName "TypeError" - textN = mkName "Text" - next = mkName ":<>:" - above = mkName ":$$:" - shw = mkName "ShowType" - errorCase = [ TySynEqn - [ VarT t , VarT ts ] - (AppT - (ConT typeErrN) - (AppT - (AppT (PromotedT above) - (AppT (AppT (PromotedT next) - (AppT (AppT - (PromotedT next) - (AppT (PromotedT textN) (LitT (StrTyLit "'")))) - (AppT (PromotedT shw) (VarT t)))) - (AppT (PromotedT textN) (LitT (StrTyLit "' is not a member of the type-level list"))))) - (AppT (PromotedT shw) (VarT ts)))) - ] +{- This generates a type family of the form +type family ElemIndex (t :: GHC.Types.Type + -> GHC.Types.Type) (ts :: [GHC.Types.Type + -> GHC.Types.Type]) :: Nat where + ElemIndex t0 ('(:) t0 _) = 0 + ElemIndex t1 ('(:) t0 ('(:) t1 _)) = 1 + ElemIndex t2 ('(:) t0 ('(:) t1 ('(:) t2 _))) = 2 + ElemIndex t3 ('(:) t0 ('(:) t1 ('(:) t2 ('(:) t3 _)))) = 3 + ElemIndex t4 ('(:) t0 ('(:) t1 ('(:) t2 ('(:) t3 ('(:) t4 _))))) = 4 + etc... + ElemIndex t ts = TypeError ('(:$$:) ('(:<>:) ('(:<>:) ('Text "'") ('ShowType t)) ('Text "' is not a member of the type-level list")) ('ShowType ts)) +-} +mkElemIndexTypeFamily :: Integer -> DecsQ +mkElemIndexTypeFamily paramN = do + -- Start by declaring some names. + let [elemIndex, t, ts] = mkName <$> ["ElemIndex", "t", "ts"] + -- Helper for building more readable type names rather than verbose gensyms + mkT = pure . VarT . mkName . ('t' :) . show + -- We want to make the kind signatures explicit here. + binders = [kindedTV t <$> [t| Type -> Type |] , kindedTV ts <$> [t| [Type -> Type] |] ] + -- This family ends up returning a Nat. + resultKind = kindSig <$> [t| Nat |] + -- We have to build n ElemIndex entries. + equations = fmap buildEquation [0..pred paramN] ++ [errorCase] + errorBody = [t| + TypeError ('Text "'" ':<>: ('ShowType $(varT t)) ':<>: + 'Text "' is not a member of the type-level list" ':$$: + 'ShowType $(varT ts)) + |] + -- The tySynEqn API changed in 2.15 so we need a guard here. + -- buildEquation a single family instance equation; it uses lhsMatch + -- to do so, making a type of the form 'ElemIndex n (n ': n0 : _) + -- errorCase is invoked above to provide a readable error +#if MIN_VERSION_template_haskell(2,15,0) + buildEquation n = tySynEqn Nothing (lhsMatch n) . litT . numTyLit $ n + lhsMatch n = [t| $(conT elemIndex) $(mkT n) $(typeListT WildCardT <$> traverse mkT [0..n]) |] + errorCase = tySynEqn Nothing [t| $(conT elemIndex) $(varT t) $(varT ts) |] errorBody +#else + buildEquation n = tySynEqn (lhsMatch n) (litT . numTyLit $ n) + lhsMatch n = [mkT n, typeListT WildCardT <$> traverse mkT [0..n] ] + errorCase = tySynEqn [varT t, varT ts] errorBody +#endif + + fmap pure =<< closedTypeFamilyD elemIndex + <$> sequenceA binders + <*> resultKind + <*> pure Nothing + <*> pure equations + + mkApplyInstance :: Integer -> Dec mkApplyInstance paramN = InstanceD Nothing (AppT constraint <$> typeParams) (AppT (AppT (ConT applyC) constraint) (typeListT PromotedNilT typeParams)) @@ -51,5 +81,5 @@ (NormalB (AppE (VarE f) (SigE (AppE (VarE 'unsafeCoerce) (VarE r)) (AppT nthType a)))) [] -typeListT :: Type -> [Type] -> Type +typeListT :: TH.Type -> [TH.Type] -> TH.Type typeListT = foldr (AppT . AppT PromotedConsT)