lens-sop (empty) → 0.1.0.0
raw patch · 6 files changed
+523/−0 lines, 6 filesdep +basedep +fclabelsdep +generics-sopsetup-changed
Dependencies added: base, fclabels, generics-sop, transformers
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- lens-sop.cabal +64/−0
- src/Generics/SOP/Lens.hs +119/−0
- src/Generics/SOP/Lens/Computed.hs +237/−0
- src/Generics/SOP/Lens/Named.hs +74/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014, Well-Typed LLP, Edsko de Vries, Andres Löh+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lens-sop.cabal view
@@ -0,0 +1,64 @@+name: lens-sop+version: 0.1.0.0+synopsis: Computing lenses generically using generics-sop+description:+ This library contains a definition of generalized lenses that are built+ on top of the @<https://hackage.haskell.org/fclabels fclabels>@ package.+ .+ It also contains SOP-style generic functions (based on the+ @<https://hackage.haskell.org/generics-sop generics-sop>@ package) that+ compute lenses for a given record type. Generalized lenses for the+ SOP representation types are also provided.+ .+ Furthermore, a generic function is provided that computes a lens from+ a given (string-based) path specification.+ .+license: BSD3+license-file: LICENSE+author: Edsko de Vries <edsko@well-typed.com>, Andres Löh <andres@well-typed.com>+maintainer: edsko@well-typed.com+category: Generics+build-type: Simple+cabal-version: >=1.10+tested-with: GHC == 7.6.3, GHC == 7.8.2++source-repository head+ type: git+ location: https://github.com/well-typed/lens-sop++library+ exposed-modules: Generics.SOP.Lens+ Generics.SOP.Lens.Named+ Generics.SOP.Lens.Computed+ build-depends: base >= 4.6 && < 5,+ generics-sop >= 0.1 && < 2,+ fclabels >= 2.0 && < 2.1,+ transformers >= 0.3 && < 0.4+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall+ default-extensions: ScopedTypeVariables+ TypeFamilies+ RankNTypes+ TypeOperators+ GADTs+ ConstraintKinds+ MultiParamTypeClasses+ TypeSynonymInstances+ FlexibleInstances+ FlexibleContexts+ DeriveFunctor+ DeriveFoldable+ DeriveTraversable+ DefaultSignatures+ KindSignatures+ DataKinds+ FunctionalDependencies+ if impl (ghc >= 7.8)+ default-extensions: AutoDeriveTypeable+ other-extensions: OverloadedStrings+ OverlappingInstances+ PolyKinds+ UndecidableInstances+ TemplateHaskell+ CPP
+ src/Generics/SOP/Lens.hs view
@@ -0,0 +1,119 @@+-- | Generalized lenses+--+-- Intended to be imported qualified+--+-- > import Generics.SOP.Lens as GLens+module Generics.SOP.Lens (+ -- * Generalized lenses+ GLens+ , lens+ , get+ , modify+ , set+ -- * Conversion+ , fromLens+ , fromIso+ , toLens+ -- * Generic computation of lenses for record type+ , glenses+ -- * Labels for the representation types+ , np+ , rep+ , sop+ , head+ , tail+ , i+ ) where++import Prelude hiding (id, (.), curry, uncurry, const, head, tail)+import Control.Arrow+import Control.Category+import Data.Label.Mono (Lens)+import Data.Label.Point (Iso(..))+import qualified Data.Label.Mono as Lens++import Generics.SOP++{-------------------------------------------------------------------------------+ Generalized lens using two categories+-------------------------------------------------------------------------------}++-- | GLens generalizes a monomorphic lens by allowing for different categories+-- for the getter and modifier+data GLens r w a b = GLens (r a b) (w (w b b, a) a)++instance (Category r, ArrowApply w) => Category (GLens r w) where+ id = GLens id app+ (GLens f m) . (GLens g n) = GLens (f . g) (uncurry (curry n . curry m))++lens :: r a b -> w (w b b, a) a -> GLens r w a b+lens = GLens++get :: GLens r w a b -> r a b+get (GLens f _) = f++modify :: GLens r w a b -> w (w b b, a) a+modify (GLens _ g) = g++set :: Arrow w => GLens r w a b -> w (b, a) a+set l = modify l . first (arr const)++{-------------------------------------------------------------------------------+ Conversion+-------------------------------------------------------------------------------}++fromLens :: (Arrow r, ArrowApply w) => Lens (->) a b -> GLens r w a b+fromLens l =+ GLens (arr (Lens.get l))+ (uncurry $ \h -> arr (Lens.set l) . (h . arr (Lens.get l) &&& id))++fromIso :: (Arrow r, ArrowApply w) => Iso (->) a b -> GLens r w a b+fromIso (Iso f g) = GLens (arr f) (uncurry $ \h -> arr g . h . arr f)++toLens :: GLens cat cat a b -> Lens cat a b+toLens (GLens f g) = Lens.lens f g++{-------------------------------------------------------------------------------+ Generic computation of all lenses for a record type+-------------------------------------------------------------------------------}++glenses :: forall r w a xs. (Generic a, Code a ~ '[xs], Arrow r, ArrowApply w) => NP (GLens r w a) xs+glenses = case sing :: Sing (Code a) of+ SCons -> hliftA (\l -> l . sop . rep) np++{-------------------------------------------------------------------------------+ Generalized lenses for representation types+-------------------------------------------------------------------------------}++np :: forall r w xs. (Arrow r, ArrowApply w, SingI xs) => NP (GLens r w (NP I xs)) xs+np = case sing :: Sing xs of+ SNil -> Nil+ SCons -> i . head :* hliftA (. tail) np++rep :: (Arrow r, ArrowApply w, Generic a) => GLens r w a (Rep a)+rep = fromIso $ Iso from to++sop :: (Arrow r, ArrowApply w) => GLens r w (SOP f '[xs]) (NP f xs)+sop = fromIso $ Iso (\(SOP (Z x)) -> x) (SOP . Z)++head :: (Arrow r, ArrowApply w) => GLens r w (NP f (x ': xs)) (f x)+head = fromLens $ Lens.lens (\(x :* _) -> x) (\(f, x :* xs) -> (f x :* xs))++tail :: (Arrow r, ArrowApply w) => GLens r w (NP f (x ': xs)) (NP f xs)+tail = fromLens $ Lens.lens (\(_ :* xs) -> xs) (\(f, x :* xs) -> (x :* f xs))++i :: (Arrow r, ArrowApply w) => GLens r w (I a) a+i = fromIso $ Iso unI I++{-------------------------------------------------------------------------------+ Auxiliary+-------------------------------------------------------------------------------}++const :: Arrow arr => c -> arr b c+const a = arr (\_ -> a)++curry :: Arrow cat => cat (a, b) c -> (a -> cat b c)+curry m a = m . (const a &&& id)++uncurry :: ArrowApply cat => (a -> cat b c) -> cat (a, b) c+uncurry a = app . arr (first a)
+ src/Generics/SOP/Lens/Computed.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE UndecidableInstances, OverlappingInstances #-}+module Generics.SOP.Lens.Computed (+ -- * Abstract lenses+ AbstractLens(..)+ , abstractId+ , afterGLens+ -- * Getters and setters+ , get+ , set+ , modify+ , getM+ , setM+ , modifyM+ -- * Computing lenses+ , Path+ , CLens+ , lens+ -- * Manually constructing lenses+ , emptyPathOnly+ -- * Configuration+ , LensOptions(..)+ , defaultLensOptions+ ) where++import Prelude hiding (id, (.))+import Control.Arrow+import Control.Category+import Control.Monad+import Data.Functor.Identity+import Data.Maybe (catMaybes)++import Generics.SOP+import Generics.SOP.Lens (GLens)+import qualified Generics.SOP.Lens as GLens++{-------------------------------------------------------------------------------+ Abstract lenses+-------------------------------------------------------------------------------}++-- | An abstract lens qualifies existentially over the target type of the lens+--+-- Sadly, abstract lenses do not form a category, so we provide special+-- identity and composition functions.+data AbstractLens r w c a =+ forall x. c x => AbstractLens (GLens r w a x)++-- | Identity abstract lens+abstractId :: (ArrowApply r, ArrowApply w, c a) => AbstractLens r w c a+abstractId = AbstractLens id++-- | Compose with a pointwise lens on the right+afterGLens :: (ArrowApply r, ArrowApply w)+ => AbstractLens r w c a -- ^ @a -> x@+ -> GLens r w b a -- ^ @b -> a@+ -> AbstractLens r w c b -- ^ @b -> x@+afterGLens (AbstractLens l) l' = AbstractLens (l . l')++{-------------------------------------------------------------------------------+ Getters and setters (mostly just for convenience)+-------------------------------------------------------------------------------}++-- | Getter for computed lenses+--+-- > get l == runIdentity . getM l . Identity+get :: Category r => AbstractLens r w c a -> (forall x. c x => r a x -> b) -> b+get l f = runIdentity $ getM l (Identity . f)++-- | Setter for computed lenses+--+-- > set l == runIdentity . setM l . Identity+set :: Arrow w => AbstractLens r w c a -> (forall x. c x => x) -> w a a+set l x = runIdentity $ setM l (Identity x)++-- | Modifier for computed lenses+modify :: Arrow w => AbstractLens r w c a -> (forall x. c x => w x x) -> w a a+modify l f = runIdentity $ modifyM l (Identity f)++-- | Getter with possibility for "compile time" failure+getM :: (Monad m, Category r)+ => AbstractLens r w c a+ -> (forall x. c x => r a x -> m b)+ -> m b+getM (AbstractLens l) k = k (GLens.get l)++-- | Setter with possibility for "compile time" failure+setM :: (Monad m, Arrow w)+ => AbstractLens r w c a -> (forall x. c x => m x) -> m (w a a)+setM (AbstractLens l) mx =+ mx >>= \x -> return $ GLens.set l . arr (\a -> (x, a))++-- | Modifier with possibility for "compile time" failure+modifyM :: (Monad m, Arrow w)+ => AbstractLens r w c a -> (forall x. c x => m (w x x)) -> m (w a a)+modifyM (AbstractLens l) mf =+ mf >>= \f -> return $ GLens.modify l . arr (\a -> (f, a))++{-------------------------------------------------------------------------------+ Paths+-------------------------------------------------------------------------------}++-- | A path is a series of field names. For instance, given+--+-- > data T1 = T1 { a :: Int, b :: Int } deriving Generic+-- > data T2 = T2 { c :: T1, d :: Int } deriving Generic+--+-- valid paths on T2 are+--+-- > []+-- > ["c"]+-- > ["d"]+-- > ["c", "a"]+-- > ["c", "b"]+type Path = [String]++{-------------------------------------------------------------------------------+ Top-level generic function+-------------------------------------------------------------------------------}++-- | Compute a lens for a given type and path+--+-- The @Either@ is used to indicate "compile time" failure of the computation+-- of the lens (for instance, when this path is invalid for this data type).+--+-- Some lenses may of course be themselves effectful, depending on the category.+-- However, the lenses returned by the generic computation are pure and total+-- (as is evident from the type of glens).+class CLens r w c a where+ default lens :: ( Generic a+ , HasDatatypeInfo a+ , ArrowApply r+ , ArrowApply w+ , c a+ , Code a ~ '[xs]+ , All (CLens r w c) xs+ )+ => LensOptions -> Path -> Either String (AbstractLens r w c a)++ lens :: LensOptions -> Path -> Either String (AbstractLens r w c a)+ lens = glens++{-------------------------------------------------------------------------------+ Instances++ We don't provide any instances here, because applications might want to+ implement special kinds of semantics for certain paths for types that we+ normally cannot "look into".+-------------------------------------------------------------------------------}++-- | A lens for abstract types (supports empty paths only)+--+-- Useful for defining CLens instances for types such as Int, Bool,+-- Text, etc.+--+-- > instance CLens c Int where lens = emptyPathOnly+emptyPathOnly :: (ArrowApply r, ArrowApply w, c a)+ => LensOptions -> Path -> Either String (AbstractLens r w c a)+emptyPathOnly _ [] = Right $ abstractId+emptyPathOnly _ _ = Left "Trying to look inside abstract type"++{-------------------------------------------------------------------------------+ Lens options+-------------------------------------------------------------------------------}++data LensOptions = LensOptions {+ -- | Match a selector against a path component+ lensOptionsMatch :: DatatypeName -> FieldName -> String -> Bool+ }++-- | Default match just compares field names+defaultLensOptions :: LensOptions+defaultLensOptions = LensOptions {+ lensOptionsMatch = const (==)+ }++{-------------------------------------------------------------------------------+ The actual generic function+-------------------------------------------------------------------------------}++glens :: forall r w a c xs.+ ( ArrowApply r+ , ArrowApply w+ , Generic a+ , HasDatatypeInfo a+ , c a+ , Code a ~ '[xs]+ , All (CLens r w c) xs+ )+ => LensOptions -> Path -> Either String (AbstractLens r w c a)+glens _ [] = Right $ abstractId+glens opts (p:ps) = liftM (`afterGLens` (GLens.sop . GLens.rep))+ . glens' opts p ps+ $ datatypeInfo (Proxy :: Proxy a)++glens' :: ( ArrowApply r+ , ArrowApply w+ , All (CLens r w c) xs+ )+ => LensOptions -> String -> Path+ -> DatatypeInfo '[xs]+ -> Either String (AbstractLens r w c (NP I xs))+glens' opts p ps (ADT _ n (c :* Nil)) = glens'' opts ps n p c+glens' opts p ps (Newtype _ n c) = glens'' opts ps n p c+glens' _ _ _ _ = error "inaccessible"++glens'' :: forall r w c xs.+ ( ArrowApply r+ , ArrowApply w+ , All (CLens r w c) xs+ )+ => LensOptions -> Path+ -> DatatypeName -> String+ -> ConstructorInfo xs+ -> Either String (AbstractLens r w c (NP I xs))+glens'' _ _ _ _ (Constructor _) =+ Left $ "Cannot compute lenses for non-record types"+glens'' _ _ _ _ (Infix _ _ _) =+ Left $ "Cannot compute lenses for non-record types"+glens'' opts ps d p (Record _ fs) =+ case matchingLenses of+ [] -> Left $ "Unknown field " ++ show p ++ " of datatype " ++ show d+ [l] -> l+ _ -> Left $ "Invalid metadata for datatype " ++ show d+ where+ matchingLenses :: [Either String (AbstractLens r w c (NP I xs))]+ matchingLenses = catMaybes . hcollapse $ hcliftA2 pl aux fs GLens.np++ aux :: forall a. CLens r w c a+ => FieldInfo a+ -> GLens r w (NP I xs) a+ -> K (Maybe (Either String (AbstractLens r w c (NP I xs)))) a+ aux (FieldInfo f) l = K $+ if lensOptionsMatch opts d f p+ then Just $ ((`afterGLens` l) `liftM` lens opts ps)+ else Nothing++ pl :: Proxy (CLens r w c)+ pl = Proxy
+ src/Generics/SOP/Lens/Named.hs view
@@ -0,0 +1,74 @@+module Generics.SOP.Lens.Named (+ -- * Monomorphic total lens, abstracted over target+ LensName+ , NamedLens(..)+ , get+ , modify+ , set+ -- * Generic construction+ , gnamedLenses+ ) where++import Generics.SOP+import Generics.SOP.Lens (GLens)+import qualified Generics.SOP.Lens as GLens++{-------------------------------------------------------------------------------+ Wrapper around Data.Label+-------------------------------------------------------------------------------}++type LensName = String++-- | Total abstract lens+data NamedLens a ctxt = forall b. ctxt b => NamedLens {+ unNamedLens :: GLens (->) (->) a b+ }++instance Show (NamedLens a ctxt) where+ show _ = "<<NamedLens>"++get :: NamedLens a ctxt -> (forall b. ctxt b => b -> c) -> a -> c+get (NamedLens l) k a = k (GLens.get l a)++modify :: NamedLens a ctxt -> (forall b. ctxt b => b -> b) -> a -> a+modify (NamedLens l) f a = GLens.modify l (f, a)++set :: NamedLens a ctxt -> (forall b. ctxt b => b) -> a -> a+set (NamedLens l) f b = GLens.set l (f, b)++{-------------------------------------------------------------------------------+ Construct named lenses+-------------------------------------------------------------------------------}++-- | Construct named lenses for a record type+--+-- NOTE: This will throw a runtime error for non-record types+gnamedLenses :: forall a ctxt xs. (Generic a, HasDatatypeInfo a, Code a ~ '[xs], All ctxt xs)+ => (DatatypeName -> ConstructorName -> LensName)+ -> [(String, NamedLens a ctxt)]+gnamedLenses mkName = case sing :: Sing (Code a) of+ SCons -> zip (fieldNames mkName (datatypeInfo pa))+ (hcollapse $ hcliftA pc (K . NamedLens) totalLenses)+ where+ totalLenses :: NP (GLens (->) (->) a) xs+ totalLenses = GLens.glenses++ pa :: Proxy a+ pa = Proxy++ pc :: Proxy ctxt+ pc = Proxy++fieldNames :: (DatatypeName -> FieldName -> LensName)+ -> DatatypeInfo '[xs] -> [String]+fieldNames mkName (ADT _ n (c :* Nil)) = fieldNames' (mkName n) c+fieldNames mkName (Newtype _ n c ) = fieldNames' (mkName n) c+fieldNames _ _ = error "inaccesible"++fieldNames' :: (FieldName -> LensName) -> ConstructorInfo xs -> [String]+fieldNames' _ (Constructor _) = error "not a record type"+fieldNames' _ (Infix _ _ _) = error "not a record type"+fieldNames' mkName (Record _ fs) = hcollapse $ hliftA aux fs+ where+ aux :: FieldInfo a -> K String a+ aux (FieldInfo n) = K (mkName n)