diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,17 @@ +0.9.4 -> 0.10 +- Update for GHC 9.6 through 9.14 + +0.9.2 -> 0.9.4 +- Update for GHC 8.8 + - Updated to base-4.13.0.0 + - Updated to template-haskell-2.15.0.0 +- Add Ap instance + +0.9.1 -> 0.9.2 +- Update for GHC 8.6 + - Updated to base-4.12.0.0 + - Updated to template-haskell-2.14.0.0 + 0.9 -> 0.9.1 - Update for GHC 8.4 - Updated to base-4.11.0.0 diff --git a/Data/Algebra/Internal.hs b/Data/Algebra/Internal.hs --- a/Data/Algebra/Internal.hs +++ b/Data/Algebra/Internal.hs @@ -17,7 +17,7 @@ ----------------------------------------------------------------------------- module Data.Algebra.Internal where -import GHC.Exts (Constraint) +import Data.Kind (Constraint, Type) import Control.Applicative (Const) import Data.Monoid (Ap) @@ -25,11 +25,11 @@ import Control.Arrow ((&&&)) -- | The signature datatype for the class @c@. -type family Signature (c :: * -> Constraint) :: * -> * +type family Signature (c :: Type -> Constraint) :: Type -> Type class Traversable f => AlgebraSignature f where -- | The class for which @f@ is the signature. - type Class f :: * -> Constraint + type Class f :: Type -> Constraint -- | Translate the operations of the signature to method calls of the class. evaluate :: Class f b => f b -> b diff --git a/Data/Algebra/TH.hs b/Data/Algebra/TH.hs --- a/Data/Algebra/TH.hs +++ b/Data/Algebra/TH.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE TemplateHaskell, TupleSections #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Algebra.TH @@ -62,28 +65,26 @@ getSignatureInfo :: Name -> Q SignatureTH getSignatureInfo name = do ClassI (ClassD ctx _ [tyvar] _ decs) _ <- reify name - let tv = tvName tyvar + let tv = tyVarName tyvar let sigName = changeName (++ "Signature") name - ops <- for decs $ \sig -> - case sig of - SigD nm (ForallT [tv'] _ tp) -> mkOp nm tp tv (tvName tv') - SigD nm tp -> mkOp nm tp tv tv - _ -> return Nothing - scs <- for ctx $ \ty -> - case ty of - (AppT (ConT scName) (VarT tv')) | tv == tv' -> do - s <- getSignatureInfo scName - case s of - SignatureTH _ _ [] [] -> return Nothing - _ -> return $ Just $ SuperclassTH scName (changeName (addScPrefix name) scName) s - _ -> return Nothing + ops <- for decs $ \case + SigD nm (ForallT [tv'] _ tp) -> mkOp nm tp tv (tyVarName tv') + SigD nm tp -> mkOp nm tp tv tv + _ -> return Nothing + scs <- for ctx $ \case + (AppT (ConT scName) (VarT tv')) | tv == tv' -> do + s <- getSignatureInfo scName + case s of + SignatureTH _ _ [] [] -> return Nothing + _ -> return $ Just $ SuperclassTH scName (changeName (addScPrefix name) scName) s + _ -> return Nothing return $ SignatureTH sigName tv (catMaybes ops) (catMaybes scs) where mkOp nm tp tv tv' = do dec <- reify nm fty <- fromMaybe defaultFixity <$> reifyFixity nm case dec of - ClassOpI _ _ _ -> + ClassOpI{} -> return $ case buildOperation tv' tp of Just (ar, mkCon) -> let opName = changeName addPrefix nm @@ -172,6 +173,7 @@ deriveSuperclassInstances' ctx className typeName AppT (ConT className) typeName -> deriveSuperclassInstances' [] className typeName + s -> error $ "Unsupported type: " <> show s deriveSuperclassInstances' :: Cxt -> Name -> Type -> Q [Dec] deriveSuperclassInstances' ctx className typeName = do @@ -196,6 +198,7 @@ deriveInstanceWith'' addSignature ctx className typeName id dec AppT (ConT className) typeName -> deriveInstanceWith'' addSignature [] className typeName id dec + s -> error $ "Unsupported type: " <> show s deriveInstanceWith'' :: Bool -> Cxt -> Name -> Type -> (Exp -> Exp) -> Q [Dec] -> Q [Dec] deriveInstanceWith'' addSignature ctx className typeName wrap dec = do @@ -214,9 +217,15 @@ (++ [InstanceD Nothing ctx (AppT (ConT className) typeName) impl]) <$> if addSignature then deriveSignature className else return [] +#if MIN_VERSION_template_haskell(2,21,0) +#else +bndrReq :: () +bndrReq = () +#endif + buildSignatureDataType :: SignatureTH -> [Dec] buildSignatureDataType s = - [DataD [] (signatureName s) [PlainTV (typeVarName s)] Nothing + [DataD [] (signatureName s) [PlainTV (typeVarName s) bndrReq] Nothing ((constructor <$> operations s) ++ (buildSuperclassCon (typeVarName s) <$> superclasses s)) [DerivClause Nothing (map ConT [''Functor, ''Foldable, ''Traversable, ''Eq, ''Ord])]] @@ -227,17 +236,17 @@ sigTFInst = TySynInstD (TySynEqn Nothing (AppT (ConT ''Signature) (ConT nm)) signature) typeInst = TySynInstD (TySynEqn Nothing (AppT (ConT ''Class) signature) (ConT nm)) asClauses = - [ Clause [ConP opName (map VarP args)] (NormalB (foldl (\e arg -> AppE e (VarE arg)) (VarE fName) args)) [] + [ Clause [ConP opName [] (map VarP args)] (NormalB (foldl (\e arg -> AppE e (VarE arg)) (VarE fName) args)) [] | OperationTH fName opName ar _ _ <- operations s, let args = mkArgList ar ] asScClauses = - [ Clause [ConP conName [(VarP v)]] (NormalB $ AppE (VarE 'evaluate) (VarE v)) [] + [ Clause [ConP conName [] [(VarP v)]] (NormalB $ AppE (VarE 'evaluate) (VarE v)) [] | SuperclassTH _ conName _ <- superclasses s, let v = mkName "v"] asInst = InstanceD Nothing [] (AppT (ConT ''AlgebraSignature) signature) [typeInst, FunD 'evaluate (asClauses ++ asScClauses)] showsPrecClauses = - [ Clause [VarP d, ConP opName (map VarP args)] (NormalB $ createShowsPrec d (nameBase fName) prec args) [] + [ Clause [VarP d, ConP opName [] (map VarP args)] (NormalB $ createShowsPrec d (nameBase fName) prec args) [] | OperationTH fName opName ar _ (Fixity prec _) <- operations s, let args = mkArgList ar, let d = mkName "d" ] showsPrecScClauses = - [ Clause [VarP d, ConP conName [(VarP v)]] (NormalB $ AppE (AppE (VarE 'showsPrec) (VarE d)) (VarE v)) [] + [ Clause [VarP d, ConP conName [] [(VarP v)]] (NormalB $ AppE (AppE (VarE 'showsPrec) (VarE d)) (VarE v)) [] | SuperclassTH _ conName _ <- superclasses s, let d = mkName "d", let v = mkName "v"] createShowsPrec d name prec [u,v] | isOperator name = InfixE (Just (AppE (VarE 'showParen) (InfixE (Just (VarE d)) (VarE '(>)) (Just (LitE (IntegerL prec')))))) (VarE '($)) @@ -292,10 +301,11 @@ prependC :: Type -> Con -> Con prependC st (NormalC nm sts) = NormalC nm ((bangDef, st):sts) +prependC _ s = error $ "Unsupported type: " <> show s bangDef :: Bang bangDef = Bang NoSourceUnpackedness NoSourceStrictness -tvName :: TyVarBndr -> Name -tvName (PlainTV nm) = nm -tvName (KindedTV nm _) = nm +tyVarName :: TyVarBndr s -> Name +tyVarName (PlainTV n _) = n +tyVarName (KindedTV n _ _) = n diff --git a/algebraic-classes.cabal b/algebraic-classes.cabal --- a/algebraic-classes.cabal +++ b/algebraic-classes.cabal @@ -1,5 +1,5 @@ name: algebraic-classes -version: 0.9.4 +version: 0.10 synopsis: Conversions between algebraic classes and F-algebras. description: Algebraic classes are type classes where all the methods return a value of the same type, which is also the class parameter. Examples from @base@ are @Num@ and @Monoid@. @@ -23,10 +23,13 @@ maintainer: sjoerd@w3future.com category: Data, Generics, Math build-type: Simple -cabal-version: >=1.8 +cabal-version: 2.0 +tested-with: GHC==9.6.7, GHC==9.8.4, GHC==9.10.3, GHC==9.12.2, GHC==9.14.1 extra-source-files: examples/*.hs + +extra-doc-files: CHANGELOG library @@ -36,10 +39,13 @@ Data.Algebra.Internal build-depends: - base >= 4.10 && < 4.14 + base >= 4.18 && < 4.23 , syb == 0.7.* - , template-haskell >= 2.12 && < 2.16 + , template-haskell >= 2.20 && < 2.25 + default-language: + Haskell2010 + source-repository head type: git - location: git://github.com/sjoerdvisscher/algebraic-classes.git + location: https://github.com/sjoerdvisscher/algebraic-classes diff --git a/examples/Fractional.hs b/examples/Fractional.hs --- a/examples/Fractional.hs +++ b/examples/Fractional.hs @@ -2,12 +2,12 @@ {-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveTraversable, RankNTypes #-} import Data.Algebra -import Data.Algebra.TH +-- import Data.Algebra.TH import Data.Ratio --- deriveInstance [t| forall m n. (Num m, Num n) => Num (m, n) |] +deriveInstance [t| forall m n. (Num m, Num n) => Num (m, n) |] deriveInstance [t| forall m n. (Fractional m, Fractional n) => Fractional (m, n) |] -deriveSuperclassInstances [t| forall m n. (Fractional m, Fractional n) => Fractional (m, n) |] +-- deriveSuperclassInstances [t| forall m n. (Fractional m, Fractional n) => Fractional (m, n) |] test :: (Ratio Int, Ratio Int) test = (5, 3) / (3, 2) + (1, 4)