{-# LANGUAGE OverloadedStrings #-}
module Graphics.Vega.VegaLite.Selection
( selection
, select
, Selection(..)
, SelectionProperty(..)
, Binding(..)
, BindLegendProperty(..)
, InputProperty(..)
, SelectionMarkProperty(..)
, SelectionResolution(..)
, selectionProperties
, selectionLabel
)
where
import qualified Data.Text as T
import Control.Arrow (second)
import Data.Aeson ((.=), object, toJSON)
import Data.Aeson.Types (Pair)
import Data.Maybe (mapMaybe)
import Graphics.Vega.VegaLite.Data
( DataValue
, dataValueSpec
)
import Graphics.Vega.VegaLite.Foundation
( Color
, DashStyle
, DashOffset
, FieldName
, Opacity
, Channel
, Cursor
, channelLabel
, fromT
, fromColor
, fromDS
, cursorLabel
, (.=~), toKey, toObject
)
import Graphics.Vega.VegaLite.Specification
( VLProperty(VLSelection)
, PropertySpec
, SelectSpec(..)
, BuildSelectSpecs
, SelectionLabel
)
data Selection
= Single
| Multi
| Interval
selectionLabel :: Selection -> T.Text
selectionLabel :: Selection -> Text
selectionLabel Selection
Single = Text
"single"
selectionLabel Selection
Multi = Text
"multi"
selectionLabel Selection
Interval = Text
"interval"
data SelectionProperty
= Empty
| BindScales
| BindLegend BindLegendProperty
| On T.Text
| Clear T.Text
| Translate T.Text
| Zoom T.Text
| Fields [FieldName]
| Encodings [Channel]
| SInit [(FieldName, DataValue)]
| SInitInterval (Maybe (DataValue, DataValue)) (Maybe (DataValue, DataValue))
| ResolveSelections SelectionResolution
| SelectionMark [SelectionMarkProperty]
| Bind [Binding]
| Nearest Bool
| Toggle T.Text
selectionProperties :: SelectionProperty -> [Pair]
selectionProperties :: SelectionProperty -> [Pair]
selectionProperties (Fields [Text]
fNames) = [Key
"fields" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Text]
fNames]
selectionProperties (Encodings [Channel]
channels) = [Key
"encodings" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a b. (a -> b) -> [a] -> [b]
map Channel -> Text
channelLabel [Channel]
channels]
selectionProperties (SInit [(Text, DataValue)]
iVals) = [Key
"init" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [LabelledSpec] -> VLSpec
toObject (forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second DataValue -> VLSpec
dataValueSpec) [(Text, DataValue)]
iVals)]
selectionProperties (SInitInterval Maybe (DataValue, DataValue)
Nothing Maybe (DataValue, DataValue)
Nothing) = []
selectionProperties (SInitInterval Maybe (DataValue, DataValue)
mx Maybe (DataValue, DataValue)
my) =
let conv :: (Key, Maybe (DataValue, DataValue)) -> Maybe a
conv (Key
_, Maybe (DataValue, DataValue)
Nothing) = forall a. Maybe a
Nothing
conv (Key
lbl, Just (DataValue
lo, DataValue
hi)) = forall a. a -> Maybe a
Just (Key
lbl forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [ DataValue -> VLSpec
dataValueSpec DataValue
lo, DataValue -> VLSpec
dataValueSpec DataValue
hi ])
in [Key
"init" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> VLSpec
object (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a}.
KeyValue a =>
(Key, Maybe (DataValue, DataValue)) -> Maybe a
conv (forall a b. [a] -> [b] -> [(a, b)]
zip [Key
"x", Key
"y"] [Maybe (DataValue, DataValue)
mx, Maybe (DataValue, DataValue)
my]))]
selectionProperties (On Text
e) = [Key
"on" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
e]
selectionProperties (Clear Text
e) =
let t :: Text
t = Text -> Text
T.strip Text
e
in [Key
"clear" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= if Text -> Bool
T.null Text
t then forall a. ToJSON a => a -> VLSpec
toJSON Bool
False else forall a. ToJSON a => a -> VLSpec
toJSON Text
t]
selectionProperties SelectionProperty
Empty = [Key
"empty" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> VLSpec
fromT Text
"none"]
selectionProperties (ResolveSelections SelectionResolution
res) = [Key
"resolve" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= SelectionResolution -> Text
selectionResolutionLabel SelectionResolution
res]
selectionProperties (SelectionMark [SelectionMarkProperty]
markProps) = [Key
"mark" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> VLSpec
object (forall a b. (a -> b) -> [a] -> [b]
map SelectionMarkProperty -> Pair
selectionMarkProperty [SelectionMarkProperty]
markProps)]
selectionProperties SelectionProperty
BindScales = [Key
"bind" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> VLSpec
fromT Text
"scales"]
selectionProperties (BindLegend BindLegendProperty
blp) = BindLegendProperty -> [Pair]
bindLegendProperty BindLegendProperty
blp
selectionProperties (Bind [Binding]
binds) = [Key
"bind" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> VLSpec
object (forall a b. (a -> b) -> [a] -> [b]
map Binding -> Pair
bindingSpec [Binding]
binds)]
selectionProperties (Nearest Bool
b) = [Key
"nearest" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
b]
selectionProperties (Toggle Text
expr) = [Key
"toggle" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
expr]
selectionProperties (Translate Text
e) = [Key
"translate" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= if Text -> Bool
T.null Text
e then forall a. ToJSON a => a -> VLSpec
toJSON Bool
False else forall a. ToJSON a => a -> VLSpec
toJSON Text
e]
selectionProperties (Zoom Text
e) = [Key
"zoom" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= if Text -> Bool
T.null Text
e then forall a. ToJSON a => a -> VLSpec
toJSON Bool
False else forall a. ToJSON a => a -> VLSpec
toJSON Text
e]
data SelectionResolution
= Global
| Union
| Intersection
selectionResolutionLabel :: SelectionResolution -> T.Text
selectionResolutionLabel :: SelectionResolution -> Text
selectionResolutionLabel SelectionResolution
Global = Text
"global"
selectionResolutionLabel SelectionResolution
Union = Text
"union"
selectionResolutionLabel SelectionResolution
Intersection = Text
"intersect"
data SelectionMarkProperty
= SMCursor Cursor
| SMFill Color
| SMFillOpacity Opacity
| SMStroke Color
| SMStrokeOpacity Opacity
| SMStrokeWidth Double
| SMStrokeDash DashStyle
| SMStrokeDashOffset DashOffset
selectionMarkProperty :: SelectionMarkProperty -> Pair
selectionMarkProperty :: SelectionMarkProperty -> Pair
selectionMarkProperty (SMCursor Cursor
c) = Key
"cursor" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Cursor -> Text
cursorLabel Cursor
c
selectionMarkProperty (SMFill Text
colour) = Key
"fill" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> VLSpec
fromColor Text
colour
selectionMarkProperty (SMFillOpacity Double
x) = Key
"fillOpacity" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
x
selectionMarkProperty (SMStroke Text
colour) = Key
"stroke" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> VLSpec
fromColor Text
colour
selectionMarkProperty (SMStrokeOpacity Double
x) = Key
"strokeOpacity" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
x
selectionMarkProperty (SMStrokeWidth Double
x) = Key
"strokeWidth" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
x
selectionMarkProperty (SMStrokeDash DashStyle
xs) = Key
"strokeDash" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DashStyle -> VLSpec
fromDS DashStyle
xs
selectionMarkProperty (SMStrokeDashOffset Double
x) = Key
"strokeDashOffset" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
x
data InputProperty
= Debounce Double
| Element T.Text
| InOptions [T.Text]
| InMin Double
| InMax Double
| InName T.Text
| InStep Double
| InPlaceholder T.Text
inputProperty :: InputProperty -> Pair
inputProperty :: InputProperty -> Pair
inputProperty (Debounce Double
x) = Key
"debounce" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
x
inputProperty (Element Text
el) = Key
"element" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
el
inputProperty (InOptions [Text]
opts) = Key
"options" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a b. (a -> b) -> [a] -> [b]
map forall a. ToJSON a => a -> VLSpec
toJSON [Text]
opts
inputProperty (InMin Double
x) = Key
"min" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
x
inputProperty (InMax Double
x) = Key
"max" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
x
inputProperty (InName Text
s) = Key
"name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
s
inputProperty (InStep Double
x) = Key
"step" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
x
inputProperty (InPlaceholder Text
el) = Key
"placeholder" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> VLSpec
toJSON Text
el
data Binding
= IRange T.Text [InputProperty]
| ICheckbox T.Text [InputProperty]
| IRadio T.Text [InputProperty]
| ISelect T.Text [InputProperty]
| IText T.Text [InputProperty]
| INumber T.Text [InputProperty]
| IDate T.Text [InputProperty]
| ITime T.Text [InputProperty]
| IMonth T.Text [InputProperty]
| IWeek T.Text [InputProperty]
| IDateTimeLocal T.Text [InputProperty]
| ITel T.Text [InputProperty]
| IColor T.Text [InputProperty]
bindingSpec :: Binding -> Pair
bindingSpec :: Binding -> Pair
bindingSpec Binding
bnd =
let (Text
lbl, VLSpec
input, [InputProperty]
ps) = case Binding
bnd of
IRange Text
label [InputProperty]
props -> (Text
label, Text -> VLSpec
fromT Text
"range", [InputProperty]
props)
ICheckbox Text
label [InputProperty]
props -> (Text
label, VLSpec
"checkbox", [InputProperty]
props)
IRadio Text
label [InputProperty]
props -> (Text
label, VLSpec
"radio", [InputProperty]
props)
ISelect Text
label [InputProperty]
props -> (Text
label, VLSpec
"select", [InputProperty]
props)
IText Text
label [InputProperty]
props -> (Text
label, VLSpec
"text", [InputProperty]
props)
INumber Text
label [InputProperty]
props -> (Text
label, VLSpec
"number", [InputProperty]
props)
IDate Text
label [InputProperty]
props -> (Text
label, VLSpec
"date", [InputProperty]
props)
ITime Text
label [InputProperty]
props -> (Text
label, VLSpec
"time", [InputProperty]
props)
IMonth Text
label [InputProperty]
props -> (Text
label, VLSpec
"month", [InputProperty]
props)
IWeek Text
label [InputProperty]
props -> (Text
label, VLSpec
"week", [InputProperty]
props)
IDateTimeLocal Text
label [InputProperty]
props -> (Text
label, VLSpec
"datetimelocal", [InputProperty]
props)
ITel Text
label [InputProperty]
props -> (Text
label, VLSpec
"tel", [InputProperty]
props)
IColor Text
label [InputProperty]
props -> (Text
label, VLSpec
"color", [InputProperty]
props)
in LabelledSpec -> Pair
toKey (Text
lbl, [Pair] -> VLSpec
object ((Key
"input" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= VLSpec
input) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map InputProperty -> Pair
inputProperty [InputProperty]
ps))
data BindLegendProperty
= BLField FieldName
| BLChannel Channel
| BLFieldEvent FieldName T.Text
| BLChannelEvent Channel T.Text
bindLegendProperty :: BindLegendProperty -> [Pair]
bindLegendProperty :: BindLegendProperty -> [Pair]
bindLegendProperty (BLField Text
f) = [ Maybe Text -> Pair
toLBind forall a. Maybe a
Nothing
, Key
"fields" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Text
f]
]
bindLegendProperty (BLChannel Channel
ch) = [ Maybe Text -> Pair
toLBind forall a. Maybe a
Nothing
, Key
"encodings" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Channel -> Text
channelLabel Channel
ch]
]
bindLegendProperty (BLFieldEvent Text
f Text
es) = [ Maybe Text -> Pair
toLBind (forall a. a -> Maybe a
Just Text
es)
, Key
"fields" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Text
f]
]
bindLegendProperty (BLChannelEvent Channel
ch Text
es) = [ Maybe Text -> Pair
toLBind (forall a. a -> Maybe a
Just Text
es)
, Key
"encodings" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Channel -> Text
channelLabel Channel
ch]
]
toLBind :: Maybe T.Text -> Pair
toLBind :: Maybe Text -> Pair
toLBind Maybe Text
Nothing = Key
"bind" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> VLSpec
fromT Text
"legend"
toLBind (Just Text
es) = Key
"bind" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> VLSpec
object [Key
"legend" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
es]
selection ::
[SelectSpec]
-> PropertySpec
selection :: [SelectSpec] -> PropertySpec
selection [SelectSpec]
sels = (VLProperty
VLSelection, [LabelledSpec] -> VLSpec
toObject (forall a b. (a -> b) -> [a] -> [b]
map SelectSpec -> LabelledSpec
unS [SelectSpec]
sels))
select ::
SelectionLabel
-> Selection
-> [SelectionProperty]
-> BuildSelectSpecs
select :: Text -> Selection -> [SelectionProperty] -> BuildSelectSpecs
select Text
nme Selection
sType [SelectionProperty]
options [SelectSpec]
ols =
let selProps :: [Pair]
selProps = (Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Selection -> Text
selectionLabel Selection
sType) forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SelectionProperty -> [Pair]
selectionProperties [SelectionProperty]
options
in LabelledSpec -> SelectSpec
S (Text
nme forall a. ToJSON a => Text -> a -> LabelledSpec
.=~ [Pair] -> VLSpec
object [Pair]
selProps) forall a. a -> [a] -> [a]
: [SelectSpec]
ols