fastsum 0.1.1.0 → 0.1.1.1
raw patch · 4 files changed
+71/−35 lines, 4 filesdep ~template-haskellnew-component:exe:examplesPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: template-haskell
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- fastsum.cabal +7/−5
- src/Data/Sum.hs +1/−1
- src/Data/Sum/Templates.hs +59/−29
ChangeLog.md view
@@ -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.
fastsum.cabal view
@@ -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
src/Data/Sum.hs view
@@ -66,7 +66,7 @@ import GHC.TypeLits import Unsafe.Coerce(unsafeCoerce) -pure [mkElemIndexTypeFamily 200]+mkElemIndexTypeFamily 200 infixr 5 :<
src/Data/Sum/Templates.hs view
@@ -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)