packages feed

generic-lens-lite (empty) → 0.1

raw patch · 5 files changed

+433/−0 lines, 5 filesdep +basedep +generic-lens-lite

Dependencies added: base, generic-lens-lite

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2020 Oleg Grenrus++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Oleg Grenrus nor the names of other+      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+OWNER 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.
+ example/Example.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE DeriveGeneric    #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -funfolding-keeness-factor=100 #-}+module Main (module Main) where++import Data.Generics.Lens.Lite (field)+import GHC.Generics            (Generic)++main :: IO ()+main = return ()++-------------------------------------------------------------------------------+-- Big record+-------------------------------------------------------------------------------++data Ex = Ex+    { exA :: Int+    , exB :: Bool+    , ex0 :: Char+    , ex1 :: Char+    , ex2 :: Char+    , ex3 :: Char+    , ex4 :: Char+    , ex5 :: Char+    , ex6 :: Char+    , ex7 :: Char+    , ex8 :: Char+    , ex9 :: Char+    } deriving (Generic)++_exA :: Functor f => (Int -> f Int) -> Ex -> f Ex+_exA = field @"exA"++_exB :: Functor f => (Bool -> f Bool) -> Ex -> f Ex+_exB = field @"exB"++_ex4 :: Functor f => (Char -> f Char) -> Ex -> f Ex+_ex4 = field @"ex4"++-------------------------------------------------------------------------------+-- Sum of records+-------------------------------------------------------------------------------++data Ex2+    = Ex2A { exC :: Char }+    | Ex2B { exC :: Char }+  deriving (Generic)++_exC :: Functor f => (Char -> f Char) -> Ex2 -> f Ex2+_exC = field @"exC"
+ generic-lens-lite.cabal view
@@ -0,0 +1,54 @@+cabal-version: 2.2+name:          generic-lens-lite+version:       0.1+synopsis:      Monomorphic field lens like with generic-lens+category:      Lens, Generics+description:+  Derivation of (monomorphic, i.e. not type-changing) lens, like generic-lens.+  .+  The package have minimal dependecies and minimal API:+  .+  @+  class HasField (name :: Symbol) r a | name r -> a+  field :: HasField name r a => Lens' r a+  @++homepage:      https://github.com/phadej/generic-lens-lite+license:       BSD-3-Clause+license-file:  LICENSE+author:        Edward Kmett, Csongor Kiss, Oleg Grenrus+maintainer:    Oleg Grenrus <oleg.grenrus@iki.fi>+copyright:     Copyright (c) 2019 Edward Kmett, 2020 Oleg Grenrus+build-type:    Simple+tested-with:   GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1++source-repository head+  type:     git+  location: https://github.com/phadej/generic-lens-lite+  subdir:   generic-lens-lite++library+  default-language: Haskell2010+  hs-source-dirs:   src+  ghc-options:      -Wall+  exposed-modules:  Data.Generics.Lens.Lite+  other-modules:    Data.Functor.Confusing+  build-depends:    base >=4.9 && <4.14++  if impl(ghc >=8.4)+    ghc-options:+      -Wincomplete-uni-patterns -Wincomplete-record-updates+      -Wredundant-constraints -Widentities -Wmissing-export-lists++test-suite example+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  hs-source-dirs:   example+  main-is:          Example.hs+  ghc-options:      -Wall+  build-depends:+    , base+    , generic-lens-lite++--  build-depends:    dump-core+--  ghc-options:      -fplugin=DumpCore
+ src/Data/Functor/Confusing.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Safe       #-}+-- |+-- Csongor Kiss, Matthew Pickering, and Nicolas Wu. 2018. Generic deriving of generic traversals.+-- Proc. ACM Program. Lang. 2, ICFP, Article 85 (July 2018), 30 pages. DOI: https://doi.org/10.1145/3236780+--+-- https://arxiv.org/abs/1805.06798+--+-- This is modified version of part of @generic-lens@ library+--+-- Copyright (c) 2018, Csongor Kiss+--+-- All rights reserved.+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+--+--     * Redistributions of source code must retain the above copyright+--       notice, this list of conditions and the following disclaimer.+--+--     * 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.+--+--     * Neither the name of Csongor Kiss nor the names of other+--       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+-- OWNER 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.+--+module Data.Functor.Confusing (+    fusing, confusing, LensLike,+    ifusing, iconfusing, IxLensLike,+    ffusing, fconfusing, FLensLike,+    CurriedYoneda, lowerCurriedYoneda, liftCurriedYoneda, yap,+    Curried (..), liftCurried, lowerCurried,+    Yoneda (..), liftYoneda, lowerYoneda,+  ) where++import Control.Applicative++-------------------------------------------------------------------------------+-- Confusing+-------------------------------------------------------------------------------++type LensLike f s t a b = (a -> f b) -> s -> f t++-- note: qualified name to justify import even with newer GHCs++fusing :: Functor f => LensLike (Yoneda f) s t a b -> LensLike f s t a b+fusing t = \f -> lowerYoneda .  t (liftYoneda . f)+{-# INLINE fusing #-}++confusing :: Control.Applicative.Applicative f => LensLike (Curried (Yoneda f)) s t a b -> LensLike f s t a b+confusing t = \f -> lowerCurriedYoneda . t (liftCurriedYoneda . f)+{-# INLINE confusing #-}++type IxLensLike f i s t a b = (i -> a -> f b) -> s -> f t++ifusing :: Functor f => IxLensLike (Yoneda f) i s t a b -> IxLensLike f i s t a b+ifusing t = \f -> lowerYoneda . t (\i a -> liftYoneda (f i a))+{-# INLINE ifusing #-}++iconfusing :: Applicative f => IxLensLike (Curried (Yoneda f)) i s t a b -> IxLensLike f i s t a b+iconfusing t = \f -> lowerYoneda . lowerCurried . t (\i a -> liftCurriedYoneda (f i a))+{-# INLINE iconfusing #-}++type FLensLike f s t a b = (forall x. a x -> f (b x)) -> s -> f t++ffusing :: Functor f => FLensLike (Yoneda f) s t a b -> FLensLike f s t a b+ffusing t = \f -> lowerYoneda . t (liftYoneda . f)+{-# INLINE ffusing #-}++fconfusing :: Applicative f => FLensLike (Curried (Yoneda f)) s t a b -> FLensLike f s t a b+fconfusing t = \f -> lowerYoneda . lowerCurried . t (liftCurriedYoneda . f)+{-# INLINE fconfusing #-}++-------------------------------------------------------------------------------+-- CurriedYoneda+-------------------------------------------------------------------------------++type CurriedYoneda f = Curried (Yoneda f)++lowerCurriedYoneda :: Applicative f => Curried (Yoneda f) a -> f a+lowerCurriedYoneda = lowerYoneda . lowerCurried+{-# INLINE lowerCurriedYoneda #-}++liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) a+liftCurriedYoneda fa = Curried (`yap` fa)+{-# INLINE liftCurriedYoneda #-}++yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b+yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)+{-# INLINE yap #-}++-------------------------------------------------------------------------------+-- Curried+-------------------------------------------------------------------------------++newtype Curried f a = Curried { runCurried :: forall r. f (a -> r) -> f r }++instance Functor f => Functor (Curried f) where+    fmap f (Curried g) = Curried (g . fmap (.f))+    {-# INLINE fmap #-}++instance Functor f => Applicative (Curried f) where+    pure a = Curried (fmap ($ a))+    {-# INLINE pure #-}+    Curried mf <*> Curried ma = Curried (ma . mf . fmap (.))+    {-# INLINE (<*>) #-}++liftCurried :: Applicative f => f a -> Curried f a+liftCurried fa = Curried (<*> fa)++lowerCurried :: Applicative f => Curried f a -> f a+lowerCurried (Curried f) = f (pure id)++-------------------------------------------------------------------------------+-- Yoneda+-------------------------------------------------------------------------------++newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b }++liftYoneda :: Functor f => f a -> Yoneda f a+liftYoneda a = Yoneda (\f -> fmap f a)++lowerYoneda :: Yoneda f a -> f a+lowerYoneda (Yoneda f) = f id++instance Functor (Yoneda f) where+    fmap f m = Yoneda (\k -> runYoneda m (k . f))++instance Applicative f => Applicative (Yoneda f) where+    pure a = Yoneda (\f -> pure (f a))+    Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)
+ src/Data/Generics/Lens/Lite.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE EmptyCase              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+-- | Derive record field lenses generically.+module Data.Generics.Lens.Lite (+    field,+    HasField,+    ) where++import Data.Functor.Confusing (LensLike, Yoneda, fusing)+import Data.Kind              (Constraint, Type)+import Data.Proxy             (Proxy (..))+import GHC.TypeLits           (ErrorMessage (..), Symbol, TypeError)++import GHC.Generics++-------------------------------------------------------------------------------+-- Public API+-------------------------------------------------------------------------------++-- | Type-class restricting 'field' usage.+class HasField (name :: Symbol) r a | name r -> a where+    field__ :: Proxy name -> LensLikeYoneda' f r a++class HasFieldInternal (name :: Symbol) r a | name r -> a where+    field_ :: Proxy name -> LensLikeYoneda' f r a++-- | A lens that focuses on a field with a given name.+-- Compatible with the lens package's 'Control.Lens.Lens' type.+--+-- __Note:__ the lens is /simple/, i.e. doesn't allow type-changing updates.+-- This keeps the implementation small and quick.+--+-- You also may want to specify+-- @+-- {-\# OPTIONS_GHC -funfolding-keeness-factor=100 #-} (or some other arbitrarily large number)+-- @+-- for GHC to inline more aggressively.+--+field+    :: forall (name :: Symbol) (r :: Type) (a :: Type) (f :: Type -> Type). (HasField name r a, Functor f)+    => (a -> f a) -> r -> f r+field = fusing (field__ (Proxy :: Proxy name))++instance HasFieldInternal name r a => HasField name r a where+    field__ = field_+    {-# INLINE field__ #-}++instance+    ( Generic r+    , ErrorCheck name r a (HasFieldPred name (Rep r))+    , HasFieldPred name (Rep r) ~ 'Just a+    , GField name (Rep r) a+    ) => HasFieldInternal name r a+  where+    field_ pname f s = fmap to (gfield pname f (from s))+    {-# INLINE field_ #-}++-------------------------------------------------------------------------------+-- Errors+-------------------------------------------------------------------------------++type family ErrorCheck (name :: Symbol) r a (res :: Maybe Type) :: Constraint where+    ErrorCheck _    _ _ ('Just _) = ()+    ErrorCheck name r a 'Nothing  = TypeError+      ( 'Text "Type " ':<>: 'ShowType r+      ':<>: 'Text " doesn't have field named " ':<>: 'Text name+      )++-- this prevents expansion of HasField "alias".+data Void1 a++instance {-# OVERLAPPING #-} HasField name (Void1 a) a where+    field__ _ _ n = case n of {}++-------------------------------------------------------------------------------+-- Generics+-------------------------------------------------------------------------------++type LensLikeYoneda' f r a = LensLike (Yoneda f) r r a a++class (HasFieldPred name f ~ 'Just a) => GField (name :: Symbol) f a | name f -> a where+    gfield :: Proxy name -> LensLikeYoneda' h (f ()) a++instance (GFieldSum name f a, i ~ D, HasFieldPred name f ~ 'Just a) => GField name (M1 i c f) a where+    gfield pname f (M1 x) = fmap M1 (gfieldsum pname f x)+    {-# INLINE gfield #-}++class HasFieldPred name f ~ 'Just a => GFieldSum (name :: Symbol) f a | name f -> a where+    gfieldsum :: Proxy name -> LensLikeYoneda' h (f ()) a++instance (HasFieldPred name (f :+: g) ~ 'Just a, GFieldSum name f a, GFieldSum name g a) => GFieldSum name (f :+: g) a where+    gfieldsum pname f (L1 x) = fmap L1 (gfieldsum pname f x)+    gfieldsum pname f (R1 y) = fmap R1 (gfieldsum pname f y)+    {-# INLINE gfieldsum #-}++instance (GFieldProd name f a, i ~ C, HasFieldPred name f ~ 'Just a) => GFieldSum name (M1 i c f) a where+    gfieldsum pname f (M1 x)  = fmap M1 (gfieldprod pname f x)+    {-# INLINE gfieldsum #-}++class (HasFieldPred name f ~ 'Just a) => GFieldProd (name :: Symbol) f a | name f -> a where+    gfieldprod :: Proxy name -> LensLikeYoneda' h (f ()) a++instance (c ~ 'MetaSel ('Just name) u s l, f ~ Rec0 a, i ~ S) => GFieldProd name (M1 i c f) a where+    gfieldprod _ f (M1 (K1 x)) = fmap (M1 . K1) (f x)+    {-# INLINE gfieldprod #-}++instance GFieldProd' name f g (HasFieldPred name f) a => GFieldProd name (f :*: g) a where+    gfieldprod = gfieldprod' (Proxy :: Proxy (HasFieldPred name f))+    {-# INLINE gfieldprod #-}++class (HasFieldPred name (f :*: g) ~ 'Just a) => GFieldProd' (name :: Symbol) f g (res :: Maybe Type) a where+    gfieldprod' :: Proxy res -> Proxy name ->  LensLikeYoneda' h ((f :*: g) ()) a++instance (a ~ a', GFieldProd name f a', HasFieldPred name (f :*: g) ~ 'Just a) => GFieldProd' name f g ('Just a') a where+    gfieldprod' _ pname f (x :*: y) = fmap (:*: y) (gfieldprod pname f x)+    {-# INLINE gfieldprod' #-}++instance (a ~ a', GFieldProd name g a', HasFieldPred name (f :*: g) ~ 'Just a) => GFieldProd' name f g 'Nothing a where+    gfieldprod' _ pname f (x :*: y) = fmap (x :*:) (gfieldprod pname f y)+    {-# INLINE gfieldprod' #-}++-------------------------------------------------------------------------------+-- TotalField+-------------------------------------------------------------------------------++type family Both (m1 :: Maybe Type) (m2 :: Maybe Type) :: Maybe Type where+    Both ('Just a) ('Just a) = 'Just a++type family Alt (m1 :: Maybe Type) (m2 :: Maybe Type) :: Maybe Type where+    Alt ('Just a) _ = 'Just a+    Alt _ b = b++type family HasFieldPred (field :: Symbol) f :: Maybe Type where+    HasFieldPred field (S1 ('MetaSel ('Just field) _ _ _) (Rec0 t)) =+        'Just t+    HasFieldPred field (S1 _ _)  = 'Nothing+    HasFieldPred field (l :*: r) = Alt (HasFieldPred field l) (HasFieldPred field r)+    HasFieldPred field (l :+: r) = Both (HasFieldPred field l) (HasFieldPred field r)+    HasFieldPred field (C1 _ f)  = HasFieldPred field f+    HasFieldPred field (D1 _ f)  = HasFieldPred field f+    HasFieldPred field (K1 _ _)  = 'Nothing+    HasFieldPred field U1        = 'Nothing+    HasFieldPred field V1        = 'Nothing