algebraic-classes 0.5.2 → 0.6

raw patch · 7 files changed

+76/−63 lines, 7 filesdep ~basedep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG +9/−0
• Data/Algebra.hs +4/−6
• Data/Algebra/Internal.hs +5/−7
• Data/Algebra/TH.hs +44/−34
• algebraic-classes.cabal +9/−4
• examples/Fractional.hs +4/−7
• examples/Signatures.hs +1/−5

@@ -0,0 +1,9 @@+0.5.2 -> 0.6+- Update for GHC 7.10+  - Updated to base-4.8.0.0+  - Updated to template-haskell-2.10.0.0++0.5.1 -> 0.5.2+- Update for GHC 7.8+  - Updated to base-4.7.0.0+  - Updated to template-haskell-2.9.0.0

@@ -1,10 +1,8 @@-{-# LANGUAGE -    TypeFamilies +{-# LANGUAGE+    TypeFamilies   , ConstraintKinds   , MultiParamTypeClasses   , TemplateHaskell-  , DeriveFunctor-  , DeriveFoldable   , DeriveTraversable   #-} -----------------------------------------------------------------------------@@ -17,13 +15,13 @@ -- Stability   :  experimental -- Portability :  non-portable ------------------------------------------------------------------------------module Data.Algebra +module Data.Algebra   ( deriveInstance   , deriveInstanceWith     -- * Classes   , Algebra(..)   , algebraA-  , Signature(..)+  , Signature   , AlgebraSignature(..)   ) where 

@@ -1,5 +1,5 @@-{-# LANGUAGE -    TypeFamilies +{-# LANGUAGE+    TypeFamilies   , ConstraintKinds   , MultiParamTypeClasses   , FlexibleInstances@@ -18,11 +18,9 @@ module Data.Algebra.Internal where  import GHC.Exts (Constraint)-import Control.Applicative-import Data.Traversable (Traversable(..))+import Control.Applicative (Const(..))  import GHC.Conc (STM)-import Data.Monoid import Control.Arrow ((&&&))  -- | The signature datatype for the class @c@.@@ -41,13 +39,13 @@   -- > instance (Class f m, Class f n) => Algebra f (m, n) where   -- >   algebra fmn = (evaluate (fmap fst fmn), evaluate (fmap snd fmn))   algebra :: AlgebraSignature f => f a -> a-  + -- | If you just want to applicatively lift existing instances, you can use this default implementation of `algebra`. algebraA :: (Applicative g, Class f b, AlgebraSignature f) => f (g b) -> g b algebraA = fmap evaluate . sequenceA  instance Algebra f () where-  algebra = const () +  algebra = const () instance (Class f m, Class f n) => Algebra f (m, n) where   algebra = evaluate . fmap fst &&& evaluate . fmap snd 

@@ -9,7 +9,7 @@ -- Stability   :  experimental -- Portability :  non-portable ------------------------------------------------------------------------------module Data.Algebra.TH +module Data.Algebra.TH   ( deriveInstance   , deriveInstanceWith   , deriveInstanceWith_skipSignature@@ -24,10 +24,8 @@  import Data.Algebra.Internal -import Control.Applicative+import Data.Traversable (for) import Control.Arrow ((***))-import Data.Foldable (Foldable(foldMap))-import Data.Traversable (Traversable, forM) import Data.Monoid (Endo(..))  import Data.Maybe (catMaybes)@@ -36,7 +34,7 @@ import Data.Generics (Data, everywhere, mkT)  -data SignatureTH = SignatureTH +data SignatureTH = SignatureTH   { signatureName :: Name   , typeVarName :: Name   , operations :: [OperationTH]@@ -55,13 +53,21 @@   ClassI (ClassD _ _ _ _ decs) _ <- reify name   let tv = mkName "a"   let sigName = changeName (++ "Signature") name-  ops <- forM decs $ \(SigD nm (ForallT [PlainTV tv'] _ tp)) -> do-    ClassOpI _ _ _ fty <- reify nm-    return $ case buildOperation tv' tp of-      Just (ar, mkCon) -> -        let opName = changeName addPrefix nm-        in Just $ OperationTH nm opName ar (everywhere (mkT (rename tv' tv)) (mkCon opName)) fty-      _ -> Nothing+  ops <- for decs $ \sig ->+    case sig of+      (SigD nm (ForallT [tv'] _ tp)) -> do+        let tvn' = tvName tv'+        dec <- reify nm+        case dec of+          ClassOpI _ _ _ fty ->+            return $ case buildOperation tvn' tp of+              Just (ar, mkCon) ->+                let opName = changeName addPrefix nm+                in Just $ OperationTH nm opName ar (everywhere (mkT (rename tvn' tv)) (mkCon opName)) fty+              _ -> Nothing+          _ -> fail $ "No support for " ++ show dec+      SigD{} -> fail $ "No support for " ++ show sig+      _ -> return Nothing   return $ SignatureTH sigName tv $ catMaybes ops  -- | Derive a signature for an algebraic class.@@ -80,7 +86,7 @@ -- >   type Class MonoidSignature = Monoid -- >   evaluate Op_mempty = mempty -- >   evaluate (Op_mappend a b) = mappend a b--- >   evaluate (Op_mconcat ms) = mconcat ms  +-- >   evaluate (Op_mconcat ms) = mconcat ms -- > -- > instance Show a => Show (MonoidSignature a) where -- >   showsPrec d Op_mempty          = showParen (d > 10) $ showString "mempty"@@ -98,7 +104,7 @@   return $ if mName == Nothing then buildSignatureDataType s ++ signatureInstances className s else []  -- | Derive an instance for an algebraic class.---   For example: +--   For example: -- --   > deriveInstance [t| (Num m, Num n) => Num (m, n) |] --@@ -112,7 +118,7 @@ -- | Derive an instance for an algebraic class with a given partial implementation. --   For example: ----- > deriveInstanceWith [t| Num n => Num (Integer -> n) |] +-- > deriveInstanceWith [t| Num n => Num (Integer -> n) |] -- >   [d| -- >     fromInteger x y = fromInteger (x + y) -- >   |]@@ -130,26 +136,26 @@ deriveInstanceWith' addSignature qtyp dec = do   typ <- qtyp   case typ of-    ForallT _ ctx (AppT (ConT className) typeName) -> +    ForallT _ ctx (AppT (ConT className) typeName) ->       deriveInstanceWith'' addSignature ctx className typeName dec-    AppT (ConT className) typeName -> +    AppT (ConT className) typeName ->       deriveInstanceWith'' addSignature [] className typeName dec  deriveInstanceWith'' :: Bool -> Cxt -> Name -> Type -> Q [Dec] -> Q [Dec] deriveInstanceWith'' addSignature ctx className typeName dec = do   given <- dec   s <- getSignatureInfo className-  let -    givenLU = -      [ (nameBase nm, (nm, renamer f)) | f@(FunD nm _) <- given ] ++ +  let+    givenLU =+      [ (nameBase nm, (nm, renamer f)) | f@(FunD nm _) <- given ] ++       [ (nameBase nm, (nm, renamer v)) | v@(ValD (VarP nm) _ _) <- given ]     renamer = renameAll [ (nm, nm') | (b, (nm, _)) <- givenLU, nm' <- functionName <$> operations s, nameBase nm' == b ]-    impl = -      [ maybe -          (FunD fName [Clause (map VarP args) (NormalB (AppE (VarE 'algebra) (foldl (\e arg -> AppE e (VarE arg)) (ConE opName) args))) []]) +    impl =+      [ maybe+          (FunD fName [Clause (map VarP args) (NormalB (AppE (VarE 'algebra) (foldl (\e arg -> AppE e (VarE arg)) (ConE opName) args))) []])           snd mgiven-      | OperationTH fName opName ar _ _ <- operations s, let mgiven = lookup (nameBase fName) givenLU, let args = mkArgList ar ]   -  (++ [InstanceD ctx (AppT (ConT className) typeName) impl]) <$> +      | OperationTH fName opName ar _ _ <- operations s, let mgiven = lookup (nameBase fName) givenLU, let args = mkArgList ar ]+  (++ [InstanceD ctx (AppT (ConT className) typeName) impl]) <$>     if addSignature then deriveSignature className else return []  buildSignatureDataType :: SignatureTH -> [Dec]@@ -163,28 +169,28 @@     signature = ConT (signatureName s)     sigTFInst = TySynInstD ''Signature (TySynEqn [ConT nm] signature)     typeInst = TySynInstD ''Class (TySynEqn [signature] (ConT nm))-    asClauses = +    asClauses =       [ 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 ]     asInst = InstanceD [] (AppT (ConT ''AlgebraSignature) signature) [typeInst, FunD 'evaluate asClauses]     showsPrecClauses =       [ 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" ]-    createShowsPrec d name prec [u,v] | isOperator name = -      InfixE (Just (AppE (VarE 'showParen) (InfixE (Just (VarE d)) (VarE '(>)) (Just (LitE (IntegerL prec')))))) (VarE '($)) -        (Just (InfixE (Just (AppE (AppE (VarE 'showsPrec) (LitE (IntegerL prec1))) (VarE u))) (VarE '(.)) -        (Just (InfixE (Just (AppE (VarE 'showString) (LitE (StringL (" " ++ name ++ " "))))) (VarE '(.)) +    createShowsPrec d name prec [u,v] | isOperator name =+      InfixE (Just (AppE (VarE 'showParen) (InfixE (Just (VarE d)) (VarE '(>)) (Just (LitE (IntegerL prec')))))) (VarE '($))+        (Just (InfixE (Just (AppE (AppE (VarE 'showsPrec) (LitE (IntegerL prec1))) (VarE u))) (VarE '(.))+        (Just (InfixE (Just (AppE (VarE 'showString) (LitE (StringL (" " ++ name ++ " "))))) (VarE '(.))         (Just (AppE (AppE (VarE 'showsPrec) (LitE (IntegerL prec1))) (VarE v)))))))       where         prec' = toInteger prec         prec1 = prec' + 1-    createShowsPrec d name prec args = +    createShowsPrec d name _ args =       InfixE (Just (AppE (VarE 'showParen) (InfixE (Just (VarE d)) (VarE '(>)) (Just (LitE (IntegerL 10)))))) (VarE '($)) $         foldl addArg (Just (AppE (VarE 'showString) (LitE (StringL name)))) args-    addArg expr arg = -      Just $ InfixE expr (VarE '(.)) (Just (InfixE (Just (AppE (VarE 'showChar) (LitE (CharL ' ')))) (VarE '(.)) +    addArg expr arg =+      Just $ InfixE expr (VarE '(.)) (Just (InfixE (Just (AppE (VarE 'showChar) (LitE (CharL ' ')))) (VarE '(.))         (Just (AppE (AppE (VarE 'showsPrec) (LitE (IntegerL 11))) (VarE arg)))))-    showInst = InstanceD [ClassP ''Show [a]] (AppT (ConT ''Show) (AppT signature a)) [FunD 'showsPrec showsPrecClauses]+    showInst = InstanceD [AppT (ConT ''Show) a] (AppT (ConT ''Show) (AppT signature a)) [FunD 'showsPrec showsPrecClauses]     a = VarT $ mkName "a"  buildOperation :: Name -> Type -> Maybe (Int, Name -> Con)@@ -215,3 +221,7 @@  prependC :: (Strict, Type) -> Con -> Con prependC st (NormalC nm sts) = NormalC nm (st:sts)++tvName :: TyVarBndr -> Name+tvName (PlainTV nm) = nm+tvName (KindedTV nm _) = nm

@@ -1,5 +1,5 @@ name:                algebraic-classes-version:             0.5.2+version:             0.6 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@.@@ -27,14 +27,19 @@  extra-source-files:   examples/*.hs+  CHANGELOG  library   exposed-modules:     Data.Algebra     Data.Algebra.TH     Data.Algebra.Internal-  +   build-depends:-      base == 4.7.*+      base == 4.8.*     , syb == 0.4.*-    , template-haskell == 2.9.0.*+    , template-haskell == 2.10.0.*++source-repository head+  type:     git+  location: git://github.com/sjoerdvisscher/algebraic-functors.git

@@ -1,18 +1,15 @@-{-# OPTIONS_GHC -ddump-splices #-}-{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# OPTIONS_GHC -ddump-splices -fno-warn-orphans #-}+{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveTraversable, RankNTypes #-}  import Data.Algebra import Data.Algebra.TH-import Data.Monoid-import Data.Foldable-import Data.Traversable import Data.Ratio  deriveSignature ''Num deriveSignature ''Fractional -deriveInstance [t| (Num m, Num n) => Num (m, n) |]-deriveInstance [t| (Fractional m, Fractional n) => Fractional (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) |]  test :: (Ratio Int, Ratio Int) test = (5, 3) / (3, 2) + (1, 4)

@@ -1,11 +1,7 @@ {-# OPTIONS_GHC -ddump-splices #-}-{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveTraversable #-} -import Data.Algebra import Data.Algebra.TH-import Data.Monoid-import Data.Foldable-import Data.Traversable  deriveSignature ''Monoid deriveSignature ''Num