1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- | Support for creating lenses from overloaded labels of the type
-- @#fieldName@, or @#"fieldName.subfield"@.
module Data.GI.Base.Internal.PathFieldAccess
( Components, PathFieldAccess(..)) where
import qualified GHC.TypeLits as TL
import Data.Kind (Constraint, Type)
import Data.Proxy (Proxy(..))
import qualified Data.Text as T
import qualified Optics.Core as O
import qualified Optics.Internal.Generic as OG
-- The Char class was introduced in GHC 9.2 (base 4.16), if this is
-- not available we fall back to an implementation that does not allow
-- for nested access. Note that overloaded labels of the form
-- #"record.subrecord" only became valid syntax in GHC 9.6, so this is
-- only really useful from that version.
#if MIN_VERSION_base(4,16,0)
type family AppendChar (s :: TL.Symbol) (c :: Char) where
AppendChar s c = TL.AppendSymbol s (TL.ConsSymbol c "")
type family DoSplit (c :: Char) (acc :: TL.Symbol) (uncons :: Maybe (Char, TL.Symbol)) where
DoSplit _ acc Nothing = '[acc]
DoSplit c acc (Just '(c, rest)) = acc : DoSplit c "" (TL.UnconsSymbol rest)
DoSplit c acc (Just '(k, rest)) = DoSplit c (AppendChar acc k) (TL.UnconsSymbol rest)
type family SplitByChar (c :: Char) (s :: TL.Symbol) :: [TL.Symbol] where
SplitByChar c s = DoSplit c "" (TL.UnconsSymbol s)
type family Components (s :: TL.Symbol) :: [TL.Symbol] where
Components s = SplitByChar '.' s
#else
type family Components (s :: TL.Symbol) :: [TL.Symbol] where
Components s = '[s]
#endif
-- | Check that the given symbol is not the empty string. If it is,
-- raise a TypeError with the given msg.
type family NonEmpty (s :: TL.Symbol) (msg :: TL.ErrorMessage) :: Constraint where
NonEmpty "" msg = TL.TypeError msg
NonEmpty _ _ = ()
-- | Create a lens for the given path, and return it together with the
-- path split into components.
class PathFieldAccess (path :: [TL.Symbol]) (model :: Type) (val :: Type) | path model -> val where
pathFieldAccess :: Proxy path -> Proxy model -> (O.Lens' model val, [T.Text])
instance {-# OVERLAPPING #-}
(OG.GFieldImpl fieldName model model val val,
NonEmpty fieldName (TL.Text "Field names cannot be empty"),
TL.KnownSymbol fieldName) =>
PathFieldAccess (fieldName : '[]) model val where
pathFieldAccess _ _ = (OG.gfieldImpl @fieldName @model @model @val @val,
[T.pack $ TL.symbolVal (Proxy @fieldName)])
instance (OG.GFieldImpl fieldName model model val val,
TL.KnownSymbol fieldName,
PathFieldAccess rest val inner) =>
PathFieldAccess (fieldName : rest) model inner where
pathFieldAccess _ _ =
let (innerLens, innerPath) = pathFieldAccess (Proxy @rest) (Proxy @val)
outerLens = OG.gfieldImpl @fieldName @model @model @val @val
outerName = T.pack $ TL.symbolVal (Proxy @fieldName)
in (outerLens O.% innerLens, outerName : innerPath)
|
