diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lens-sop.cabal b/lens-sop.cabal new file mode 100644 --- /dev/null +++ b/lens-sop.cabal @@ -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 @@ package. + . + It also contains SOP-style generic functions (based on the + @@ 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 , Andres Löh +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 diff --git a/src/Generics/SOP/Lens.hs b/src/Generics/SOP/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/Lens.hs @@ -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) diff --git a/src/Generics/SOP/Lens/Computed.hs b/src/Generics/SOP/Lens/Computed.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/Lens/Computed.hs @@ -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 diff --git a/src/Generics/SOP/Lens/Named.hs b/src/Generics/SOP/Lens/Named.hs new file mode 100644 --- /dev/null +++ b/src/Generics/SOP/Lens/Named.hs @@ -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 _ = "<" + +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)