free-functors 0.8.2 → 0.8.3

raw patch · 4 files changed

+68/−1 lines, 4 files

Files

• CHANGELOG +4/−0
• free-functors.cabal +4/−1
• src/Data/Functor/Free.hs +1/−0
• src/Data/Functor/Free/TH.hs +59/−0

@@ -1,8 +1,12 @@ CHANGELOG +0.8.2 -> 0.8.3+  - Added Data.Functor.Free.TH to other-modules+   0.8.1 -> 0.8.2   - Support for `deriveInstances` for classes which have one or more superclasses   - `deriveInstances` now also derives the `HasSuperClasses` instance+  - Expose internal `ShowHelper` datatype    0.8 -> 0.8.1   - Added HHCofree

@@ -1,5 +1,5 @@ name:                free-functors-version:             0.8.2+version:             0.8.3 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@@ -39,6 +39,9 @@     Data.Functor.HFree,     Data.Functor.HHCofree,     Data.Functor.HHFree+    +  other-modules:+    Data.Functor.Free.TH    default-language:     Haskell2010

@@ -51,6 +51,7 @@   , InitialObject   , initial   +  -- * Internal   , ShowHelper(..)    ) where

@@ -0,0 +1,59 @@+{-# LANGUAGE+    ConstraintKinds+  , GADTs+  , RankNTypes+  , TypeOperators+  , FlexibleInstances+  , MultiParamTypeClasses+  , UndecidableInstances+  , ScopedTypeVariables+  , DeriveFunctor+  , DeriveFoldable+  , DeriveTraversable+  , TemplateHaskell+  , PolyKinds+  , DataKinds+  #-}+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' :: Bool -> Name -> Name -> Name -> Name -> Name -> Name -> Q [Dec]+deriveInstances' withHSC forallLiftedNm dictLiftedNm freeNm liftAFreeNm showHelperNm 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+    , hasSuperClassesInstance+    , 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)))+      hasSuperClassesInstance = if withHSC then [d|instance HasSuperClasses $(pure c) where {+        type SuperClasses $(pure c) = $(pure c) ': $(scs);+        superClasses = Sub Dict;+        containsSelf = Sub Dict+      }|] else return []+      scs = foldr (\(SuperclassTH scnm _ _) q -> [t|SuperClasses $(pure (ConT scnm)) ++ $(q)|]) [t|'[]|] $ superclasses sigInfo+      isSC = AppT (AppT superClass1 c) (VarT vc)+      free = ConT freeNm+      liftAFree = ConT liftAFreeNm+      showHelper = ConT showHelperNm+      superClass1 = ConT ''SuperClass1+      c = ConT nm+      sig = ConT $ signatureName sigInfo+      a = mkName "a"+      f = mkName "f"+      vc = mkName "c"