Merge pull request #8 from ConferHealth/corec-reflex

Corec reflex

Makefile

 
-.PHONY: build update-build update-nixpkgs composite-aeson/composite-aeson.cabal composite-base/composite-base.cabal composite-ekg/composite-ekg.cabal composite-opaleye/composite-opaleye.cabal
+.PHONY: \
+	build update-build update-nixpkgs                     \
+	composite-aeson/composite-aeson.cabal                 \
+	composite-aeson-refined/composite-aeson-refined.cabal \
+	composite-base/composite-base.cabal                   \
+	composite-ekg/composite-ekg.cabal                     \
+	composite-opaleye/composite-opaleye.cabal             \
+	composite-reflex/composite-reflex.cabal
 
 build: update-build
 	stack test --ghc-options="-Wall -Werror"
 
-update-build: composite-aeson/package.nix composite-base/package.nix composite-ekg/package.nix composite-opaleye/package.nix
+update-build: \
+  composite-aeson/package.nix \
+  composite-aeson-refined/package.nix \
+  composite-base/package.nix \
+  composite-ekg/package.nix \
+  composite-opaleye/package.nix \
+  composite-reflex/package.nix
 
 composite-aeson/package.nix: composite-aeson/composite-aeson.cabal
 	rm -f composite-aeson/package.nix
@@ -13,6 +26,13 @@ composite-aeson/package.nix: composite-aeson/composite-aeson.cabal
 composite-aeson/composite-aeson.cabal:
 	nix-shell -p haskellPackages.hpack --run 'hpack composite-aeson'
 
+composite-aeson-refined/package.nix: composite-aeson-refined/composite-aeson-refined.cabal
+	rm -f composite-aeson-refined/package.nix
+	cd composite-aeson-refined && nix-shell -p cabal2nix --run 'cabal2nix .' > package.nix
+
+composite-aeson-refined/composite-aeson-refined.cabal:
+	nix-shell -p haskellPackages.hpack --run 'hpack composite-aeson-refined'
+
 composite-base/package.nix: composite-base/composite-base.cabal
 	rm -f composite-base/package.nix
 	cd composite-base && nix-shell -p cabal2nix --run 'cabal2nix .' > package.nix
@@ -33,3 +53,10 @@ composite-opaleye/package.nix: composite-opaleye/composite-opaleye.cabal
 
 composite-opaleye/composite-opaleye.cabal:
 	nix-shell -p haskellPackages.hpack --run 'hpack composite-opaleye'
+
+composite-reflex/package.nix: composite-reflex/composite-reflex.cabal
+	rm -f composite-reflex/package.nix
+	cd composite-reflex && nix-shell -p cabal2nix --run 'cabal2nix .' > package.nix
+
+composite-reflex/composite-reflex.cabal:
+	nix-shell -p haskellPackages.hpack --run 'hpack composite-reflex'

composite-aeson-refined/Setup.hs

+import Distribution.Simple
+main = defaultMain

composite-aeson-refined/composite-aeson-refined.cabal

+-- This file has been generated from package.yaml by hpack version 0.17.0.
+--
+-- see: https://github.com/sol/hpack
+
+name:           composite-aeson-refined
+version:        0.4.0.0
+synopsis:       composite-aeson support for Refined from the refined package
+description:    JsonFormat and DefaultJsonFormat for Refined
+category:       Records
+homepage:       https://github.com/ConferHealth/composite#readme
+author:         Confer Health, Inc
+maintainer:     oss@confer.care
+copyright:      2017 Confer Health, Inc.
+license:        BSD3
+build-type:     Simple
+cabal-version:  >= 1.10
+
+library
+  hs-source-dirs:
+      src
+  default-extensions: DataKinds FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns
+  ghc-options: -Wall -O2
+  build-depends:
+      base >= 4.7 && < 5
+    , composite-aeson
+    , refined
+  exposed-modules:
+      Composite.Aeson.Refined
+  default-language: Haskell2010

composite-aeson-refined/package.nix

+{ mkDerivation, base, composite-aeson, refined, stdenv }:
+mkDerivation {
+  pname = "composite-aeson-refined";
+  version = "0.4.0.0";
+  src = ./.;
+  libraryHaskellDepends = [ base composite-aeson refined ];
+  homepage = "https://github.com/ConferHealth/composite#readme";
+  description = "composite-aeson support for Refined from the refined package";
+  license = stdenv.lib.licenses.bsd3;
+}

composite-aeson-refined/package.yaml

