generics-sop-lens (empty) → 0.1.1.0

raw patch · 5 files changed

+332/−0 lines, 5 filesdep +basedep +generics-sopdep +lenssetup-changed

Dependencies added: base, generics-sop, lens

Files

LICENSE +30/−0
README.md +3/−0
Setup.hs +2/−0
generics-sop-lens.cabal +37/−0
src/Generics/SOP/Lens.hs +260/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2015, 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.

+ README.md view

@@ -0,0 +1,3 @@+# generics-sop-lenses++Lenses for types in [`generics-sop`](http://hackage.haskell.org/package/generics-sop)

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ generics-sop-lens.cabal view

@@ -0,0 +1,37 @@+-- This file has been generated from package.yaml by hpack version 0.8.0.+--+-- see: https://github.com/sol/hpack++name:           generics-sop-lens+version:        0.1.1.0+synopsis:       Lenses for types in generics-sop+description:    Lenses for types in generics-sop package+category:       Web+homepage:       https://github.com/phadej/generics-sop-lens#readme+bug-reports:    https://github.com/phadej/generics-sop-lens/issues+author:         Oleg Grenrus <oleg.grenrus@iki.fi>+maintainer:     Oleg Grenrus <oleg.grenrus@iki.fi>+license:        BSD3+license-file:   LICENSE+tested-with:    GHC==7.8.4, GHC==7.10.3, GHC==8.0.1+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/phadej/generics-sop-lens++library+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base                  >=4.7      && <4.10+    , generics-sop          >=0.1      && <0.3+    , lens                  >=4.7      && <4.14+  exposed-modules:+      Generics.SOP.Lens+  default-language: Haskell2010

+ src/Generics/SOP/Lens.hs view

