-
Notifications
You must be signed in to change notification settings - Fork 0
/
DataTree.purs
212 lines (174 loc) · 6.08 KB
/
DataTree.purs
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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
module InteractiveData.Core.Types.DataTree
( DataTree(..)
, DataTreeChildren(..)
, TreeMeta
, digTrivialTrees
, find
, hasNoChildren
, mapMetadataAlongPath
, setChildren
) where
import Prelude
import Data.Array as Array
import Data.Eq (class Eq1)
import Data.Generic.Rep (class Generic)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, over)
import Data.Ord (class Ord1)
import Data.Tuple (fst)
import Data.Tuple.Nested (type (/\), (/\))
import DataMVC.Types (DataPath, DataPathSegment(..), DataPathSegmentField(..), DataResult)
import Dodo (Doc)
import Dodo as Dodo
import InteractiveData.Core.Types.DataAction (DataAction)
--------------------------------------------------------------------------------
--- Types
--------------------------------------------------------------------------------
type TreeMeta =
{ errored :: DataResult Unit
, typeName :: String
}
newtype DataTree srf msg = DataTree
{ view :: srf msg
, children :: DataTreeChildren srf msg
, actions :: Array (DataAction msg)
, meta :: Maybe TreeMeta
, text :: Maybe String
}
data DataTreeChildren srf msg
= Fields
(Array (DataPathSegmentField /\ DataTree srf msg))
| Case
(String /\ DataTree srf msg)
-- | A trivial tree is
-- | a) a tree with no children (leaf)
-- | b) a tree with a single "field" child
-- | c) a tree with a "case" child
digTrivialTrees
:: forall srf msg
. DataPath
-> DataTree srf msg
-> Array (DataPath /\ DataTree srf msg)
digTrivialTrees path tree@(DataTree { children }) = case children of
Case (_ /\ (DataTree { meta: Just { typeName: "Fields" }, children: Fields [] })) ->
[ path /\ tree ]
-- Case
Case case_ ->
let
(k /\ subTree) = case_
newPath :: DataPath
newPath = path <> [ SegCase k ]
in
[ path /\ tree ] <> digTrivialTrees newPath subTree
-- Singleton "Arguments"
Fields [ SegStaticIndex ix /\ subTree ] ->
let
newPath :: DataPath
newPath = path <> [ SegField $ SegStaticIndex ix ]
in
digTrivialTrees newPath subTree
-- Leaf
Fields [] -> [ path /\ tree ]
-- Singleton static index
Fields [ field@(SegStaticIndex _ /\ _) ] ->
let
k /\ subTree = field
newPath :: DataPath
newPath = path <> [ SegField k ]
in
[ path /\ tree ] <> digTrivialTrees newPath subTree
Fields _ -> [ path /\ tree ]
--------------------------------------------------------------------------------
hasNoChildren :: forall srf msg. DataTree srf msg -> Boolean
hasNoChildren (DataTree { children }) =
case children of
Fields fields -> Array.null fields
Case _ -> false
mapMetadataAlongPath
:: forall srf msg
. DataPath
-> DataTree srf msg
-> Maybe (Array (DataPathSegment /\ TreeMeta))
mapMetadataAlongPath = loop []
where
loop
:: Array (DataPathSegment /\ TreeMeta)
-> Array DataPathSegment
-> DataTree srf msg
-> Maybe (Array (DataPathSegment /\ TreeMeta))
loop accum path (DataTree { children }) =
let
unconsResult :: Maybe { head :: DataPathSegment, tail :: Array DataPathSegment }
unconsResult = Array.uncons path
in
case { unconsResult, children } of
{ unconsResult: Nothing
, children: _
} ->
Just accum
{ unconsResult: Just { head: SegCase casePath, tail }
, children: Case (caseTree /\ tree@(DataTree { meta }))
} ->
if casePath == caseTree then do
meta' <- meta
loop (accum <> [ SegCase casePath /\ meta' ]) tail tree
else
Nothing
{ unconsResult: Just { head: SegField fieldPath, tail }
, children: Fields fields
} -> do
_ /\ tree@(DataTree { meta }) <- Array.find (fst >>> (_ == fieldPath)) fields
meta' <- meta
loop (accum <> [ SegField fieldPath /\ meta' ]) tail tree
_ -> Nothing
setChildren :: forall srf msg. DataTreeChildren srf msg -> DataTree srf msg -> DataTree srf msg
setChildren children = over DataTree _ { children = children }
--------------------------------------------------------------------------------
--- API
--------------------------------------------------------------------------------
find :: forall srf msg. DataPath -> DataTree srf msg -> Maybe (DataTree srf msg)
find path tree@(DataTree { children }) =
case
Array.uncons path,
children
of
Nothing, _ ->
Just tree
Just { head: SegCase casePath, tail },
Case (caseTree /\ tree')
| casePath == caseTree ->
find tail tree'
Just { head: SegField fieldPath, tail },
Fields fields -> do
_ /\ tree' <- Array.find (fst >>> (_ == fieldPath)) fields
find tail tree'
_, _ -> Nothing
prettyPrint :: forall a srf msg. String -> DataTree srf msg -> Doc a
prettyPrint label (DataTree { children }) =
Dodo.lines
[ Dodo.text label
, Dodo.indent (prettyPrintChildren children)
]
where
prettyPrintChildren :: DataTreeChildren srf msg -> Doc a
prettyPrintChildren = case _ of
Fields fields -> Dodo.lines (map (\(key /\ value) -> printItem (show key /\ value)) fields)
Case case_ -> Dodo.lines [ printItem case_ ]
printItem :: String /\ DataTree srf msg -> Doc a
printItem (key /\ value) = Dodo.lines
[ Dodo.text key
, Dodo.indent (prettyPrint "" value)
]
--------------------------------------------------------------------------------
--- Instances
--------------------------------------------------------------------------------
derive instance Newtype (DataTree srf msg) _
derive instance Generic (DataTree srf msg) _
derive instance Functor srf => Functor (DataTreeChildren srf)
derive instance Functor srf => Functor (DataTree srf)
derive instance (Eq1 srf, Eq (srf msg), Eq msg) => Eq (DataTree srf msg)
derive instance (Eq1 srf, Eq (srf msg), Eq msg) => Eq (DataTreeChildren srf msg)
derive instance (Ord (srf msg), Ord1 srf, Ord msg) => Ord (DataTree srf msg)
derive instance (Ord (srf msg), Ord1 srf, Ord msg) => Ord (DataTreeChildren srf msg)
instance Show (DataTree srf msg) where
show tree = "\n" <> (Dodo.print Dodo.plainText Dodo.twoSpaces $ prettyPrint "Root" tree) <> "\n"