domain-optics 0.1.0.1 → 0.1.0.2
raw patch · 6 files changed
+105/−113 lines, 6 filesdep ~th-legoPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: th-lego
API changes (from Hackage documentation)
Files
- demo/Main.hs +13/−11
- domain-optics.cabal +4/−3
- library/DomainOptics.hs +7/−10
- library/DomainOptics/InstanceDecs.hs +4/−9
- library/DomainOptics/Prelude.hs +16/−22
- library/DomainOptics/Util/OpticsTH.hs +61/−58
demo/Main.hs view
@@ -1,22 +1,24 @@-{-# LANGUAGE- QuasiQuotes, TemplateHaskell,- FlexibleInstances, MultiParamTypeClasses,- DataKinds, TypeFamilies,- UndecidableInstances- #-}-module Main-where+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -import Prelude+module Main where+ import Domain import DomainOptics import Optics-+import Prelude main = return () -declare Nothing labelOpticDeriver+declare+ Nothing+ labelOpticDeriver [schema| ServiceAddress:
domain-optics.cabal view
@@ -1,5 +1,7 @@+cabal-version: 3.0+ name: domain-optics-version: 0.1.0.1+version: 0.1.0.2 synopsis: Integration of domain with optics homepage: https://github.com/nikita-volkov/domain-optics bug-reports: https://github.com/nikita-volkov/domain-optics/issues@@ -9,7 +11,6 @@ license: MIT license-file: LICENSE build-type: Simple-cabal-version: >=1.10 source-repository head type: git@@ -32,7 +33,7 @@ text >=1 && <2, template-haskell >=2.14 && <3, template-haskell-compat-v0208 >=0.1.5 && <0.2,- th-lego >=0.2.1 && <0.3,+ th-lego >=0.2.1 && <0.4, unordered-containers >=0.2.10 && <0.3 test-suite demo
library/DomainOptics.hs view
@@ -1,16 +1,13 @@-module DomainOptics-where+module DomainOptics where -import DomainOptics.Prelude import qualified DomainCore.Deriver as Deriver import qualified DomainOptics.InstanceDecs as InstanceDecs---{-|-Generates 'LabelOptic' instances for enums, products and sums,-automatically choosing the appropriate optic type.+import DomainOptics.Prelude -Requires to have the @UndecidableInstances@ extension enabled.--}+-- |+-- Generates 'LabelOptic' instances for enums, products and sums,+-- automatically choosing the appropriate optic type.+--+-- Requires to have the @UndecidableInstances@ extension enabled. labelOpticDeriver = Deriver.effectless InstanceDecs.labelOptic
library/DomainOptics/InstanceDecs.hs view
@@ -1,16 +1,11 @@-module DomainOptics.InstanceDecs-where+module DomainOptics.InstanceDecs where +import qualified DomainCore.Model as Model+import qualified DomainCore.TH as DomainTH import DomainOptics.Prelude+import qualified DomainOptics.Util.OpticsTH as OpticsTH import Language.Haskell.TH.Syntax import THLego.Helpers-import qualified DomainOptics.Util.OpticsTH as OpticsTH-import qualified DomainCore.Model as Model-import qualified DomainCore.TH as DomainTH----- *-------------------------- labelOptic (Model.TypeDec typeName typeDef) = case typeDef of
library/DomainOptics/Prelude.hs view
@@ -1,21 +1,18 @@ module DomainOptics.Prelude-( - module Exports,- showAsText,-)+ ( module Exports,+ showAsText,+ ) where --- base---------------------------import Control.Applicative as Exports hiding (WrappedArrow(..))+import Control.Applicative as Exports hiding (WrappedArrow (..)) import Control.Arrow as Exports hiding (first, second) import Control.Category as Exports import Control.Concurrent as Exports import Control.Exception as Exports-import Control.Monad as Exports hiding (fail, mapM_, sequence_, forM_, msum, mapM, sequence, forM)-import Control.Monad.IO.Class as Exports+import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_) import Control.Monad.Fail as Exports import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.IO.Class as Exports import Control.Monad.ST as Exports import Data.Bifunctor as Exports import Data.Bits as Exports@@ -32,11 +29,11 @@ import Data.Functor as Exports import Data.Functor.Compose as Exports import Data.Functor.Contravariant as Exports-import Data.Int as Exports import Data.IORef as Exports+import Data.Int as Exports import Data.Ix as Exports-import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')-import Data.List.NonEmpty as Exports (NonEmpty(..))+import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)+import Data.List.NonEmpty as Exports (NonEmpty (..)) import Data.Maybe as Exports import Data.Monoid as Exports hiding (Alt) import Data.Ord as Exports@@ -44,6 +41,7 @@ import Data.Ratio as Exports hiding ((%)) import Data.STRef as Exports import Data.String as Exports+import Data.Text as Exports (Text) import Data.Traversable as Exports import Data.Tuple as Exports import Data.Unique as Exports@@ -55,13 +53,12 @@ import Foreign.Ptr as Exports import Foreign.StablePtr as Exports import Foreign.Storable as Exports-import GHC.Conc as Exports hiding (orElse, withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)-import GHC.Exts as Exports (IsList(..), lazy, inline, sortWith, groupWith)+import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)+import GHC.Exts as Exports (IsList (..), groupWith, inline, lazy, sortWith) import GHC.Generics as Exports (Generic) import GHC.IO.Exception as Exports import GHC.OverloadedLabels as Exports import Numeric as Exports-import Prelude as Exports hiding ((%), fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.)) import System.Environment as Exports import System.Exit as Exports import System.IO as Exports (Handle, hClose)@@ -71,14 +68,11 @@ import System.Mem.StableName as Exports import System.Timeout as Exports import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)-import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)-import Text.Printf as Exports (printf, hPrintf)-import Text.Read as Exports (Read(..), readMaybe, readEither)+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe) import Unsafe.Coerce as Exports---- text---------------------------import Data.Text as Exports (Text)+import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (%), (.)) showAsText :: Show a => a -> Text showAsText = show >>> fromString
library/DomainOptics/Util/OpticsTH.hs view
@@ -1,19 +1,15 @@-{-|-TH utils for optics.--}-module DomainOptics.Util.OpticsTH-where+-- |+-- TH utils for optics.+module DomainOptics.Util.OpticsTH where +import qualified Data.Text as Text import DomainOptics.Prelude import Language.Haskell.TH+import qualified Optics.Core as Optics import THLego.Helpers import qualified THLego.Lambdas as Lambdas-import qualified Optics.Core as Optics-import qualified Data.Text as Text - -- * Optics-------------------------- productLensVlE :: Name -> Int -> Int -> Exp productLensVlE conName numMembers index =@@ -25,32 +21,35 @@ where getterE = Lambdas.productGetter conName numMembers index- setterE = + setterE = Lambdas.productSetter conName numMembers index -{-|->prism' Dog (\ case-> Dog a -> Just a-> _ -> Nothing)--}+-- |+-- >prism' Dog (\ case+-- > Dog a -> Just a+-- > _ -> Nothing) singleMemberPrismE :: Name -> Exp singleMemberPrismE conName =- AppE (AppE (VarE 'Optics.prism') (ConE conName))- (LamE [VarP aName] (CaseE (VarE aName) [- Match (ConP conName [VarP bName]) (NormalB (AppE (ConE 'Just) (VarE bName))) []- ,- Match WildP (NormalB (ConE 'Nothing)) []- ]))+ AppE+ (AppE (VarE 'Optics.prism') (ConE conName))+ ( LamE+ [VarP aName]+ ( CaseE+ (VarE aName)+ [ Match (ConP conName [VarP bName]) (NormalB (AppE (ConE 'Just) (VarE bName))) [],+ Match WildP (NormalB (ConE 'Nothing)) []+ ]+ )+ ) -{-|-Prism to a tuple of members.--}+-- |+-- Prism to a tuple of members. prismE :: Name -> Int -> Exp prismE conName numMembers =- multiAppE (VarE 'Optics.prism') [- Lambdas.tupleOrSingletonToProduct conName numMembers- ,- Lambdas.adtConstructorNarrower conName numMembers+ multiAppE+ (VarE 'Optics.prism')+ [ Lambdas.tupleOrSingletonToProduct conName numMembers,+ Lambdas.adtConstructorNarrower conName numMembers ] emptyConLensE :: Name -> Exp@@ -58,11 +57,14 @@ AppE (AppE (VarE 'Optics.lens) getterE) setterE where getterE =- LamE [VarP aName] (CaseE (VarE aName) [- Match (ConP conName []) (NormalB (ConE 'True)) []- ,- Match WildP (NormalB (ConE 'False)) []- ])+ LamE+ [VarP aName]+ ( CaseE+ (VarE aName)+ [ Match (ConP conName []) (NormalB (ConE 'True)) [],+ Match WildP (NormalB (ConE 'False)) []+ ]+ ) setterE = LamE [VarP aName, VarP bName] (CondE (VarE bName) (ConE conName) (VarE aName)) @@ -72,16 +74,13 @@ where getterE = VarE fieldName- setterE = + setterE = Lambdas.namedFieldSetter fieldName - -- * LabelOptic instances-------------------------- -{-|-General definition helper.--}+-- |+-- General definition helper. labelOpticInstanceD :: TyLit -> Name -> Name -> Type -> Exp -> Dec labelOpticInstanceD lit opticType typeName aAndBType exp = InstanceD Nothing cxt headType [labelOpticDec]@@ -96,33 +95,37 @@ cPred = eqConstraintT cName (ConT opticType) headType =- foldl' AppT (ConT ''Optics.LabelOptic) [- LitT lit,- VarT cName,- ConT typeName,- ConT typeName,- VarT aName,- VarT bName+ foldl'+ AppT+ (ConT ''Optics.LabelOptic)+ [ LitT lit,+ VarT cName,+ ConT typeName,+ ConT typeName,+ VarT aName,+ VarT bName ] labelOpticDec = FunD 'Optics.labelOptic [Clause [] (NormalB exp) []] -{-|->instance (k ~ A_Lens, a ~ String, b ~ String) => LabelOptic "name" k Human Human a b where-> labelOptic = lensVL $ \f s -> (\v -> s { humanName = v }) <$> f (humanName s)--}+-- |+-- >instance (k ~ A_Lens, a ~ String, b ~ String) => LabelOptic "name" k Human Human a b where+-- > labelOptic = lensVL $ \f s -> (\v -> s { humanName = v }) <$> f (humanName s) fieldLensLabelOpticInstanceDec :: TyLit -> Name -> Type -> Int -> Int -> Dec fieldLensLabelOpticInstanceDec lit typeName aAndBType numMembers index =- labelOpticInstanceD lit ''Optics.A_Lens typeName aAndBType+ labelOpticInstanceD+ lit+ ''Optics.A_Lens+ typeName+ aAndBType (productLensVlE typeName numMembers index) -{-|->instance (k ~ A_Prism, a ~ String, b ~ String) => LabelOptic "dog" k Pet Pet a b where-> labelOptic =-> prism' Dog (\ case-> Dog a -> Just a-> _ -> Nothing)--}+-- |+-- >instance (k ~ A_Prism, a ~ String, b ~ String) => LabelOptic "dog" k Pet Pet a b where+-- > labelOptic =+-- > prism' Dog (\ case+-- > Dog a -> Just a+-- > _ -> Nothing) prismLabelOpticInstanceDec :: TyLit -> Name -> Name -> [Type] -> Dec prismLabelOpticInstanceDec lit typeName conName memberTypes = labelOpticInstanceD lit ''Optics.A_Prism typeName aAndBType exp