+name:                composite-aeson-refined
+version:             0.4.0.0
+synopsis:            composite-aeson support for Refined from the refined package
+description:         JsonFormat and DefaultJsonFormat for Refined
+homepage:            https://github.com/ConferHealth/composite#readme
+license:             BSD3
+author:              Confer Health, Inc
+maintainer:          oss@confer.care
+copyright:           2017 Confer Health, Inc.
+category:            Records
+
+dependencies:
+  - base >= 4.7 && < 5
+  - composite-aeson
+  - refined
+  # - aeson
+  # - aeson-better-errors
+  # - composite-base
+  # - containers
+  # - contravariant
+  # - generic-deriving
+  # - hashable
+  # - lens
+  # - profunctors
+  # - tagged
+  # - template-haskell
+  # - text
+  # - time
+  # - unordered-containers
+  # - vector
+  # - vinyl
+
+default-extensions:
+  - DataKinds
+  - FlexibleContexts
+  - FlexibleInstances
+  - GeneralizedNewtypeDeriving
+  - LambdaCase
+  - MultiParamTypeClasses
+  - MultiWayIf
+  - OverloadedStrings
+  - PatternSynonyms
+  - PolyKinds
+  - QuasiQuotes
+  - RankNTypes
+  - ScopedTypeVariables
+  - StandaloneDeriving
+  - StrictData
+  - TemplateHaskell
+  - TupleSections
+  - TypeFamilies
+  - TypeOperators
+  - ViewPatterns
+
+ghc-options: -Wall -O2
+
+library:
+  source-dirs: src

composite-aeson-refined/src/Composite/Aeson/Refined.hs

+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Composite.Aeson.Refined (refinedJsonFormat) where
+
+import Composite.Aeson (DefaultJsonFormat, defaultJsonFormat, JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor))
+import Refined (Predicate, Refined, refine, unrefine)
+
+-- |Given a @'JsonFormat' e a@, produce a @JsonFormat e ('Refined' p a)@ where @p@ is some 'Predicate' from the refined library for @a@.
+--
+-- This maps to the same JSON as the given 'JsonFormat', but when parsing it will apply 'refine' to assert that the incoming JSON value conforms to the
+-- predicate, failing to parse if not.
+refinedJsonFormat :: Predicate p a => JsonFormat e a -> JsonFormat e (Refined p a)
+refinedJsonFormat (JsonFormat (JsonProfunctor oa ia)) = JsonFormat $ JsonProfunctor o i
+  where
+    o = oa . unrefine
+    i = either fail pure . refine =<< ia
+
+instance (DefaultJsonFormat a, Predicate p a) => DefaultJsonFormat (Refined p a) where
+  defaultJsonFormat = refinedJsonFormat defaultJsonFormat

composite-aeson/composite-aeson.cabal

@@ -3,7 +3,7 @@
 -- see: https://github.com/sol/hpack
 
 name:           composite-aeson
-version:        0.3.1.0
+version:        0.4.0.0
 synopsis:       JSON for Vinyl/Frames records
 description:    Integration between Aeson and Vinyl/Frames records allowing records to be easily converted to JSON using automatic derivation, explicit formats, or a mix of both.
 category:       Records
@@ -18,7 +18,7 @@ cabal-version:  >= 1.10
 library
   hs-source-dirs:
       src
-  default-extensions: DataKinds FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns
+  default-extensions: DataKinds FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns
   ghc-options: -Wall -O2
   build-depends:
       base >= 4.7 && < 5
@@ -42,6 +42,7 @@ library
   exposed-modules:
       Composite.Aeson
       Composite.Aeson.Base
+      Composite.Aeson.CoRecord
       Composite.Aeson.DateTimeFormatUtils
       Composite.Aeson.Enum
       Composite.Aeson.Formats.DateTime
@@ -58,7 +59,7 @@ test-suite composite-aeson-test
   main-is: Main.hs
   hs-source-dirs:
       test
-  default-extensions: DataKinds FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns
+  default-extensions: DataKinds FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns
   ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans
   build-depends:
       base >= 4.7 && < 5

composite-aeson/package.nix

