diff --git a/composite-base.cabal b/composite-base.cabal --- a/composite-base.cabal +++ b/composite-base.cabal @@ -1,9 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.18.1. +-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack +-- +-- hash: 0e7b65fc80c01f09bbc6c5d29da7e17ba09561542cffc9f1780105d9c863f54d name: composite-base -version: 0.5.3.0 +version: 0.5.4.0 synopsis: Shared utilities for composite-* packages. description: Shared helpers for the various composite packages. category: Records @@ -21,17 +23,17 @@ default-extensions: ConstraintKinds DataKinds FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses NamedFieldPuns OverloadedStrings PatternSynonyms PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns ghc-options: -Wall -O2 build-depends: - base >= 4.7 && < 5 - , exceptions - , lens - , monad-control - , mtl - , profunctors - , template-haskell - , text - , transformers - , transformers-base - , vinyl + base >=4.7 && <5 + , exceptions >=0.8.3 && <0.9 + , lens >=4.15.4 && <4.17 + , monad-control >=1.0.2.2 && <1.1 + , mtl >=2.2.1 && <2.3 + , profunctors >=5.2.1 && <5.3 + , template-haskell >=2.11.1.0 && <2.13 + , text >=1.2.2.2 && <1.3 + , transformers >=0.5.2.0 && <0.6 + , transformers-base >=0.4.4 && <0.5 + , vinyl >=0.5.3 && <0.8 exposed-modules: Composite Composite.CoRecord @@ -50,21 +52,22 @@ default-extensions: ConstraintKinds DataKinds FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses NamedFieldPuns OverloadedStrings PatternSynonyms PolyKinds RankNTypes RecordWildCards 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 - , exceptions - , lens - , monad-control - , mtl - , profunctors - , template-haskell - , text - , transformers - , transformers-base - , vinyl - , QuickCheck + QuickCheck + , base >=4.7 && <5 , composite-base + , exceptions >=0.8.3 && <0.9 , hspec + , lens >=4.15.4 && <4.17 + , monad-control >=1.0.2.2 && <1.1 + , mtl >=2.2.1 && <2.3 + , profunctors >=5.2.1 && <5.3 + , template-haskell >=2.11.1.0 && <2.13 + , text >=1.2.2.2 && <1.3 + , transformers >=0.5.2.0 && <0.6 + , transformers-base >=0.4.4 && <0.5 + , vinyl >=0.5.3 && <0.8 other-modules: RecordSpec THSpec + Paths_composite_base default-language: Haskell2010 diff --git a/src/Composite/CoRecord.hs b/src/Composite/CoRecord.hs --- a/src/Composite/CoRecord.hs +++ b/src/Composite/CoRecord.hs @@ -4,7 +4,7 @@ module Composite.CoRecord where import Prelude -import Composite.Record (AllHave, HasInstances, reifyDicts, zipRecsWith) +import Composite.Record (AllHave, HasInstances, (:->)(getVal, Val), reifyDicts, val, zipRecsWith) import Control.Lens (Prism', prism') import Data.Functor.Identity (Identity(Identity), runIdentity) import Data.Kind (Constraint) @@ -56,9 +56,19 @@ field :: r ∈ rs => r -> Field rs field = CoVal . Identity +-- |Inject a value @a@ into a @'Field' rs@ given that @s :-> a@ is one of the valid @rs@. +-- +-- Equivalent to @'CoVal' . 'Identity' . 'Val'@. +fieldVal :: forall s a rs proxy. s :-> a ∈ rs => proxy (s :-> a) -> a -> Field rs +fieldVal _ = CoVal . val @s + -- |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) + +-- |Produce a prism for the given @:->@ alternative of a 'Field', given a proxy to identify which @s :-> a@ you meant. +fieldValPrism :: (RecApplicative rs, s :-> a ∈ rs) => proxy (s :-> a) -> Prism' (Field rs) a +fieldValPrism proxy = coRecPrism proxy . dimap (getVal . runIdentity) (fmap (Identity . Val)) -- |Apply an extraction to whatever @f r@ is contained in the given 'CoRec'. -- diff --git a/src/Composite/Record.hs b/src/Composite/Record.hs --- a/src/Composite/Record.hs +++ b/src/Composite/Record.hs @@ -2,7 +2,7 @@ module Composite.Record ( Rec((:&), RNil), Record , pattern (:*:), pattern (:^:) - , (:->)(Val, getVal), val, valName, valWithName + , (:->)(Val, getVal), _Val, val, valName, valWithName , RElem, rlens, rlens' , AllHave, HasInstances, ValuesAllHave , zipRecsWith, reifyDicts, recordToNonEmpty @@ -11,6 +11,7 @@ , RDelete, RDeletable, rdelete ) where +import Control.Lens (Iso, iso) import Control.Lens.TH (makeWrapped) import Data.Functor.Identity (Identity(Identity)) import Data.Kind (Constraint) @@ -39,6 +40,9 @@ -- -- Recommended pronunciation: record val. newtype (:->) (s :: Symbol) a = Val { getVal :: a } + +_Val :: Iso (s :-> a) (s :-> b) a b +_Val = iso getVal Val makeWrapped ''(:->) diff --git a/src/Composite/TH.hs b/src/Composite/TH.hs --- a/src/Composite/TH.hs +++ b/src/Composite/TH.hs @@ -5,9 +5,9 @@ , withOpticsAndProxies ) where -import Composite.CoRecord (Field, fieldPrism) +import Composite.CoRecord (Field, fieldValPrism) import Composite.Record ((:->), Record, rlens) -import Control.Lens (Prism', _1, _head, _Wrapped, each, over, toListOf) +import Control.Lens (Prism', _1, _head, each, over, toListOf) import Data.Char (toLower) import Data.List (foldl') import Data.Maybe (catMaybes) @@ -17,7 +17,8 @@ import Data.Vinyl.Lens (type (∈)) import Language.Haskell.TH ( Q, newName, mkName, nameBase - , Body(NormalB), cxt, Dec(SigD, ValD), Exp(VarE), Name, Pat(VarP), Type(AppT, ConT, ForallT, VarT), TyVarBndr(PlainTV, KindedTV), varT + , Body(NormalB), cxt, Dec(PragmaD, SigD, ValD), Exp(VarE), Inline(Inlinable), Name, Pat(VarP), Phases(AllPhases), Pragma(InlineP), RuleMatch(FunLike) + , Type(AppT, ConT, ForallT, VarT), TyVarBndr(PlainTV, KindedTV), varT ) import Language.Haskell.TH.Lens (_TySynD) @@ -53,7 +54,8 @@ proxyType <- [t|Proxy $tySynType|] proxyVal <- [|Proxy|] pure - [ SigD proxyName proxyType + [ PragmaD (InlineP proxyName Inlinable FunLike AllPhases) + , SigD proxyName proxyType , ValD (VarP proxyName) (NormalB proxyVal) [] ] @@ -84,7 +86,7 @@ withLensesAndProxies :: Q [Dec] -> Q [Dec] withLensesAndProxies = withBoilerplate True False --- |Make 'fieldPrism' and 'Proxy' definitions for each of the @type@ synonyms in the given block of declarations. The prisms have the same names as the +-- |Make 'fieldValPrism' and 'Proxy' definitions for each of the @type@ synonyms in the given block of declarations. The prisms have the same names as the -- synonyms but prefixed with @_@. The proxies will have the same name as the synonym but with the first character lowercased and @_@ appended. -- -- For example: @@ -100,7 +102,7 @@ -- @ -- type FFoo = "foo" :-> Int -- _FFoo :: FFoo ∈ rs => Prism' (Field rs) Int --- _FFoo = fieldPrism fFoo_ . _Wrapped +-- _FFoo = fieldValPrism fFoo_ -- fFoo_ :: Proxy FFoo -- fFoo_ = Proxy -- @ @@ -111,7 +113,7 @@ withPrismsAndProxies :: Q [Dec] -> Q [Dec] withPrismsAndProxies = withBoilerplate False True --- |Make 'rlens', 'fieldPrism', and 'Proxy' definitions for each of the @type@ synonyms in the given block of declarations. +-- |Make 'rlens', 'fieldValPrism', and 'Proxy' definitions for each of the @type@ synonyms in the given block of declarations. -- The lenses have the same names as the synonyms but with the first letter lowercased, e.g. @FFoo@ becomes @fFoo@. -- The prisms have the same names as the synonyms but with @_@ prepended, e.g. @FFoo@ becomes @_FFoo@. -- The proxies have the same names as the synonyms but with the first letter lowercase and trailing @_@, e.g. @FFoo@ becomes @fFoo_@. @@ -131,7 +133,7 @@ -- fFoo :: FFoo ∈ rs => Lens' (Record rs) Int -- fFoo = rlens fFoo_ -- _FFoo :: FFoo ∈ rs => Prism' (Field rs) Int --- _FFoo = fieldPrism fFoo_ . _Wrapped +-- _FFoo = fieldValPrism fFoo_ -- fFoo_ :: Proxy FFoo -- fFoo_ = Proxy -- @ @@ -181,7 +183,8 @@ proxyType <- [t|Proxy $(pure fieldTypeApplied)|] proxyVal <- [|Proxy|] pure - [ SigD proxyName proxyType + [ PragmaD (InlineP proxyName Inlinable FunLike AllPhases) + , SigD proxyName proxyType , ValD (VarP proxyName) (NormalB proxyVal) [] ] @@ -202,7 +205,8 @@ rlensVal <- [| rlens $(pure proxyVal) |] pure - [ SigD lensName (ForallT lensBinders lensContext lensType) + [ PragmaD (InlineP lensName Inlinable FunLike AllPhases) + , SigD lensName (ForallT lensBinders lensContext lensType) , ValD (VarP lensName) (NormalB rlensVal) [] ] @@ -218,9 +222,10 @@ prismContext <- cxt [ [t| RecApplicative $rsTy |], [t| $(pure fieldTypeApplied) ∈ $rsTy |] ] prismType <- [t| Prism' (Field $rsTy) $(pure fieldValueType) |] - fieldPrismVal <- [| fieldPrism $(pure proxyVal) . _Wrapped |] + fieldPrismVal <- [| fieldValPrism $(pure proxyVal) |] pure - [ SigD prismName (ForallT prismBinders prismContext prismType) + [ PragmaD (InlineP prismName Inlinable FunLike AllPhases) + , SigD prismName (ForallT prismBinders prismContext prismType) , ValD (VarP prismName) (NormalB fieldPrismVal) [] ]