free-functors 1.0 → 1.0.1

raw patch · 4 files changed

+83/−57 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• examples/Sem.hs +0/−35
• examples/SemSum.hs +61/−0
• free-functors.cabal +1/−1
• src/Data/Functor/Free/Internal.hs +21/−21

@@ -1,35 +0,0 @@-{-# 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)

@@ -0,0 +1,61 @@+{-# LANGUAGE +  TemplateHaskell, TypeFamilies, DeriveTraversable, FlexibleInstances, UndecidableInstances,+  TypeOperators, MultiParamTypeClasses, ConstraintKinds, UndecidableSuperClasses, QuantifiedConstraints +  #-}+  +module Sem where+  +import GHC.Generics+import Data.Algebra+import Data.Functor.Free++class BaseSem a where+  val :: Int -> a+  add :: a -> a -> a++instance BaseSem Int where+  val = id+  add = (+)++class SubSem a where+  sub :: a -> a -> a++instance SubSem Int where+  sub = (-)++class MulSem a where+  mul :: a -> a -> a++instance MulSem Int where+  mul = (*)+++class (a x, b x) => (a + b) x+instance (a x, b x) => (a + b) x++type instance Signature (a + b) = Signature a :+: Signature b++instance (AlgebraSignature f, AlgebraSignature g) => AlgebraSignature (f :+: g) where+  type Class (f :+: g) = Class f + Class g+  evaluate (L1 f) = evaluate f+  evaluate (R1 f) = evaluate f+  ++deriveInstances ''BaseSem+deriveInstances ''SubSem+deriveInstances ''MulSem+++test :: Free (BaseSem + SubSem + MulSem) String+test = mul (add (pure "a") (val 3)) (sub (val 5) (pure "b"))++eval :: Free (BaseSem + SubSem + MulSem) String -> Int+eval = rightAdjunct lookupVar+  where+    lookupVar :: String -> Int+    lookupVar "a" = 2+    lookupVar "b" = 1+    lookupVar v = error $ "Unknown variable: " ++ v++main :: IO ()+main = putStrLn $ show test ++ " = " ++ show (eval test)

@@ -1,5 +1,5 @@ name:                free-functors-version:             1.0+version:             1.0.1 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

@@ -1,5 +1,6 @@ {-# LANGUAGE-    RankNTypes+    GADTs+  , RankNTypes   , TypeOperators   , DeriveFunctor   , DeriveFoldable@@ -88,17 +89,19 @@   traverse f = getLiftAFree . rightAdjunct (LiftAFree . fmap unit . f)  -data ShowHelper f a = ShowUnit a | ShowRec (f (ShowHelper f a))+data ShowHelper a where +  ShowUnit :: a -> ShowHelper a+  ShowRec :: Show (f (ShowHelper a)) => f (ShowHelper a) -> ShowHelper a -instance Algebra f (ShowHelper f a) where+instance Show (f (ShowHelper a)) => Algebra f (ShowHelper a) where   algebra = ShowRec -instance (Show a, Show (f (ShowHelper f a))) => Show (ShowHelper f a) where+instance Show a => Show (ShowHelper a) where   showsPrec p (ShowUnit a) = showParen (p > 10) $ showString "unit " . showsPrec 11 a   showsPrec p (ShowRec f) = showsPrec p f -instance (Show a, Show (Signature c (ShowHelper (Signature c) a)), c (ShowHelper (Signature c) a)) => Show (Free c a) where-  showsPrec p = showsPrec p . rightAdjunct (ShowUnit :: a -> ShowHelper (Signature c) a)+instance (Show a, Show (Signature c (ShowHelper a)), c (ShowHelper a)) => Show (Free c a) where+  showsPrec p = showsPrec p . rightAdjunct ShowUnit   class (a => b) => a :=> b@@ -110,18 +113,15 @@ -- -- @deriveInstances ''Num@ deriveInstances :: Name -> Q [Dec]-deriveInstances nm = getSignatureInfo nm >>= h where-  h sigInfo =-    concat <$> sequenceA-    [ deriveSignature nm-    , deriveInstanceWith_skipSignature freeHeader $ return []-    , deriveInstanceWith_skipSignature liftAFreeHeader $ return []-    , deriveInstanceWith_skipSignature showHelperHeader $ return []-    , deriveSuperclassInstances showHelperHeader-    ]-    where-      freeHeader = [t|forall a c. (forall x. c x :=> $clss x) => $clss (Free c a)|]-      liftAFreeHeader = [t|forall f a c. (Applicative f, forall x. c x :=> $clss x) => $clss (LiftAFree c f a)|]-      showHelperHeader = [t|forall a. $clss (ShowHelper $sig a)|]-      clss = pure $ ConT nm-      sig = pure . ConT $ signatureName sigInfo+deriveInstances nm = +  concat <$> sequenceA+  [ deriveSignature nm+  , deriveInstanceWith_skipSignature freeHeader $ return []+  , deriveInstanceWith_skipSignature liftAFreeHeader $ return []+  , deriveInstanceWith_skipSignature showHelperHeader $ return []+  ]+  where+    freeHeader = [t|forall a c. (forall x. c x :=> $clss x) => $clss (Free c a)|]+    liftAFreeHeader = [t|forall f a c. (Applicative f, forall x. c x :=> $clss x) => $clss (LiftAFree c f a)|]+    showHelperHeader = [t|forall a. Show a => $clss (ShowHelper a)|]+    clss = pure $ ConT nm