composite-base 0.4.0.0 → 0.4.1.0

raw patch · 4 files changed

+241/−40 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• composite-base.cabal +4/−3
• src/Composite/TH.hs +160/−37
• test/Main.hs +2/−0
• test/THSpec.hs +75/−0

@@ -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

@@ -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) []+    ]

@@ -1,7 +1,9 @@ import RecordSpec (recordSuite)+import ThSpec (thSuite) import Test.Hspec (hspec)  main :: IO () main = hspec $ do   recordSuite+  thSuite 

@@ -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++