free-functors 0.8.1 → 0.8.2
raw patch · 5 files changed
+50/−56 lines, 5 filesdep ~algebraic-classes
Dependency ranges changed: algebraic-classes
Files
- CHANGELOG +4/−0
- examples/Sem.hs +35/−0
- free-functors.cabal +2/−3
- src/Data/Functor/Free.hs +9/−4
- src/Data/Functor/Free/TH.hs +0/−49
CHANGELOG view
@@ -1,5 +1,9 @@ CHANGELOG +0.8.1 -> 0.8.2+ - Support for `deriveInstances` for classes which have one or more superclasses+ - `deriveInstances` now also derives the `HasSuperClasses` instance+ 0.8 -> 0.8.1 - Added HHCofree - Changes towards support for `SuperClass1` in TH code for `Free`
+ examples/Sem.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveTraversable, FlexibleInstances, FlexibleContexts, UndecidableInstances, DataKinds #-}+module Sem where+ +import Data.Functor.Free++class BaseSem a where+ val :: Int -> a+ add :: a -> a -> a++instance BaseSem Int where+ val = id+ add = (+)++class BaseSem a => AdvSem a where+ mul :: a -> a -> a++instance AdvSem Int where+ mul = (*)++deriveInstances ''BaseSem+deriveInstances ''AdvSem+++test :: Free AdvSem String+test = mul (add (pure "a") (val 3)) (val 5)++evaluate :: Free AdvSem String -> Int+evaluate = rightAdjunct lookupVar+ where+ lookupVar :: String -> Int+ lookupVar "a" = 2+ lookupVar v = error $ "Unknown variable: " ++ v++main :: IO ()+main = putStrLn $ show test ++ " = " ++ show (evaluate test)
free-functors.cabal view
@@ -1,5 +1,5 @@ name: free-functors-version: 0.8.1+version: 0.8.2 synopsis: Free functors, adjoint to functors that forget class constraints. description: A free functor is a left adjoint to a forgetful functor. It used to be the case that the only category that was easy to work with in Haskell was Hask itself, so@@ -35,7 +35,6 @@ Data.Constraint.Class1, Data.Functor.Cofree, Data.Functor.Free,- Data.Functor.Free.TH, Data.Functor.HCofree, Data.Functor.HFree, Data.Functor.HHCofree,@@ -50,7 +49,7 @@ constraints == 0.9.*, transformers == 0.5.*, comonad == 5.*,- algebraic-classes >= 0.7 && < 0.9,+ algebraic-classes >= 0.9 && < 1.0, contravariant == 1.4.*, bifunctors == 5.*, profunctors == 5.*
src/Data/Functor/Free.hs view
@@ -13,6 +13,7 @@ , TemplateHaskell , PolyKinds , TypeFamilies+ , DataKinds #-} ----------------------------------------------------------------------------- -- |@@ -49,6 +50,8 @@ , inR , InitialObject , initial+ + , ShowHelper(..) ) where @@ -213,8 +216,10 @@ -- -- @deriveInstances ''Num@ deriveInstances :: Name -> Q [Dec]-deriveInstances = deriveInstances' ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper+deriveInstances = deriveInstances' True ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper -deriveInstances' ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper ''Num-deriveInstances' ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper ''Semigroup-deriveInstances' ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper ''Monoid+deriveInstances' False ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper ''Num+deriveInstances' False ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper ''Fractional+deriveInstances' False ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper ''Floating+deriveInstances' False ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper ''Semigroup+deriveInstances' False ''ForallLifted 'dictLifted ''Free ''LiftAFree ''ShowHelper ''Monoid
− src/Data/Functor/Free/TH.hs
@@ -1,49 +0,0 @@-{-# LANGUAGE- ConstraintKinds- , GADTs- , RankNTypes- , TypeOperators- , FlexibleInstances- , MultiParamTypeClasses- , UndecidableInstances- , ScopedTypeVariables- , DeriveFunctor- , DeriveFoldable- , DeriveTraversable- , TemplateHaskell- , PolyKinds- #-}-module Data.Functor.Free.TH where--import Data.Constraint hiding (Class)-import Data.Constraint.Class1--import Data.Algebra.TH-import Language.Haskell.TH.Syntax--deriveInstances' :: Name -> Name -> Name -> Name -> Name -> Name -> Q [Dec]-deriveInstances' forallLiftedNm dictLiftedNm freeNm liftAFreeNm showHelperNm nm = concat <$> sequenceA- [ deriveSignature nm- , deriveInstanceWith_skipSignature freeHeader $ return []- , deriveInstanceWith_skipSignature liftAFreeHeader $ return []- , deriveInstanceWith_skipSignature showHelperHeader $ return []- , return $ [InstanceD Nothing [] (AppT (ConT forallLiftedNm) c) [ValD (VarP dictLiftedNm) (NormalB (ConE 'Dict)) []]]- ]- where- freeHeader = return $ ForallT [PlainTV a, PlainTV vc] [AppT (AppT superClass1 c) (VarT vc)]- (AppT c (AppT (AppT free (VarT vc)) (VarT a)))- liftAFreeHeader = return $ ForallT [PlainTV f, PlainTV a, PlainTV vc] [AppT (ConT ''Applicative) (VarT f), isSC]- (AppT c (AppT (AppT (AppT liftAFree (VarT vc)) (VarT f)) (VarT a)))- showHelperHeader = return $ ForallT [PlainTV a] []- (AppT c (AppT (AppT showHelper sig) (VarT a)))- isSC = AppT (AppT superClass1 c) (VarT vc)- free = ConT freeNm- liftAFree = ConT liftAFreeNm- showHelper = ConT showHelperNm- superClass1 = ConT ''SuperClass1- c = ConT nm- sig = ConT $ mkName (nameBase nm ++ "Signature")- a = mkName "a"- f = mkName "f"- vc = mkName "c"-