domain-optics (empty) → 0.1
raw patch · 8 files changed
+403/−0 lines, 8 filesdep +basedep +domaindep +domain-coresetup-changed
Dependencies added: base, domain, domain-core, domain-optics, optics, optics-core, rerebase, template-haskell, template-haskell-compat-v0208, text, th-lego, unordered-containers
Files
- LICENSE +22/−0
- Setup.hs +2/−0
- demo/Main.hs +53/−0
- domain-optics.cabal +47/−0
- library/DomainOptics.hs +16/−0
- library/DomainOptics/InstanceDecs.hs +37/−0
- library/DomainOptics/Prelude.hs +84/−0
- library/DomainOptics/Util/OpticsTH.hs +142/−0
+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2020 Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ demo/Main.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE+ QuasiQuotes, TemplateHaskell,+ FlexibleInstances, MultiParamTypeClasses,+ DataKinds, TypeFamilies,+ UndecidableInstances+ #-}+module Main+where++import Prelude+import Domain+import DomainOptics+import Optics+++main =+ return ()++declare Nothing labelOpticDeriver+ [schema|++ ServiceAddress:+ sum:+ network: NetworkAddress+ local: FilePath++ NetworkAddress:+ product:+ protocol: TransportProtocol+ host: Host+ port: Word16++ TransportProtocol:+ enum:+ - tcp+ - udp++ Host:+ sum:+ ip: Ip+ name: Text++ Ip:+ sum:+ v4: Word32+ v6: Word128++ Word128:+ product:+ part1: Word64+ part2: Word64++ |]
+ domain-optics.cabal view
@@ -0,0 +1,47 @@+name: domain-optics+version: 0.1+synopsis: Integration of domain with optics+homepage: https://github.com/nikita-volkov/domain-optics+bug-reports: https://github.com/nikita-volkov/domain-optics/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2020 Nikita Volkov+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: git://github.com/nikita-volkov/domain-optics.git++library+ hs-source-dirs: library+ default-extensions: BangPatterns, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DerivingVia, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedLabels, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples+ default-language: Haskell2010+ exposed-modules:+ DomainOptics+ other-modules:+ DomainOptics.InstanceDecs+ DomainOptics.Prelude+ DomainOptics.Util.OpticsTH+ build-depends:+ base >=4.12 && <5,+ domain-core >=0.1 && <0.2,+ optics-core >=0.3.0.1 && <0.4,+ text >=1 && <2,+ template-haskell >=2.14 && <3,+ template-haskell-compat-v0208 >=0.1.5 && <0.2,+ th-lego >=0.2.1 && <0.3,+ unordered-containers >=0.2.10 && <0.3++test-suite demo+ type: exitcode-stdio-1.0+ hs-source-dirs: demo+ main-is: Main.hs+ default-language: Haskell2010+ build-depends:+ domain,+ domain-optics,+ optics,+ rerebase >=1.9 && <2
+ library/DomainOptics.hs view
@@ -0,0 +1,16 @@+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.++Requires to have the @UndecidableInstances@ extension enabled.+-}+labelOpticDeriver =+ Deriver.effectless InstanceDecs.labelOptic
+ library/DomainOptics/InstanceDecs.hs view
@@ -0,0 +1,37 @@+module DomainOptics.InstanceDecs+where++import DomainOptics.Prelude+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+ Model.ProductTypeDef members ->+ zipWith zipper (enumFrom 0) members+ where+ membersLength =+ length members+ zipper fieldIndex (fieldName, fieldType) =+ OpticsTH.fieldLensLabelOpticInstanceDec+ (textTyLit fieldName)+ (textName typeName)+ (DomainTH.typeType fieldType)+ membersLength+ fieldIndex+ Model.SumTypeDef structure ->+ fmap mapper structure+ where+ mapper (memberName, subTypes) =+ OpticsTH.prismLabelOpticInstanceDec+ (textTyLit memberName)+ (textName typeName)+ (DomainTH.sumConstructorName typeName memberName)+ (fmap DomainTH.typeType subTypes)
+ library/DomainOptics/Prelude.hs view
@@ -0,0 +1,84 @@+module DomainOptics.Prelude+( + module Exports,+ showAsText,+)+where++-- base+-------------------------+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.Fail as Exports+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.ST as Exports+import Data.Bifunctor as Exports+import Data.Bits as Exports+import Data.Bool as Exports+import Data.Char as Exports+import Data.Coerce as Exports+import Data.Complex as Exports+import Data.Data as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+import Data.Fixed as Exports+import Data.Foldable as Exports hiding (toList)+import Data.Function as Exports hiding (id, (.))+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.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.Maybe as Exports+import Data.Monoid as Exports hiding (Alt)+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports hiding ((%))+import Data.STRef as Exports+import Data.String as Exports+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.Unique as Exports+import Data.Version as Exports+import Data.Void as Exports+import Data.Word as Exports+import Debug.Trace as Exports+import Foreign.ForeignPtr as Exports+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.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)+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+import System.Mem as Exports+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 Unsafe.Coerce as Exports++-- text+-------------------------+import Data.Text as Exports (Text)++showAsText :: Show a => a -> Text+showAsText = show >>> fromString
+ library/DomainOptics/Util/OpticsTH.hs view
@@ -0,0 +1,142 @@+{-|+TH utils for optics.+-}+module DomainOptics.Util.OpticsTH+where++import DomainOptics.Prelude+import Language.Haskell.TH+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 =+ AppE (VarE 'Optics.lensVL) (Lambdas.vlLens conName numMembers index)++productLensE :: Name -> Int -> Int -> Exp+productLensE conName numMembers index =+ AppE (AppE (VarE 'Optics.lens) getterE) setterE+ where+ getterE =+ Lambdas.productGetter conName numMembers index+ setterE = + Lambdas.productSetter conName numMembers index++{-|+>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)) []+ ]))++{-|+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+ ]++emptyConLensE :: Name -> Exp+emptyConLensE conName =+ 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)) []+ ])+ setterE =+ LamE [VarP aName, VarP bName] (CondE (VarE bName) (ConE conName) (VarE aName))++namedFieldLensE :: Name -> Exp+namedFieldLensE fieldName =+ AppE (AppE (VarE 'Optics.lens) getterE) setterE+ where+ getterE =+ VarE fieldName+ setterE = + Lambdas.namedFieldSetter fieldName+++-- * LabelOptic instances+-------------------------++{-|+General definition helper.+-}+labelOpticInstanceD :: TyLit -> Name -> Name -> Type -> Exp -> Dec+labelOpticInstanceD lit opticType typeName aAndBType exp =+ InstanceD Nothing cxt headType [labelOpticDec]+ where+ cxt =+ [aPred, bPred, cPred]+ where+ aPred =+ eqConstraintT aName aAndBType+ bPred =+ eqConstraintT bName aAndBType+ cPred =+ eqConstraintT cName (ConT opticType)+ headType =+ 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)+-}+fieldLensLabelOpticInstanceDec :: TyLit -> Name -> Type -> Int -> Int -> Dec+fieldLensLabelOpticInstanceDec lit typeName aAndBType numMembers index =+ 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)+-}+prismLabelOpticInstanceDec :: TyLit -> Name -> Name -> [Type] -> Dec+prismLabelOpticInstanceDec lit typeName conName memberTypes =+ labelOpticInstanceD lit ''Optics.A_Prism typeName aAndBType exp+ where+ aAndBType =+ appliedTupleOrSingletonT memberTypes+ exp =+ prismE conName (length memberTypes)++emptyConLensLabelOpticInstanceDec :: TyLit -> Name -> Name -> Dec+emptyConLensLabelOpticInstanceDec lit typeName conName =+ labelOpticInstanceD lit ''Optics.A_Lens typeName aAndBType exp+ where+ aAndBType =+ ConT ''Bool+ exp =+ emptyConLensE conName