diff --git a/composite-base.cabal b/composite-base.cabal --- a/composite-base.cabal +++ b/composite-base.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: composite-base -version: 0.4.0.0 +version: 0.4.1.0 synopsis: Shared utilities for composite-* packages. description: Shared helpers for the various composite packages. category: Records @@ -18,7 +18,7 @@ library hs-source-dirs: src - default-extensions: ConstraintKinds DataKinds FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings PatternSynonyms PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns + 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 @@ -45,7 +45,7 @@ main-is: Main.hs hs-source-dirs: test - default-extensions: ConstraintKinds DataKinds FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings PatternSynonyms PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns + 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 @@ -64,4 +64,5 @@ , hspec other-modules: RecordSpec + THSpec default-language: Haskell2010 diff --git a/src/Composite/TH.hs b/src/Composite/TH.hs --- a/src/Composite/TH.hs +++ b/src/Composite/TH.hs @@ -1,13 +1,24 @@ -module Composite.TH where +module Composite.TH + ( withProxies + , withLensesAndProxies + , withPrismsAndProxies + , withOpticsAndProxies + ) where -import Composite.Record (Record, rlens) -import Control.Lens (_1, _head, each, over, toListOf) +import Composite.CoRecord (Field, fieldPrism) +import Composite.Record ((:->), Record, rlens) +import Control.Lens (Prism', _1, _head, _Wrapped, each, over, toListOf) import Data.Char (toLower) +import Data.List (foldl') +import Data.Maybe (catMaybes) import Data.Monoid ((<>)) import Data.Proxy (Proxy(Proxy)) -import Data.Vinyl.Lens (RElem) -import Data.Vinyl.TypeLevel (RIndex) -import Language.Haskell.TH (Q, Body(NormalB), Dec(SigD, ValD), Exp(VarE), Name, Pat(VarP), Type(AppT, ConT), TyVarBndr, mkName, nameBase) +import Data.Vinyl (RecApplicative) +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 + ) import Language.Haskell.TH.Lens (_TySynD) -- |Make 'Proxy' definitions for each of the @type@ synonyms in the given block of declarations. The proxies have the same names as the synonyms but with @@ -47,7 +58,7 @@ ] -- |Make 'rlens' 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. The proxies have that name but with _ suffix. +-- but with the first letter lowercased. The proxies have that name but with @_@ suffix. -- -- For example: -- @@ -61,43 +72,155 @@ -- -- @ -- type FFoo = "foo" :-> Int --- fFoo :: RElem FFoo rs (RIndex FFoo rs) => Lens' (Record rs) Int +-- fFoo :: FFoo ∈ rs => Lens' (Record rs) Int -- fFoo = rlens fFoo_ -- fFoo_ :: Proxy FFoo -- fFoo_ = Proxy -- @ -- -- __Note:__ the trailing @|]@ of the quasi quote bracket has to be indented or a parse error will occur. +-- +-- This is equivalent to 'withOpticsAndProxies' but without the prisms. withLensesAndProxies :: Q [Dec] -> Q [Dec] -withLensesAndProxies qDecs = do +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 +-- synonyms but prefixed with @_@. The proxies will have the same name as the synonym but with the first character lowercased and @_@ appended. +-- +-- For example: +-- +-- @ +-- withPrismsAndProxies [d| +-- type FFoo = "foo" :-> Int +-- |] +-- @ +-- +-- Is equivalent to: +-- +-- @ +-- type FFoo = "foo" :-> Int +-- _FFoo :: FFoo ∈ rs => Prism' (Field rs) Int +-- _FFoo = fieldPrism fFoo_ . _Wrapped +-- fFoo_ :: Proxy FFoo +-- fFoo_ = Proxy +-- @ +-- +-- __Note:__ the trailing @|]@ of the quasi quote bracket has to be indented or a parse error will occur. +-- +-- This is equivalent to 'withOpticsAndProxies' but without the prisms. +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. +-- 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_@. +-- +-- For example: +-- +-- @ +-- withOpticsAndProxies [d| +-- type FFoo = "foo" :-> Int +-- |] +-- @ +-- +-- Is equivalent to: +-- +-- @ +-- type FFoo = "foo" :-> Int +-- fFoo :: FFoo ∈ rs => Lens' (Record rs) Int +-- fFoo = rlens fFoo_ +-- _FFoo :: FFoo ∈ rs => Prism' (Field rs) Int +-- _FFoo = fieldPrism fFoo_ . _Wrapped +-- fFoo_ :: Proxy FFoo +-- fFoo_ = Proxy +-- @ +-- +-- __Note:__ the trailing @|]@ of the quasi quote bracket has to be indented or a parse error will occur. +withOpticsAndProxies :: Q [Dec] -> Q [Dec] +withOpticsAndProxies = withBoilerplate True True + +data FieldDec = FieldDec + { fieldName :: Name + , fieldBinders :: [TyVarBndr] + , fieldTypeApplied :: Type + , fieldValueType :: Type + } +-- |TH splice which implements 'withLensesAndProxies', 'withPrismsAndProxies', and 'withOpticsAndProxies' +withBoilerplate :: Bool -> Bool -> Q [Dec] -> Q [Dec] +withBoilerplate generateLenses generatePrisms qDecs = do decs <- qDecs - proxyDecs <- traverse proxyDecForName $ toListOf (each . _TySynD . _1) decs - lensDecs <- traverse lensDecForName $ toListOf (each . _TySynD) decs - pure $ decs <> concat proxyDecs <> concat lensDecs - where - proxyNameForTypeName = mkName . (++ "_") . over _head toLower . nameBase - proxyDecForName :: Name -> Q [Dec] - proxyDecForName tySynName = do - let tySynType = pure $ ConT tySynName - proxyName = proxyNameForTypeName tySynName - proxyType <- [t|Proxy $tySynType|] - proxyVal <- [|Proxy|] - pure - [ SigD proxyName proxyType - , ValD (VarP proxyName) (NormalB proxyVal) [] - ] + let fieldDecs = catMaybes . map fieldDecMay . toListOf (each . _TySynD) $ decs - lensDecForName :: (Name, [TyVarBndr], Type) -> Q [Dec] - lensDecForName (tySynName, _, AppT (AppT (ConT (nameBase -> ":->")) _) valTy) = do -- FIXME stop doing name hacks - let tySynType = pure $ ConT tySynName - proxyName = proxyNameForTypeName tySynName - proxyVal = VarE proxyName - lensName = mkName . over _head toLower . nameBase $ tySynName - lensType <- [t|forall f rs. (Functor f, RElem $tySynType rs (RIndex $tySynType rs)) => ($(pure valTy) -> f $(pure valTy)) -> Record rs -> f (Record rs)|] - rlensVal <- [|rlens $(pure proxyVal)|] - pure - [ SigD lensName lensType - , ValD (VarP lensName) (NormalB rlensVal) [] ] - lensDecForName (tySynName, _, _) = - fail $ "Can only make lenses and proxies for type synonyms like type FField = \"field\" :-> Type, but " <> nameBase tySynName <> " has some other form of type" + proxyDecs <- traverse proxyDecFor fieldDecs + lensDecs <- if generateLenses then traverse lensDecFor fieldDecs else pure [] + prismDecs <- if generatePrisms then traverse prismDecFor fieldDecs else pure [] + + pure $ decs <> concat proxyDecs <> concat lensDecs <> concat prismDecs + +fieldDecMay :: (Name, [TyVarBndr], Type) -> Maybe FieldDec +fieldDecMay (fieldName, fieldBinders, ty) = case ty of + AppT (AppT (ConT n) _) fieldValueType | n == ''(:->) -> + let fieldTypeApplied = foldl' AppT (ConT fieldName) (map binderTy fieldBinders) + binderTy (PlainTV n') = VarT n' + binderTy (KindedTV n' _) = VarT n' + in Just $ FieldDec {..} + _ -> + Nothing + +lensNameFor, prismNameFor, proxyNameFor :: Name -> Name +lensNameFor = mkName . over _head toLower . nameBase +prismNameFor = mkName . ("_" ++) . nameBase +proxyNameFor = mkName . (++ "_") . over _head toLower . nameBase + +proxyDecFor :: FieldDec -> Q [Dec] +proxyDecFor (FieldDec { fieldName, fieldTypeApplied }) = do + let proxyName = proxyNameFor fieldName + + proxyType <- [t|Proxy $(pure fieldTypeApplied)|] + proxyVal <- [|Proxy|] + pure + [ SigD proxyName proxyType + , ValD (VarP proxyName) (NormalB proxyVal) [] + ] + +lensDecFor :: FieldDec -> Q [Dec] +lensDecFor (FieldDec {..}) = do + f <- newName "f" + rs <- newName "rs" + + let fTy = varT f + rsTy = varT rs + proxyName = proxyNameFor fieldName + lensName = lensNameFor fieldName + proxyVal = VarE proxyName + lensBinders = fieldBinders ++ [PlainTV f, PlainTV rs] + + lensContext <- cxt [ [t| Functor $fTy |], [t| $(pure fieldTypeApplied) ∈ $rsTy |] ] + lensType <- [t| ($(pure fieldValueType) -> $fTy $(pure fieldValueType)) -> (Record $rsTy -> $fTy (Record $rsTy)) |] + rlensVal <- [| rlens $(pure proxyVal) |] + + pure + [ SigD lensName (ForallT lensBinders lensContext lensType) + , ValD (VarP lensName) (NormalB rlensVal) [] + ] + +prismDecFor :: FieldDec -> Q [Dec] +prismDecFor (FieldDec {..}) = do + rs <- newName "rs" + + let rsTy = varT rs + proxyName = proxyNameFor fieldName + prismName = prismNameFor fieldName + proxyVal = VarE proxyName + prismBinders = fieldBinders ++ [PlainTV rs] + + prismContext <- cxt [ [t| RecApplicative $rsTy |], [t| $(pure fieldTypeApplied) ∈ $rsTy |] ] + prismType <- [t| Prism' (Field $rsTy) $(pure fieldValueType) |] + fieldPrismVal <- [| fieldPrism $(pure proxyVal) . _Wrapped |] + + pure + [ SigD prismName (ForallT prismBinders prismContext prismType) + , ValD (VarP prismName) (NormalB fieldPrismVal) [] + ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,7 +1,9 @@ import RecordSpec (recordSuite) +import ThSpec (thSuite) import Test.Hspec (hspec) main :: IO () main = hspec $ do recordSuite + thSuite diff --git a/test/THSpec.hs b/test/THSpec.hs new file mode 100644 --- /dev/null +++ b/test/THSpec.hs @@ -0,0 +1,75 @@ +module ThSpec where + +import Composite.CoRecord (Field, field) +import Composite.Record ((:->)(Val), Rec(RNil), Record, pattern (:*:), rlens) +import Composite.TH +import Control.Lens (preview, review, view) +import Test.Hspec (Spec, describe, it, shouldBe) + +-- test that withLensesAndProxies works in the simple case +withLensesAndProxies [d| + type FConcrete = "foo" :-> Int + |] + +-- test that withLensesAndProxies ignores non-conformant shapes (without :->) in the declaration +withLensesAndProxies [d| + type ConcreteRec = '[FConcrete] + type FConcreteRec = "foo" :-> Record ConcreteRec + |] + +-- test that withLensesAndProxies works with parameterized fields (and unrelated types) +withLensesAndProxies [d| + type FParameterized a = "foo" :-> a + type ParameterizedRec a = '[FParameterized a] + type FParameterizedRec a = "foo" :-> Record (ParameterizedRec a) + |] + +-- test that withOpticsAndProxies works in the simple case +withOpticsAndProxies [d| + type FOptical = "foo" :-> Int + |] + +thSuite :: Spec +thSuite = do + describe "withLensesAndProxies" $ do + it "works for simple fields" $ do + let r :: Record '[FConcrete] + r = 123 :*: RNil + view fConcrete r `shouldBe` 123 + view (rlens fConcrete_) r `shouldBe` 123 + + it "works for declaration blocks with non-fields in them" $ do + let r :: Record ConcreteRec + r = 123 :*: RNil + r2 :: Record '[FConcreteRec] + r2 = r :*: RNil + view ( fConcreteRec . fConcrete) r2 `shouldBe` 123 + view (rlens fConcreteRec_ . fConcrete) r2 `shouldBe` 123 + + it "works with parameterized fields" $ do + let ra :: Record '[FParameterized Int] + ra = 123 :*: RNil + ra2 :: Record '[FParameterizedRec Int] + ra2 = ra :*: RNil + rb :: Record '[FParameterized Bool] + rb = True :*: RNil + rb2 :: Record '[FParameterizedRec Bool] + rb2 = rb :*: RNil + + view ( (fParameterized @Int )) ra `shouldBe` 123 + view ( rlens (fParameterized_ @Int )) ra `shouldBe` 123 + view ( (fParameterized @Bool)) rb `shouldBe` True + view ( rlens (fParameterized_ @Bool)) rb `shouldBe` True + view ( (fParameterizedRec @Int ). (fParameterized @Int )) ra2 `shouldBe` 123 + view (rlens (fParameterizedRec_ @Int ). (fParameterized @Int )) ra2 `shouldBe` 123 + view ( (fParameterizedRec @Bool). (fParameterized @Bool)) rb2 `shouldBe` True + view (rlens (fParameterizedRec_ @Bool). (fParameterized @Bool)) rb2 `shouldBe` True + + describe "withOpticsAndProxies" $ do + it "works for simple fields" $ do + let f :: Field '[FOptical] + f = field (Val 123 :: FOptical) + preview _FOptical f `shouldBe` Just 123 + review _FOptical 123 `shouldBe` f + +