git.iko.soy/rel8
on master help sign in
Simplify Labels
db148ffShane O'Brien
src/Rel8/Kind/Labels.hs+14−18
compare with master
unifiedsplit
@@ -8,7 +8,7 @@
8
8
9module Rel8.Kind.Labels
9module Rel8.Kind.Labels
10 ( Labels
10 ( Labels
11− , SLabels( SLabel, SLabels )
11+ , SLabels( SNil, SCons )
12 , KnownLabels( labelsSing )
12 , KnownLabels( labelsSing )
13 , renderLabels
13 , renderLabels
14 )
14 )
@@ -16,7 +16,8 @@ where
16
16
17-- base
17-- base
18import Data.Kind ( Constraint, Type )
18import Data.Kind ( Constraint, Type )
19−import Data.List.NonEmpty ( NonEmpty( (:|) ), (<|) )
19+import Data.List.NonEmpty ( NonEmpty, nonEmpty )
20+import Data.Maybe ( fromMaybe )
20import Data.Proxy ( Proxy( Proxy ) )
21import Data.Proxy ( Proxy( Proxy ) )
21import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
22import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
22import Prelude
23import Prelude
@@ -28,8 +29,8 @@ type Labels = [Symbol]
28
29
29type SLabels :: Labels -> Type
30type SLabels :: Labels -> Type
30data SLabels labels where
31data SLabels labels where
31− SLabel :: KnownSymbol label => Proxy label -> SLabels '[label]
32+ SNil :: SLabels '[]
32− SLabels :: KnownSymbol label => Proxy label -> SLabels labels -> SLabels (label ': labels)
33+ SCons :: KnownSymbol label => Proxy label -> SLabels labels -> SLabels (label ': labels)
33
34
34
35
35type KnownLabels :: Labels -> Constraint
36type KnownLabels :: Labels -> Constraint
@@ -37,25 +38,20 @@ class KnownLabels labels where
37 labelsSing :: SLabels labels
38 labelsSing :: SLabels labels
38
39
39
40
40−instance KnownSymbol label => KnownLabels (label ': '[]) where
41+instance KnownLabels '[] where
41− labelsSing = SLabel Proxy
42+ labelsSing = SNil
42
43
43
44
44−instance (KnownSymbol label, KnownLabels (label_ ': labels)) =>
45+instance (KnownSymbol label, KnownLabels labels) =>
45− KnownLabels (label ': (label_ ': labels))
46+ KnownLabels (label ': labels)
46 where
47 where
47− labelsSing = SLabels Proxy labelsSing
48+ labelsSing = SCons Proxy labelsSing
48
49
49
50
50renderLabels :: SLabels labels -> NonEmpty String
51renderLabels :: SLabels labels -> NonEmpty String
51−renderLabels = cleanup . go
52+renderLabels = fromMaybe (pure "anon") . nonEmpty . go
52 where
53 where
53− go :: SLabels labels -> NonEmpty String
54+ go :: SLabels labels -> [String]
54 go = \case
55 go = \case
55− SLabel label -> pure (symbolVal label)
56+ SNil -> []
56− SLabels label labels -> symbolVal label <| go labels
57+ SCons label labels -> symbolVal label : go labels
57−
58− cleanup ("" :| []) = "anon" :| []
59− cleanup (a :| []) = a :| []
60− cleanup (a :| [""]) = a :| []
61− cleanup (a :| (b : c)) = a <| cleanup (b :| c)
src/Rel8/Schema/HTable/Label.hs+2−2
@@ -28,7 +28,7 @@ import GHC.TypeLits ( KnownSymbol, Symbol )
28import Prelude
28import Prelude
29
29
30-- rel8
30-- rel8
31−import Rel8.Kind.Labels ( SLabels( SLabels ) )
31+import Rel8.Kind.Labels ( SLabels( SCons ) )
32import Rel8.Schema.HTable
32import Rel8.Schema.HTable
33 ( HTable
33 ( HTable
34 , hfield, htabulate, hspecs
34 , hfield, htabulate, hspecs
@@ -54,7 +54,7 @@ type instance Eval (Label label ('Spec labels necessity a)) = 'Spec (label : lab
54
54
55instance KnownSymbol l => MapSpec (Label l) where
55instance KnownSymbol l => MapSpec (Label l) where
56 mapInfo = \case
56 mapInfo = \case
57− SSpec {..} -> SSpec {labels = SLabels Proxy labels, ..}
57+ SSpec {..} -> SSpec {labels = SCons Proxy labels, ..}
58
58
59
59
60hlabel :: (HTable t, KnownSymbol label)
60hlabel :: (HTable t, KnownSymbol label)
src/Rel8/Schema/HTable/Type.hs+5−6
@@ -11,11 +11,10 @@ where
11
11
12-- base
12-- base
13import Data.Kind ( Type )
13import Data.Kind ( Type )
14−import Data.Proxy ( Proxy( Proxy ) )
15import Prelude
14import Prelude
16
15
17-- rel8
16-- rel8
18−import Rel8.Kind.Labels ( SLabels( SLabel ) )
17+import Rel8.Kind.Labels ( SLabels( SNil ) )
19import Rel8.Kind.Necessity ( Necessity( Required ), SNecessity( SRequired ) )
18import Rel8.Kind.Necessity ( Necessity( Required ), SNecessity( SRequired ) )
20import Rel8.Schema.Dict ( Dict( Dict ) )
19import Rel8.Schema.Dict ( Dict( Dict ) )
21import Rel8.Schema.HTable
20import Rel8.Schema.HTable
@@ -30,17 +29,17 @@ import Rel8.Type ( DBType, typeInformation )
30
29
31type HType :: Type -> K.HTable
30type HType :: Type -> K.HTable
32newtype HType a context = HType
31newtype HType a context = HType
33− { unHType :: context ('Spec '[""] 'Required a)
32+ { unHType :: context ('Spec '[] 'Required a)
34 }
33 }
35
34
36
35
37type HTypeField :: Type -> Spec -> Type
36type HTypeField :: Type -> Spec -> Type
38data HTypeField a spec where
37data HTypeField a spec where
39− HTypeField :: HTypeField a ('Spec '[""] 'Required a)
38+ HTypeField :: HTypeField a ('Spec '[] 'Required a)
40
39
41
40
42instance Sql DBType a => HTable (HType a) where
41instance Sql DBType a => HTable (HType a) where
43− type HConstrainTable (HType a) c = c ('Spec '[""] 'Required a)
42+ type HConstrainTable (HType a) c = c ('Spec '[] 'Required a)
44 type HField (HType a) = HTypeField a
43 type HField (HType a) = HTypeField a
45
44
46 hfield (HType a) HTypeField = a
45 hfield (HType a) HTypeField = a
@@ -48,7 +47,7 @@ instance Sql DBType a => HTable (HType a) where
48 htraverse f (HType a) = HType <$> f a
47 htraverse f (HType a) = HType <$> f a
49 hdicts = HType Dict
48 hdicts = HType Dict
50 hspecs = HType SSpec
49 hspecs = HType SSpec
51− { labels = SLabel Proxy
50+ { labels = SNil
52 , necessity = SRequired
51 , necessity = SRequired
53 , info = typeInformation
52 , info = typeInformation
54 , nullity = nullable
53 , nullity = nullable