@@ -0,0 +1,260 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# OPTIONS_GHC -fno-warn-orphans  #-}+-- | Lenses for "Generics.SOP"+--+-- Orphan instances:+--+-- @+-- 'Wrapped' ('SOP' f xss) -- Also 'Rewrapped'+-- 'Wrapped' ('POP' f xss)+-- 'Field1' ('NP' f (x ': zs)) ('NP' f (y ': zs)) (f x) (f y) -- 'Field2' etc.+-- 'Field1' ('POP' f (x ': zs)) ('NP' f (y ': zs)) (NP f x) (NP f y)+-- @+module Generics.SOP.Lens (+    rep,+    -- * SOP & POP+    sop, pop,+    unsop, unpop,+    -- * Functors+    isoI, isoK,+    uni, unk,+    -- * Products+    singletonP,+    unSingletonP,+    headLens,+    tailLens,+    -- * Sums+    singletonS,+    unSingletonS,+    _Z,+    _S,+    -- * DatatypeInfo+    moduleName,+    datatypeName,+    constructorInfo,+    ) where++import Control.Lens+import Generics.SOP hiding (from)+import qualified Generics.SOP as SOP++rep :: Generic a => Iso' a (Rep a)+rep = iso SOP.from SOP.to++-------------------------------------------------------------------------------+-- SOP & POP+-------------------------------------------------------------------------------++sop ::+    forall (f :: k -> *) xss yss.+    Iso (NS (NP f) xss) (NS (NP f) yss) (SOP f xss) (SOP f yss)+sop = iso SOP unSOP++unsop ::+    forall (f :: k -> *) xss yss.+    Iso (SOP f xss) (SOP f yss) (NS (NP f) xss) (NS (NP f) yss)+unsop = from sop++pop ::+    forall (f :: k -> *) xss yss.+    Iso (NP (NP f) xss) (NP (NP f) yss) (POP f xss) (POP f yss)+pop = iso POP unPOP++unpop ::+    forall (f :: k -> *) xss yss.+    Iso (POP f xss) (POP f yss) (NP (NP f) xss) (NP (NP f) yss)+unpop = from pop++instance (t ~ SOP f xss) => Rewrapped (SOP f xss) t+instance Wrapped (SOP f xss) where+    type Unwrapped (SOP f xss) = NS (NP f) xss+    _Wrapped' = from sop++instance (t ~ POP f xss) => Rewrapped (POP f xss) t+instance Wrapped (POP f xss) where+    type Unwrapped (POP f xss) = NP (NP f) xss+    _Wrapped' = from pop++-------------------------------------------------------------------------------+-- Basic functors+-------------------------------------------------------------------------------++isoI :: Iso a b (I a) (I b)+isoI = iso I unI++uni :: Iso (I a) (I b) a b+uni = iso unI I++isoK :: Iso a b (K a c) (K b c)+isoK = iso K unK++unk :: Iso (K a c) (K b c) a b+unk = iso unK K++instance (t ~ I a) => Rewrapped (I a) t+instance Wrapped (I a) where+    type Unwrapped (I a) = a+    _Wrapped' = from isoI++instance (t ~ K a b) => Rewrapped (K a b) t+instance Wrapped (K a b) where+    type Unwrapped (K a b) = a+    _Wrapped' = from isoK++-------------------------------------------------------------------------------+-- Products+-------------------------------------------------------------------------------++singletonP ::+    forall (f :: k -> *) x y.+    Iso (f x) (f y) (NP f '[x]) (NP f '[y])+singletonP = iso s g+  where+    g :: NP f '[y] -> f y+    g (y  :* Nil)   = y+#if __GLASGOW_HASKELL < 800+    g _ = error "singletonP"+#endif++    s :: f x -> NP f '[x]+    s x = x :* Nil++unSingletonP ::+    forall (f :: k -> *) x y.+    Iso (NP f '[x]) (NP f '[y]) (f x) (f y)+unSingletonP = from singletonP++headLens ::+    forall (f :: k -> *) x y zs.+    Lens (NP f (x ': zs)) (NP f (y ': zs)) (f x) (f y)+headLens = lens g s+  where+    g :: NP f (x ': zs) -> f x+    g (x  :* _zs)   = x++    s :: NP f (x ': zs) -> f y -> NP f (y ': zs)+    s (_x :*  zs) y = y :* zs++tailLens ::+    forall (f :: k -> *) x ys zs.+    Lens (NP f (x ': ys)) (NP f (x ': zs)) (NP f ys) (NP f zs)+tailLens = lens g s+  where+    g :: NP f (x ': ys) -> NP f ys+    g (_x :*  ys)    = ys++    s :: NP f (x ': ys) -> NP f zs -> NP f (x ': zs)+    s (x  :* _ys) zs = x :* zs++instance Field1 (NP f (x ': zs)) (NP f (y ': zs)) (f x) (f y) where _1 = headLens+instance Field1 (POP f (x ': zs)) (POP f (y ': zs)) (NP f x) (NP f y) where _1 = from pop . _1++instance Field2 (NP f (a ': x ': zs)) (NP f (a ': y ': zs)) (f x) (f y) where _2 = tailLens . _1+instance Field2 (POP f (a ': x ': zs)) (POP f (a ': y ': zs)) (NP f x) (NP f y) where _2 = from pop . _2++instance Field3 (NP f (a ': b ': x ': zs)) (NP f (a ': b ': y ': zs)) (f x) (f y) where _3 = tailLens . _2+instance Field3 (POP f (a ': b ': x ': zs)) (POP f (a ': b ': y ': zs)) (NP f x) (NP f y) where _3 = from pop . _3++instance Field4 (NP f (a ': b ': c ': x ': zs)) (NP f (a ': b ': c ': y ': zs)) (f x) (f y) where _4 = tailLens . _3+instance Field4 (POP f (a ': b ': c ': x ': zs)) (POP f (a ': b ': c ': y ': zs)) (NP f x) (NP f y) where _4 = from pop . _4++instance Field5 (NP f (a ': b ': c ': d ': x ': zs)) (NP f (a ': b ': c ': d ': y ': zs)) (f x) (f y) where _5 = tailLens . _4+instance Field5 (POP f (a ': b ': c ': d ': x ': zs)) (POP f (a ': b ': c ': d ': y ': zs)) (NP f x) (NP f y) where _5 = from pop . _5++instance Field6 (NP f (a ': b ': c ': d ': e ': x ': zs)) (NP f (a ': b ': c ': d ': e ': y ': zs)) (f x) (f y) where _6 = tailLens . _5+instance Field6 (POP f (a ': b ': c ': d ': e ': x ': zs)) (POP f (a ': b ': c ': d ': e ': y ': zs)) (NP f x) (NP f y) where _6 = from pop . _6++instance Field7 (NP f' (a ': b ': c ': d ': e ': f ': x ': zs)) (NP f' (a ': b ': c ': d ': e ': f ': y ': zs)) (f' x) (f' y) where _7 = tailLens . _6+instance Field7 (POP f' (a ': b ': c ': d ': e ': f ': x ': zs)) (POP f' (a ': b ': c ': d ': e ': f ': y ': zs)) (NP f' x) (NP f' y) where _7 = from pop . _7++instance Field8 (NP f' (a ': b ': c ': d ': e ': f ': g ': x ': zs)) (NP f' (a ': b ': c ': d ': e ': f ': g ': y ': zs)) (f' x) (f' y) where _8 = tailLens . _7+instance Field8 (POP f' (a ': b ': c ': d ': e ': f ': g ': x ': zs)) (POP f' (a ': b ': c ': d ': e ': f ': g ': y ': zs)) (NP f' x) (NP f' y) where _8 = from pop . _8++instance Field9 (NP f' (a ': b ': c ': d ': e ': f ': g ': h ': x ': zs)) (NP f' (a ': b ': c ': d ': e ': f ': g ': h ': y ': zs)) (f' x) (f' y) where _9 = tailLens . _8+instance Field9 (POP f' (a ': b ': c ': d ': e ': f ': g ': h ': x ': zs)) (POP f' (a ': b ': c ': d ': e ': f ': g ': h ': y ': zs)) (NP f' x) (NP f' y) where _9 = from pop . _9++-------------------------------------------------------------------------------+-- Sums+-------------------------------------------------------------------------------++singletonS ::+    forall (f :: k -> *) x y.+    Iso (f x) (f y) (NS f '[x]) (NS f '[y])+singletonS = iso s g+  where+    g :: NS f '[y] -> f y+    g (Z y)   = y+#if __GLASGOW_HASKELL < 800+    g _ = error "singletonS"+#endif++    s :: f x -> NS f '[x]+    s x = Z x++unSingletonS ::+    forall (f :: k -> *) x y.+    Iso (NS f '[x]) (NS f '[y]) (f x) (f y)+unSingletonS = from singletonS++_Z ::+    forall (f :: k -> *) x y zs.+    Prism (NS f (x ': zs)) (NS f (y ': zs)) (f x) (f y)+_Z = prism Z p+  where+    p :: NS f (x ': zs) -> Either (NS f (y ': zs)) (f x)+    p (Z x)  = Right x+    p (S xs) = Left (S xs)++_S ::+    forall (f :: k -> *) x ys zs.+    Prism (NS f (x ': ys)) (NS f (x ': zs)) (NS f ys) (NS f zs)+_S = prism S p+  where+    p :: NS f (x ': ys) -> Either (NS f (x ': zs)) (NS f ys)+    p (Z x)  = Left $ Z x+    p (S xs) = Right $ xs++-------------------------------------------------------------------------------+-- DatatypeInfo+-------------------------------------------------------------------------------++moduleName :: Lens' (DatatypeInfo xss) ModuleName+moduleName = lens g s+  where+    g :: DatatypeInfo xss -> ModuleName+    g (ADT m _ _)     = m+    g (Newtype m _ _) = m++    s :: DatatypeInfo xss -> ModuleName -> DatatypeInfo xss+    s (ADT _ n cs)    m = ADT m n cs+    s (Newtype _ n c) m = Newtype m n c++datatypeName :: Lens' (DatatypeInfo xss) DatatypeName+datatypeName = lens g s+  where+    g :: DatatypeInfo xss -> DatatypeName+    g (ADT _ n _)     = n+    g (Newtype _ n _) = n++    s :: DatatypeInfo xss -> DatatypeName -> DatatypeInfo xss+    s (ADT m _ cs)    n = ADT m n cs+    s (Newtype m _ c) n = Newtype m n c++constructorInfo :: Lens' (DatatypeInfo xss) (NP ConstructorInfo xss)+constructorInfo = lens g s+  where+    g :: DatatypeInfo xss -> NP ConstructorInfo xss+    g (ADT _ _ cs)    = cs+    g (Newtype _ _ c) = c :* Nil++    s :: DatatypeInfo xss -> NP ConstructorInfo xss -> DatatypeInfo xss+    s (ADT m n _)     cs          = ADT m n cs+    s (Newtype m n _) (c :* Nil)  = Newtype m n c+    s _ _ = error "constructorInfo set: impossible happened"