git.iko.soy/generic-lens
on master help sign in
Add files
62bd16dCsongor Kiss
.gitignorenew file+1
compare with master
unifiedsplit
@@ -0,0 +1 @@
1+dist*
ChangeLog.mdnew file+5
@@ -0,0 +1,5 @@
1+# Revision history for generic-records
2+
3+## 0.1.0.0 -- YYYY-mm-dd
4+
5+* First version. Released on an unsuspecting world.
LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright (c) 2016, Csongor Kiss
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Csongor Kiss nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
examples/StarWars.hsnew file+72
@@ -0,0 +1,72 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE DuplicateRecordFields #-}
3+{-# LANGUAGE UndecidableInstances #-}
4+{-# LANGUAGE TypeApplications #-}
5+{-# LANGUAGE DataKinds #-}
6+{-# LANGUAGE FlexibleContexts #-}
7+
8+-- Note: this file may contain spoilers
9+-- (although I would be really surprised if it did, I haven't seen the films)
10+module StarWars where
11+
12+import Data.Proxy
13+import GHC.Generics
14+import Records.Generic
15+
16+data Episode = NEWHOPE | EMPIRE | JEDI
17+ deriving (Generic, Show, Eq)
18+
19+data Character = Character
20+ { name :: String
21+ , friends :: [Character]
22+ , appearsIn :: [Episode]
23+ } deriving (Generic, Show, Eq)
24+
25+data Human = Human
26+ { name :: String
27+ , friends :: [Character]
28+ , appearsIn :: [Episode]
29+ , homePlanet :: String
30+ } deriving (Generic, Show)
31+
32+data Droid = Droid
33+ { friends :: [Character]
34+ , appearsIn :: [Episode]
35+ , name :: String
36+ , primaryFunction :: String
37+ } deriving (Generic, Show)
38+
39+luke :: Human
40+luke = Human
41+ { name = "Luke Skywalker"
42+ , friends = []
43+ , appearsIn = [NEWHOPE, EMPIRE, JEDI]
44+ , homePlanet = "Saturn (?)"
45+ }
46+
47+r2d2 :: Droid
48+r2d2 = Droid
49+ { name = "R2-D2"
50+ , friends = [upcast luke]
51+ , appearsIn = [NEWHOPE]
52+ , primaryFunction = "destroy"
53+ }
54+
55+c3po :: Droid
56+c3po = Droid
57+ { name = "C3PO"
58+ , friends = [upcast r2d2, upcast luke]
59+ , appearsIn = [NEWHOPE, EMPIRE, JEDI]
60+ , primaryFunction = "exist"
61+ }
62+
63+getName :: HasField r "name" a => r -> a
64+getName r = getField r (Proxy @"name")
65+
66+-- upcast :: Subtype a b => a -> b
67+characters :: [Character]
68+characters = [upcast r2d2, upcast luke, upcast c3po]
69+
70+names :: [String]
71+names = map getName characters
72+-- => ["R2-D2","Luke Skywalker","C3PO"]
generic-records.cabalnew file+67
@@ -0,0 +1,67 @@
1+-- Initial generic-records.cabal generated by cabal init. For further
2+-- documentation, see http://haskell.org/cabal/users-guide/
3+
4+-- The name of the package.
5+name: generic-records
6+
7+-- The package version. See the Haskell package versioning policy (PVP)
8+-- for standards guiding when and how versions should be incremented.
9+-- https://wiki.haskell.org/Package_versioning_policy
10+-- PVP summary: +-+------- breaking API changes
11+-- | | +----- non-breaking API additions
12+-- | | | +--- code changes with no API change
13+version: 0.1.0.0
14+
15+-- A short (one-line) description of the package.
16+synopsis: Magic record operations using generics
17+
18+-- A longer description of the package.
19+description: This package uses the GHC8 Generic representation of records to derive magic classes (a la OverloadedRecordLabels), and prove structural subtyping relationship between records. The latter can be used to upcast the "sub-record" to the more general "interface".
20+
21+-- The license under which the package is released.
22+license: BSD3
23+
24+-- The file containing the license text.
25+license-file: LICENSE
26+
27+-- The package author(s).
28+author: Csongor Kiss
29+
30+-- An email address to which users can send suggestions, bug reports, and
31+-- patches.
32+maintainer: kiss.csongor.kiss@gmail.com
33+
34+-- A copyright notice.
35+-- copyright:
36+
37+category: Generics, Records
38+
39+build-type: Simple
40+
41+-- Extra files to be distributed with the package, such as examples or a
42+-- README.
43+extra-source-files: ChangeLog.md
44+
45+-- Constraint on the version of Cabal needed to build this package.
46+cabal-version: >=1.10
47+
48+
49+library
50+ -- Modules exported by the library.
51+ exposed-modules: Records.Generic
52+
53+ -- Modules included in this library but not exported.
54+ -- other-modules:
55+
56+ -- LANGUAGE extensions used by modules in this package.
57+ other-extensions: DataKinds, DeriveGeneric, DuplicateRecordFields, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, PolyKinds, ScopedTypeVariables, TypeFamilies, TypeApplications, TypeOperators
58+
59+ -- Other library packages from which modules are imported.
60+ build-depends: base >=4.9 && <4.10
61+
62+ -- Directories containing source files.
63+ hs-source-dirs: src
64+
65+ -- Base language which the package is written in.
66+ default-language: Haskell2010
67+
src/Records/Generic.hsnew file+120
@@ -0,0 +1,120 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DuplicateRecordFields #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE UndecidableInstances #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeApplications #-}
11+{-# LANGUAGE TypeOperators #-}
12+
13+module Records.Generic
14+ ( HasField (..)
15+ , Subtype (..)
16+ ) where
17+
18+import GHC.TypeLits (Symbol, TypeError, ErrorMessage(..))
19+import Data.Kind (Type)
20+import Data.Proxy (Proxy(..))
21+import GHC.Generics
22+import Control.Applicative ((<|>))
23+
24+--------------------------------------------------------------------------------
25+
26+-- |Type-level list append
27+type family ((xs :: [k]) ++ (ys :: [k])) :: [k] where
28+ '[] ++ ys = ys
29+ (x ': xs) ++ ys = x ': (xs ++ ys)
30+
31+type family (Collect a) :: [(Symbol, Type)] where
32+ Collect (D1 m cs)
33+ = Collect cs
34+ Collect (C1 mc cs)
35+ = Collect cs
36+ Collect (a :*: b)
37+ = Collect a ++ Collect b
38+ Collect (S1 ('MetaSel ('Just n) p f b) (Rec0 t))
39+ = '[ '(n, t) ]
40+ Collect x = TypeError ('Text "Invalid type")
41+
42+class GHasField rec (field :: Symbol) a where
43+ ggetField :: rec x -> Proxy field -> a
44+
45+instance
46+ ( Contains field (Collect rec) ~ 'Just a
47+ , LookupField rec field a
48+ ) => GHasField rec field a where
49+ ggetField rec p = res
50+ where Just res = lookupField rec p :: Maybe a
51+
52+-- This could be kind polymorphic, but the error message implies this kind anyway
53+type family Contains (sym :: Symbol) (xs :: [(Symbol, Type)]) :: Maybe Type where
54+ Contains s ('(s, t) ': _)
55+ = 'Just t
56+ Contains s (_ ': xs)
57+ = Contains s xs
58+ Contains s _
59+ = TypeError ('Text "Field " ':<>: 'ShowType s ':<>: 'Text " not found in source record")
60+
61+{-
62+ TODO: It's be possible to determine which branch contains the field
63+ (e.g. with a type family) and then we won't need the `Maybe` business.
64+
65+ That will possibly require an extra argument to differentiate between the two
66+ cases in the instance definition (and not just the constraints thereof) to
67+ avoid duplicate instances
68+-}
69+class LookupField a field ret where
70+ lookupField :: a x -> Proxy field -> Maybe ret
71+
72+instance (LookupField a field ret, LookupField b field ret) => LookupField (a :*: b) field ret where
73+ lookupField (a :*: b) p = lookupField a p <|> lookupField b p
74+
75+instance LookupField (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) field t where
76+ lookupField (M1 x) = lookupField x
77+
78+instance {-# OVERLAPS #-} LookupField (S1 ('MetaSel ms su ss ds) t) field x where
79+ lookupField _ _ = Nothing
80+
81+instance {-# OVERLAPS #-} LookupField f field ret => LookupField (M1 i c f) field ret where
82+ lookupField (M1 x) = lookupField x
83+
84+instance LookupField (K1 R a) field a where
85+ lookupField (K1 x) _ = Just x
86+
87+--------------------------------------------------------------------------------
88+class Convert (rep :: Type -> Type) (f :: Type -> Type) where
89+ convert :: rep p -> f p
90+
91+instance (Convert rep a, Convert rep b) => Convert rep (a :*: b) where
92+ convert rep = (convert rep) :*: (convert rep)
93+
94+instance GHasField rep field t => Convert rep (S1 ('MetaSel ('Just field) p f b) (Rec0 t)) where
95+ convert rep = M1 (K1 (ggetField rep (Proxy @field)))
96+
97+instance {-# OVERLAPS #-} Convert rep f => Convert rep (M1 i c f) where
98+ convert = M1 . convert
99+--------------------------------------------------------------------------------
100+
101+-- Exported stuff
102+
103+-- Structural subtype relationship
104+class Subtype a b where
105+ upcast :: a -> b
106+
107+instance (Convert (Rep a) (Rep b), Generic a, Generic b) => Subtype a b where
108+ upcast = to . convert . from
109+
110+class Generic rec => HasField rec (field :: Symbol) a where
111+ getField :: rec -> Proxy field -> a
112+
113+instance
114+ ( Contains field (Collect (Rep rec)) ~ 'Just a
115+ , Generic rec
116+ , LookupField (Rep rec) field a
117+ ) => HasField rec field a where
118+ getField rec p = res
119+ where Just res = lookupField (from rec) p :: Maybe a
120+