@@ -6,7 +6,7 @@
 }:
 mkDerivation {
   pname = "composite-aeson";
-  version = "0.3.1.0";
+  version = "0.4.0.0";
   src = ./.;
   libraryHaskellDepends = [
     aeson aeson-better-errors base composite-base containers

composite-aeson/package.yaml

 name:                composite-aeson
-version:             0.3.1.0
+version:             0.4.0.0
 synopsis:            JSON for Vinyl/Frames records
 description:         Integration between Aeson and Vinyl/Frames records allowing records to be easily converted to JSON using automatic derivation, explicit formats, or a mix of both.
 homepage:            https://github.com/ConferHealth/composite#readme
@@ -47,6 +47,7 @@ default-extensions:
   - StrictData
   - TemplateHaskell
   - TupleSections
+  - TypeApplications
   - TypeFamilies
   - TypeOperators
   - ViewPatterns

composite-aeson/src/Composite/Aeson/CoRecord.hs

+module Composite.Aeson.CoRecord
+  ( JsonFormatField, DefaultJsonFormatField(defaultJsonFormatField)
+  , fieldJsonFormat
+  ) where
+
+import Composite.Aeson.Base (FromJson(FromJson), JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor), wrappedJsonFormat)
+import Composite.Aeson.Formats.Default (DefaultJsonFormat, defaultJsonFormat)
+import Composite.Aeson.Formats.Generic (SumStyle, jsonSumFormat)
+import Composite.CoRecord (CoRec(CoVal), Field, fieldToRec)
+import Composite.Record ((:->), Rec((:&), RNil), RecWithContext(rmapWithContext), recordToNonEmpty, ReifyNames, reifyNames)
+import Data.Aeson (Value)
+import Data.Functor.Identity (Identity(Identity))
+import Data.List.NonEmpty (NonEmpty)
+import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
+import Data.Text (Text)
+import Data.Vinyl (RecApplicative, rapply, recordToList, (<<&>>))
+import Data.Vinyl.Functor (Compose(Compose), (:.), Const(Const), Lift(Lift))
+import Data.Vinyl.Lens (type (∈))
+import Data.Proxy (Proxy(Proxy))
+
+-- |Type of records which contain JSON formats for each element of @rs@.
+type JsonFormatField e rs = Rec (JsonFormat e) rs
+
+-- |Class which makes up a 'JsonFormatField' for some @rs@ where each @r ~ s :-> a@ by using the 'DefaultJsonFormat' instance for each @a@.
+class DefaultJsonFormatField (rs :: [*]) where
+  -- |Make up a 'JsonFormatField' for some @rs@ where each @r ~ s :-> a@ by using the 'DefaultJsonFormat' instance for each @a@.
+  defaultJsonFormatField :: JsonFormatField e rs
+
+instance DefaultJsonFormatField '[] where
+  defaultJsonFormatField = RNil
+
+instance forall s a rs. (DefaultJsonFormat a, DefaultJsonFormatField rs) => DefaultJsonFormatField (s :-> a ': rs) where
+  defaultJsonFormatField = wrappedJsonFormat defaultJsonFormat :& (defaultJsonFormatField :: JsonFormatField e rs)
+
+-- |Make a @'JsonFormat' e (Field rs)@ given how to map the sum type to JSON alogn with a record with formatters for each value the field could have.
+fieldJsonFormat
+  :: forall (rs :: [*]) r' (rs' :: [*]) e.
+     (rs ~ (r' ': rs'), RecApplicative rs, RecWithContext rs rs, ReifyNames rs)
+  => SumStyle -> JsonFormatField e rs -> JsonFormat e (Field rs)
+fieldJsonFormat sumStyle fmts = jsonSumFormat sumStyle o i
+  where
+    namedFmts :: Rec ((,) Text :. JsonFormat e) rs
+    namedFmts = reifyNames fmts
+
+    o :: Field rs -> (Text, Value)
+    o = fromMaybe (error "fieldToRec somehow produced all Nothings")
+      . listToMaybe . catMaybes
+      . (recordToList :: Rec (Const (Maybe (Text, Value))) rs -> [Maybe (Text, Value)])
+      . rapply outputs
+      . fieldToRec
+
+    outputs :: Rec (Lift (->) Maybe (Const (Maybe (Text, Value)))) rs
+    outputs = namedFmts <<&>> \ (Compose (name, JsonFormat (JsonProfunctor oa _))) ->
+      Lift $ Const . fmap ((name,) . oa)
+
+    i :: NonEmpty (Text, FromJson e (Field rs))
+    i = recordToNonEmpty $ rmapWithContext (Proxy @rs) oneCase namedFmts
+      where
+        oneCase :: forall r. r ∈ rs => ((,) Text :. JsonFormat e) r -> Const (Text, FromJson e (Field rs)) r
+        oneCase (Compose (name, JsonFormat (JsonProfunctor _ ia))) =
+          Const (name, FromJson (CoVal . Identity <$> ia))
+

composite-base/composite-base.cabal

@@ -3,7 +3,7 @@
 -- see: https://github.com/sol/hpack
 
 name:           composite-base
-version:        0.3.1.0
+version:        0.4.0.0
 synopsis:       Shared utilities for composite-* packages.
 description:    Shared helpers for the various composite packages.
 category:       Records
@@ -18,7 +18,7 @@ cabal-version:  >= 1.10
 library
   hs-source-dirs:
       src
-  default-extensions: ConstraintKinds DataKinds FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings PatternSynonyms PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns
+  default-extensions: ConstraintKinds DataKinds FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings PatternSynonyms PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns
   ghc-options: -Wall -O2
   build-depends:
       base >= 4.7 && < 5
@@ -27,12 +27,14 @@ library
     , lens
     , monad-control
     , mtl
+    , profunctors
     , text
     , transformers
     , transformers-base
     , vinyl
   exposed-modules:
       Composite
+      Composite.CoRecord
       Composite.Record
       Composite.TH
       Control.Monad.Composite.Context
@@ -43,7 +45,7 @@ test-suite composite-base-test
   main-is: Main.hs
   hs-source-dirs:
       test
-  default-extensions: ConstraintKinds DataKinds FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings PatternSynonyms PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns
+  default-extensions: ConstraintKinds DataKinds FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings PatternSynonyms PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns
   ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans
   build-depends:
       base >= 4.7 && < 5
@@ -52,6 +54,7 @@ test-suite composite-base-test
     , lens
     , monad-control
     , mtl
+    , profunctors
     , text
     , transformers
     , transformers-base

composite-base/package.nix

 { mkDerivation, base, exceptions, hspec, lens, monad-control, mtl
-, QuickCheck, stdenv, template-haskell, text, transformers
-, transformers-base, vinyl
+, profunctors, QuickCheck, stdenv, template-haskell, text
+, transformers, transformers-base, vinyl
 }:
 mkDerivation {
   pname = "composite-base";
-  version = "0.3.1.0";
+  version = "0.4.0.0";
   src = ./.;
   libraryHaskellDepends = [
-    base exceptions lens monad-control mtl template-haskell text
-    transformers transformers-base vinyl
+    base exceptions lens monad-control mtl profunctors template-haskell
+    text transformers transformers-base vinyl
   ];
   testHaskellDepends = [
-    base exceptions hspec lens monad-control mtl QuickCheck
+    base exceptions hspec lens monad-control mtl profunctors QuickCheck
     template-haskell text transformers transformers-base vinyl
   ];
   homepage = "https://github.com/ConferHealth/composite#readme";

composite-base/package.yaml

 name:                composite-base
-version:             0.3.1.0
+version:             0.4.0.0
 synopsis:            Shared utilities for composite-* packages.
 description:         Shared helpers for the various composite packages.
 homepage:            https://github.com/ConferHealth/composite#readme
@@ -16,6 +16,7 @@ dependencies:
   - lens
   - monad-control
   - mtl
+  - profunctors
   - text
   - transformers
   - transformers-base
@@ -27,6 +28,7 @@ default-extensions:
   - FlexibleContexts
   - FlexibleInstances
   - FunctionalDependencies
+  - GADTs
   - GeneralizedNewtypeDeriving
   - MultiParamTypeClasses
   - OverloadedStrings
@@ -38,6 +40,7 @@ default-extensions:
   - StrictData
   - TemplateHaskell
   - TupleSections
+  - TypeApplications
   - TypeFamilies
   - TypeOperators
   - ViewPatterns

composite-base/src/Composite/CoRecord.hs

+-- |Module containing the sum formulation companion to 'Composite.Record's product formulation. Values of type @'CoRec' f rs@ represent a single value
+-- @f r@ for one of the @r@s in @rs@. Heavily based on the great work by Anthony Cowley in Frames.
+{-# LANGUAGE UndecidableInstances #-} -- for FoldRec
+module Composite.CoRecord where
+
+import Prelude
+import Composite.Record (AllHave, HasInstances, reifyDicts, zipRecsWith)
+import Control.Lens (Prism', prism')
+import Data.Functor.Identity (Identity(Identity), runIdentity)
+import Data.Kind (Constraint)
+import Data.Profunctor (dimap)
+import Data.Proxy (Proxy(Proxy))
+import Data.Vinyl (Dict(Dict), Rec((:&), RNil), RecApplicative, RElem, recordToList, reifyConstraint, rmap, rpure)
+import Data.Vinyl.Functor (Compose(Compose, getCompose), Const(Const), (:.))
+import Data.Vinyl.Lens (type (∈), rget, rput)
+import Data.Vinyl.TypeLevel (RecAll, RIndex)
+
+-- FIXME? replace with int-index/union or at least lift ideas from there. This encoding is awkward to work with and not compositional.
+
+-- |@CoRef f rs@ represents a single value of type @f r@ for some @r@ in @rs@.
+data CoRec :: (u -> *) -> [u] -> * where
+  -- |Witness that @r@ is an element of @rs@ using '∈' ('RElem' with 'RIndex') from Vinyl.
+  CoVal :: r ∈ rs => !(f r) -> CoRec f rs
+
+instance forall rs. (AllHave '[Show] rs, RecApplicative rs) => Show (CoRec Identity rs) where
+  show (CoVal (Identity x)) = "(CoVal " ++ show' x ++ ")"
+    where
+      shower :: Rec (Op String) rs
+      shower = reifyDicts (Proxy @'[Show]) (\ _ -> Op show)
+      show' = runOp (rget Proxy shower)
+
+instance forall rs. (RecAll Maybe rs Eq, RecApplicative rs) => Eq (CoRec Identity rs) where
+  crA == crB = and . recordToList $ zipRecsWith f (toRec crA) (fieldToRec crB)
+    where
+      f :: forall a. (Dict Eq :. Maybe) a -> Maybe a -> Const Bool a
+      f (Compose (Dict a)) b = Const $ a == b
+      toRec = reifyConstraint (Proxy @Eq) . fieldToRec
+
+-- |The common case of a 'CoRec' with @f ~ 'Identity'@, i.e. a regular value.
+type Field = CoRec Identity
+
+-- |Inject a value @f r@ into a @'CoRec' f rs@ given that @r@ is one of the valid @rs@.
+--
+-- Equivalent to 'CoVal' the constructor, but exists to parallel 'field'.
+coRec :: r ∈ rs => f r -> CoRec f rs
+coRec = CoVal
+
+-- |Produce a prism for the given alternative of a 'CoRec', given a proxy to identify which @r@ you meant.
+coRecPrism :: (RecApplicative rs, r ∈ rs) => proxy r -> Prism' (CoRec f rs) (f r)
+coRecPrism proxy = prism' CoVal (getCompose . rget proxy . coRecToRec)
+
+-- |Inject a value @r@ into a @'Field' rs@ given that @r@ is one of the valid @rs@.
+--
+-- Equivalent to @'CoVal' . 'Identity'@.
+field :: r ∈ rs => r -> Field rs
+field = CoVal . Identity
+
+-- |Produce a prism for the given alternative of a 'Field', given a proxy to identify which @r@ you meant.
+fieldPrism :: (RecApplicative rs, r ∈ rs) => proxy r -> Prism' (Field rs) r
+fieldPrism proxy = coRecPrism proxy . dimap runIdentity (fmap Identity)
+
+-- |Apply an extraction to whatever @f r@ is contained in the given 'CoRec'.
+--
+-- For example @foldCoVal getConst :: CoRec (Const a) rs -> a@.
+foldCoVal :: (forall (r :: u). RElem r rs (RIndex r rs) => f r -> b) -> CoRec f rs -> b
+foldCoVal f (CoVal x) = f x
+{-# INLINE foldCoVal #-}
+
+-- |Map a @'CoRec' f@ to a @'CoRec' g@ using a natural transform from @f@ to @g@ (@forall x. f x -> g x@).
+mapCoRec :: (forall x. f x -> g x) -> CoRec f rs -> CoRec g rs
+mapCoRec f (CoVal x) = CoVal (f x)
+{-# INLINE mapCoRec #-}
+
+-- |Apply some kleisli on @h@ to the @f x@ contained in a @'CoRec' f@ and yank the @h@ outside. Like 'traverse' but for 'CoRec'.
+traverseCoRec :: Functor h => (forall x. f x -> h (g x)) -> CoRec f rs -> h (CoRec g rs)
+traverseCoRec f (CoVal x) = CoVal <$> f x
+{-# INLINE traverseCoRec #-}
+
+-- |Project a @'CoRec' f@ into a @'Rec' ('Maybe' ':.' f)@ where only the single @r@ held by the 'CoRec' is 'Just' in the resulting record, and all other
+-- fields are 'Nothing'.
+coRecToRec :: RecApplicative rs => CoRec f rs -> Rec (Maybe :. f) rs
+coRecToRec (CoVal a) = rput (Compose (Just a)) (rpure (Compose Nothing))
+{-# INLINE coRecToRec #-}
+
+-- |Project a 'Field' into a @'Rec' 'Maybe'@ where only the single @r@ held by the 'Field' is 'Just' in the resulting record, and all other
+-- fields are 'Nothing'.
+fieldToRec :: RecApplicative rs => Field rs -> Rec Maybe rs
+fieldToRec = rmap (fmap runIdentity . getCompose) . coRecToRec
+{-# INLINE fieldToRec #-}
+
+-- |Typeclass which allows folding ala 'foldMap' over a 'Rec', using a 'CoRec' as the accumulator.
+class FoldRec ss ts where
+  -- |Given some combining function, an initial value, and a record, visit each field of the record using the combining function to accumulate the
+  -- initial value or previous accumulation with the field of the record.
+  foldRec
+    :: (CoRec f ss -> CoRec f ss -> CoRec f ss)
+    -> CoRec f ss
+    -> Rec f ts
+    -> CoRec f ss
+
+instance FoldRec ss '[] where
+  foldRec _ z _ = z
+  {-# INLINE foldRec #-}
+
+instance (t ∈ ss, FoldRec ss ts) => FoldRec ss (t ': ts) where
+  foldRec f z (x :& xs) = foldRec f (z `f` CoVal x) xs
+  {-# INLINE foldRec #-}
+
+-- |'foldRec' for records with at least one field that doesn't require an initial value.
+foldRec1
+  :: FoldRec (r ': rs) rs
+  => (CoRec f (r ': rs) -> CoRec f (r ': rs) -> CoRec f (r ': rs))
+  -> Rec f (r ': rs)
+  -> CoRec f (r ': rs)
+foldRec1 f (x :& xs) = foldRec f (CoVal x) xs
+{-# INLINE foldRec1 #-}
+
+-- |Given a @'Rec' ('Maybe' ':.' f) rs@, yield a @Just coRec@ for the first field which is @Just@, or @Nothing@ if there are no @Just@ fields in the record.
+firstCoRec :: FoldRec rs rs => Rec (Maybe :. f) rs -> Maybe (CoRec f rs)
+firstCoRec RNil       = Nothing
+firstCoRec v@(x :& _) = traverseCoRec getCompose $ foldRec f (CoVal x) v
+  where
+    f c@(CoVal (Compose (Just _))) _ = c
+    f _                            c = c
+{-# INLINE firstCoRec #-}
+
+-- |Given a @'Rec' 'Maybe' rs@, yield a @Just field@ for the first field which is @Just@, or @Nothing@ if there are no @Just@ fields in the record.
+firstField :: FoldRec rs rs => Rec Maybe rs -> Maybe (Field rs)
+firstField = firstCoRec . rmap (Compose . fmap Identity)
+{-# INLINE firstField #-}
+
+-- |Given a @'Rec' ('Maybe' ':.' f) rs@, yield a @Just coRec@ for the last field which is @Just@, or @Nothing@ if there are no @Just@ fields in the record.
+lastCoRec :: FoldRec rs rs => Rec (Maybe :. f) rs -> Maybe (CoRec f rs)
+lastCoRec RNil       = Nothing
+lastCoRec v@(x :& _) = traverseCoRec getCompose $ foldRec f (CoVal x) v
+  where
+    f _ c@(CoVal (Compose (Just _))) = c
+    f c                            _ = c
+{-# INLINE lastCoRec #-}
+
+-- |Given a @'Rec' 'Maybe' rs@, yield a @Just field@ for the last field which is @Just@, or @Nothing@ if there are no @Just@ fields in the record.
+lastField :: FoldRec rs rs => Rec Maybe rs -> Maybe (Field rs)
+lastField = lastCoRec . rmap (Compose . fmap Identity)
+{-# INLINE lastField #-}
+
+-- |Helper newtype containing a function @a -> b@ but with the type parameters flipped so @Op b@ has a consistent codomain for a varying domain.
+newtype Op b a = Op { runOp :: a -> b }
+
+-- |Given a list of constraints @cs@ required to apply some function, apply the function to whatever value @r@ (not @f r@) which the 'CoRec' contains.
+onCoRec
+  :: forall (cs :: [* -> Constraint]) (f :: * -> *) (rs :: [*]) (b :: *) (proxy :: [* -> Constraint] -> *).
+     (AllHave cs rs, Functor f, RecApplicative rs)
+  => proxy cs
+  -> (forall (a :: *). HasInstances a cs => a -> b)
+  -> CoRec f rs
+  -> f b
+onCoRec p f (CoVal x) = go <$> x
+  where
+    go = runOp $ rget Proxy (reifyDicts p (\ _ -> Op f) :: Rec (Op b) rs)
+{-# INLINE onCoRec #-}
+
+-- |Given a list of constraints @cs@ required to apply some function, apply the function to whatever value @r@ which the 'Field' contains.
+onField
+  :: forall (cs :: [* -> Constraint]) (rs :: [*]) (b :: *) (proxy :: [* -> Constraint] -> *).
+     (AllHave cs rs, RecApplicative rs)
+  => proxy cs
+  -> (forall (a :: *). HasInstances a cs => a -> b)
+  -> Field rs
+  -> b
+onField p f x = runIdentity (onCoRec p f x)
+{-# INLINE onField #-}
+
+-- |Given some target type @r@ that's a possible value of @'Field' rs@, yield @Just@ if that is indeed the value being stored by the 'Field', or @Nothing@ if
+-- not.
+asA :: (r ∈ rs, RecApplicative rs) => proxy r -> Field rs -> Maybe r
+asA p = rget p . fieldToRec
+{-# INLINE asA #-}
+
+-- |An extractor function @f a -> b@ which can be passed to 'foldCoRec' to eliminate one possible alternative of a 'CoRec'.
+newtype Case' f b a = Case' { unCase' :: f a -> b }
+
+-- |A record of @Case'@ eliminators for each @r@ in @rs@ representing the pieces of a total function from @'CoRec' f@ to @b@.
+type Cases' f rs b = Rec (Case' f b) rs
+
+-- |Fold a @'CoRec' f@ using @Cases'@ which eliminate each possible value held by the 'CoRec', yielding the @b@ produced by whichever case matches.
+foldCoRec :: RecApplicative (r ': rs) => Cases' f (r ': rs) b -> CoRec f (r ': rs) -> b
+foldCoRec hs = go hs . coRecToRec
+  where
+    go :: Cases' f rs b -> Rec (Maybe :. f) rs -> b
+    go (Case' f :&  _) (Compose (Just x) :& _) = f x
+    go (Case' _ :& fs) (Compose Nothing  :& t) = go fs t
+    go RNil            RNil                    = error "foldCoRec should be provably total, isn't"
+    {-# INLINE go #-}
+{-# INLINE foldCoRec #-}
+
+-- |Fold a @'CoRec' f@ using @Cases'@ which eliminate each possible value held by the 'CoRec', yielding the @b@ produced by whichever case matches.
+--
+-- Equivalent to 'foldCoRec' but with its arguments flipped so it can be written @matchCoRec coRec $ cases@.
+matchCoRec :: RecApplicative (r ': rs) => CoRec f (r ': rs) -> Cases' f (r ': rs) b -> b
+matchCoRec = flip foldCoRec
+{-# INLINE matchCoRec #-}
+
+newtype Case b a = Case { unCase :: a -> b }
+type Cases rs b = Rec (Case b) rs
+
+-- |Fold a 'Field' using 'Cases' which eliminate each possible value held by the 'Field', yielding the @b@ produced by whichever case matches.
+foldField :: RecApplicative (r ': rs) => Cases (r ': rs) b -> Field (r ': rs) -> b
+foldField hs = foldCoRec (rmap (Case' . (. runIdentity) . unCase) hs)
+{-# INLINE foldField #-}
+
+-- |Fold a 'Field' using 'Cases' which eliminate each possible value held by the 'Field', yielding the @b@ produced by whichever case matches.
+--
+-- Equivalent to 'foldCoRec' but with its arguments flipped so it can be written @matchCoRec coRec $ cases@.
+matchField :: RecApplicative (r ': rs) => Field (r ': rs) -> Cases (r ': rs) b -> b
+matchField = flip foldField
+{-# INLINE matchField #-}

composite-base/src/Composite/Record.hs

+{-# LANGUAGE UndecidableInstances #-} -- argh, for ReifyNames
 module Composite.Record
   ( Rec((:&), RNil), Record
   , pattern (:*:), pattern (:^:)
   , (:->)(Val, getVal), valName, valWithName
   , RElem, rlens, rlens'
+  , AllHave, HasInstances, ValuesAllHave
+  , zipRecsWith, reifyDicts, recordToNonEmpty
+  , ReifyNames(reifyNames)
+  , RecWithContext(rmapWithContext)
   ) where
 
 import Control.Lens.TH (makeWrapped)
 import Data.Functor.Identity (Identity(Identity))
+import Data.Kind (Constraint)
+import Data.List.NonEmpty (NonEmpty((:|)))
 import Data.Proxy (Proxy(Proxy))
 import Data.Semigroup (Semigroup)
 import Data.String (IsString)
 import Data.Text (Text, pack)
-import Data.Vinyl (Rec((:&), RNil))
+import Data.Vinyl (Rec((:&), RNil), RecApplicative, recordToList, rpure)
 import qualified Data.Vinyl as Vinyl
+import Data.Vinyl.Functor (Compose(Compose), Const(Const), (:.))
+import Data.Vinyl.Lens (type (∈))
 import qualified Data.Vinyl.TypeLevel as Vinyl
 import Foreign.Storable (Storable)
 import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
@@ -155,3 +164,73 @@ rlens' proxy f =
   Vinyl.rlens proxy $ \ (fmap getVal -> fa) ->
     fmap Val <$> f fa
 {-# INLINE rlens' #-}
+
+-- | 'zipWith' for Rec's.
+zipRecsWith :: (forall a. f a -> g a -> h a) -> Rec f as -> Rec g as -> Rec h as
+zipRecsWith _ RNil      _         = RNil
+zipRecsWith f (r :& rs) (s :& ss) = f r s :& zipRecsWith f rs ss
+
+-- | Convert a provably nonempty @'Rec' ('Const' a) rs@ to a @'NonEmpty' a@.
+recordToNonEmpty :: Rec (Const a) (r ': rs) -> NonEmpty a
+recordToNonEmpty (Const a :& rs) = a :| recordToList rs
+
+-- |Type function which produces a constraint on @a@ for each constraint in @cs@.
+--
+-- For example, @HasInstances Int '[Eq, Ord]@ is equivalent to @(Eq Int, Ord Int)@.
+type family HasInstances (a :: u) (cs :: [u -> Constraint]) :: Constraint where
+  HasInstances a '[] = ()
+  HasInstances a (c ': cs) = (c a, HasInstances a cs)
+
+-- |Type function which produces the cross product of constraints @cs@ and types @as@.
+--
+-- For example, @AllHave '[Eq, Ord] '[Int, Text]@ is equivalent to @(Eq Int, Ord Int, Eq Text, Ord Text)@
+type family AllHave (cs :: [u -> Constraint]) (as :: [u]) :: Constraint where
+  AllHave cs      '[]  = ()
+  AllHave cs (a ': as) = (HasInstances a cs, AllHave cs as)
+
+-- |Type function which produces the cross product of constraints @cs@ and the values carried in a record @rs@.
+--
+-- For example, @ValuesAllHave '[Eq, Ord] '["foo" :-> Int, "bar" :-> Text]@ is equivalent to @(Eq Int, Ord Int, Eq Text, Ord Text)@
+type family ValuesAllHave (cs :: [u -> Constraint]) (as :: [u]) :: Constraint where
+  ValuesAllHave cs            '[]  = ()
+  ValuesAllHave cs (s :-> a ': as) = (HasInstances a cs, ValuesAllHave cs as)
+
+
+-- |Given a list of constraints @cs@, apply some function for each @r@ in the target record type @rs@ with proof that those constraints hold for @r@,
+-- generating a record with the result of each application.
+reifyDicts
+  :: forall (cs :: [u -> Constraint]) (f :: u -> *) (rs :: [u]) (proxy :: [u -> Constraint] -> *).
+     (AllHave cs rs, RecApplicative rs)
+  => proxy cs
+  -> (forall proxy' (a :: u). HasInstances a cs => proxy' a -> f a)
+  -> Rec f rs
+reifyDicts _ f = go (rpure (Const ()))
+  where
+    go :: forall (rs' :: [u]). AllHave cs rs' => Rec (Const ()) rs' -> Rec f rs'
+    go RNil = RNil
+    go ((_ :: Const () a) :& xs) = f (Proxy @a) :& go xs
+{-# INLINE reifyDicts #-}
+
+-- |Class which reifies the symbols of a record composed of ':->' fields as 'Text'.
+class ReifyNames (rs :: [*]) where
+  -- |Given a @'Rec' f rs@ where each @r@ in @rs@ is of the form @s ':->' a@, make a record which adds the 'Text' for each @s@.
+  reifyNames :: Rec f rs -> Rec ((,) Text :. f) rs
+
+instance ReifyNames '[] where
+  reifyNames _ = RNil
+
+instance forall (s :: Symbol) a (rs :: [*]). (KnownSymbol s, ReifyNames rs) => ReifyNames (s :-> a ': rs) where
+  reifyNames (fa :& rs) = Compose ((,) (pack $ symbolVal (Proxy @s)) fa) :& reifyNames rs
+
+-- |Class with 'Data.Vinyl.rmap' but which gives the natural transformation evidence that the value its working over is contained within the overall record @ss@.
+class RecWithContext (ss :: [*]) (ts :: [*]) where
+  -- |Apply a natural transformation from @f@ to @g@ to each field of the given record, except that the natural transformation can be mildly unnatural by having
+  -- evidence that @r@ is in @ss@.
+  rmapWithContext :: proxy ss -> (forall r. r ∈ ss => f r -> g r) -> Rec f ts -> Rec g ts
+
+instance RecWithContext ss '[] where
+  rmapWithContext _ _ _ = RNil
+
+instance forall r (ss :: [*]) (ts :: [*]). (r ∈ ss, RecWithContext ss ts) => RecWithContext ss (r ': ts) where
+  rmapWithContext proxy n (r :& rs) = n r :& rmapWithContext proxy n rs
+

composite-base/src/Control/Monad/Composite/Context.hs

@@ -134,7 +134,7 @@ instance MonadCont m => MonadCont (ContextT c m) where
   callCC f = ContextT $ \ r -> callCC $ \ c -> runContextT (f (ContextT . const . c)) r
 
 instance MonadThrow m => MonadThrow (ContextT c m) where
-  throwM e = ContextT $ \ r -> throwM e
+  throwM e = ContextT $ \ _ -> throwM e
 
 instance MonadCatch m => MonadCatch (ContextT c m) where
   catch m h = ContextT $ \ r -> catch (runContextT m r) (\ e -> runContextT (h e) r)

composite-ekg/composite-ekg.cabal

@@ -3,7 +3,7 @@
 -- see: https://github.com/sol/hpack
 
 name:           composite-ekg
-version:        0.3.1.0
+version:        0.4.0.0
 synopsis:       EKG Metrics for Vinyl/Frames records
 description:    Integration between EKG and Vinyl/Frames records allowing records holding registered metrics to be easily constructed from a type declaration.
 category:       Records

composite-ekg/package.nix

@@ -3,7 +3,7 @@
 }:
 mkDerivation {
   pname = "composite-ekg";
-  version = "0.3.1.0";
+  version = "0.4.0.0";
   src = ./.;
   libraryHaskellDepends = [
     base composite-base ekg ekg-core lens text vinyl