{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Graphics.Vega.VegaLite.Input
( Data
, DataColumn
, DataRow
, Format(..)
, DataType(..)
, dataFromUrl
, dataFromColumns
, dataFromRows
, dataFromJson
, dataFromSource
, dataName
, datasets
, dataColumn
, dataRow
, noData
, dataSequence
, dataSequenceAs
) where
import qualified Data.Aeson as A
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import Control.Arrow (second)
import Data.Aeson ((.=), Value, decode, encode, object, toJSON)
import Data.Aeson.Types (Pair)
import Data.Maybe (fromMaybe, mapMaybe)
#if !(MIN_VERSION_base(4, 12, 0))
import Data.Monoid ((<>))
#endif
import Graphics.Vega.VegaLite.Data
( DataValue(..)
, DataValues(..)
, dataValueSpec
)
import Graphics.Vega.VegaLite.Foundation
( FieldName
, toObject
)
import Graphics.Vega.VegaLite.Specification
( VLProperty(VLData, VLDatasets)
, VLSpec
, LabelledSpec
)
import Graphics.Vega.VegaLite.Time (dateTimeSpec)
data DataType
= FoNumber
| FoBoolean
| FoDate T.Text
| FoUtc T.Text
data Format
= JSON T.Text
| CSV
| TSV
| DSV Char
| TopojsonFeature T.Text
| TopojsonMesh T.Text
| Parse [(FieldName, DataType)]
type DataColumn = [LabelledSpec]
type DataRow = VLSpec
type Data = (VLProperty, VLSpec)
formatProperty :: Format -> [Pair]
formatProperty :: Format -> [Pair]
formatProperty (JSON Text
js) =
let ps :: [(Key, Text)]
ps = [(Key
"type", Text
"json")]
[(Key, Text)] -> [(Key, Text)] -> [(Key, Text)]
forall a. Semigroup a => a -> a -> a
<> if Text -> Bool
T.null (Text -> Text
T.strip Text
js) then [] else [(Key
"property", Text
js)]
in ((Key, Text) -> Pair) -> [(Key, Text)] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Value) -> (Key, Text) -> Pair
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Text -> Value
forall a. ToJSON a => a -> Value
toJSON) [(Key, Text)]
ps
formatProperty Format
CSV = [(Key
"type", Value
"csv")]
formatProperty Format
TSV = [(Key
"type", Value
"tsv")]
formatProperty (DSV Char
delim) = [(Key
"type", Value
"dsv"), Key
"delimiter" Key -> Char -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Char
delim]
formatProperty (TopojsonFeature Text
os) = [(Key
"type", Value
"topojson")
, Key
"feature" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
os
]
formatProperty (TopojsonMesh Text
os) = [(Key
"type", Value
"topojson")
, Key
"mesh" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
os
]
formatProperty (Parse [(Text, DataType)]
fmts) =
let pObj :: Value
pObj = [LabelledSpec] -> Value
toObject (((Text, DataType) -> LabelledSpec)
-> [(Text, DataType)] -> [LabelledSpec]
forall a b. (a -> b) -> [a] -> [b]
map ((DataType -> Value) -> (Text, DataType) -> LabelledSpec
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second DataType -> Value
dataTypeSpec) [(Text, DataType)]
fmts)
in [(Key
"parse", Value
pObj)]
dataTypeSpec :: DataType -> VLSpec
dataTypeSpec :: DataType -> Value
dataTypeSpec DataType
dType =
let s :: Text
s = case DataType
dType of
DataType
FoNumber -> Text
"number"
DataType
FoBoolean -> Text
"boolean"
FoDate Text
fmt | Text -> Bool
T.null Text
fmt -> Text
"date"
| Bool
otherwise -> Text
"date:'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fmt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
FoUtc Text
fmt | Text -> Bool
T.null Text
fmt -> Text
"utc"
| Bool
otherwise -> Text
"utc:'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
fmt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
in Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
s
dataRow :: [(FieldName, DataValue)] -> [DataRow] -> [DataRow]
dataRow :: [(Text, DataValue)] -> [Value] -> [Value]
dataRow [(Text, DataValue)]
rw = ([LabelledSpec] -> Value
toObject (((Text, DataValue) -> LabelledSpec)
-> [(Text, DataValue)] -> [LabelledSpec]
forall a b. (a -> b) -> [a] -> [b]
map ((DataValue -> Value) -> (Text, DataValue) -> LabelledSpec
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second DataValue -> Value
dataValueSpec) [(Text, DataValue)]
rw) Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:)
datasets :: [(T.Text, Data)] -> Data
datasets :: [(Text, Data)] -> Data
datasets [(Text, Data)]
namedData =
let converted :: (a, Value) -> Value
converted = Value -> Value
extract (Value -> Value) -> ((a, Value) -> Value) -> (a, Value) -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Value) -> Value
forall a b. (a, b) -> b
snd
specs :: [LabelledSpec]
specs = ((Text, Data) -> LabelledSpec) -> [(Text, Data)] -> [LabelledSpec]
forall a b. (a -> b) -> [a] -> [b]
map ((Data -> Value) -> (Text, Data) -> LabelledSpec
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Data -> Value
forall a. (a, Value) -> Value
converted) [(Text, Data)]
namedData
convert :: Value -> Maybe [(T.Text, Value)]
convert :: Value -> Maybe [LabelledSpec]
convert Value
v = HashMap Text Value -> [LabelledSpec]
forall k v. HashMap k v -> [(k, v)]
HM.toList (HashMap Text Value -> [LabelledSpec])
-> Maybe (HashMap Text Value) -> Maybe [LabelledSpec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe (HashMap Text Value)
forall a. FromJSON a => ByteString -> Maybe a
decode (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
v)
extract :: Value -> Value
extract Value
din =
let extract' :: [(a, a)] -> Maybe a
extract' [(a
_, a
v)] = a -> Maybe a
forall a. a -> Maybe a
Just a
v
extract' [(a, a)]
_ = Maybe a
forall a. Maybe a
Nothing
in Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
din (Value -> Maybe [LabelledSpec]
convert Value
din Maybe [LabelledSpec]
-> ([LabelledSpec] -> Maybe Value) -> Maybe Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [LabelledSpec] -> Maybe Value
forall a a. [(a, a)] -> Maybe a
extract')
in (VLProperty
VLDatasets, [LabelledSpec] -> Value
toObject [LabelledSpec]
specs)
noData :: Data
noData :: Data
noData = (VLProperty
VLData, Value
A.Null)
dataName ::
T.Text
-> Data
-> Data
dataName :: Text -> Data -> Data
dataName Text
s odata :: Data
odata@(VLProperty
_, Value
dataSpec) =
let converted :: Maybe Pair
converted = Maybe [Pair]
convert Maybe [Pair] -> ([Pair] -> Maybe Pair) -> Maybe Pair
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Pair] -> Maybe Pair
forall a. [a] -> Maybe a
extract
convert :: Maybe [Pair]
convert :: Maybe [Pair]
convert = HashMap Key Value -> [Pair]
forall k v. HashMap k v -> [(k, v)]
HM.toList (HashMap Key Value -> [Pair])
-> Maybe (HashMap Key Value) -> Maybe [Pair]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe (HashMap Key Value)
forall a. FromJSON a => ByteString -> Maybe a
decode (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
dataSpec)
extract :: [a] -> Maybe a
extract [a
v] = a -> Maybe a
forall a. a -> Maybe a
Just a
v
extract [a]
_ = Maybe a
forall a. Maybe a
Nothing
in case Maybe Pair
converted of
Just Pair
v -> (VLProperty
VLData, [Pair] -> Value
object [ Key
"name" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
s, Pair
v ])
Maybe Pair
_ -> Data
odata
dataFromColumns ::
[Format]
-> [DataColumn]
-> Data
dataFromColumns :: [Format] -> [[LabelledSpec]] -> Data
dataFromColumns [Format]
fmts [[LabelledSpec]]
cols =
let dataArray :: [Value]
dataArray = ([LabelledSpec] -> Value) -> [[LabelledSpec]] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map [LabelledSpec] -> Value
toObject ([[LabelledSpec]] -> [[LabelledSpec]]
forall a. [[a]] -> [[a]]
transpose [[LabelledSpec]]
cols)
vals :: [Pair]
vals = [(Key
"values", [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON [Value]
dataArray)]
[Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> if [Format] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Format]
fmts
then []
else [(Key
"format", Value -> Value
forall a. ToJSON a => a -> Value
toJSON Value
fmtObject)]
fmtObject :: Value
fmtObject = [Pair] -> Value
object ((Format -> [Pair]) -> [Format] -> [Pair]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Format -> [Pair]
formatProperty [Format]
fmts)
in (VLProperty
VLData, [Pair] -> Value
object [Pair]
vals)
transpose :: [[a]] -> [[a]]
transpose :: [[a]] -> [[a]]
transpose [] = []
transpose ([]:[[a]]
xss) = [[a]] -> [[a]]
forall a. [[a]] -> [[a]]
transpose [[a]]
xss
transpose ((a
x:[a]
xs) : [[a]]
xss) =
let heads :: [a]
heads = ([a] -> Maybe a) -> [[a]] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
filterMap [a] -> Maybe a
forall a. [a] -> Maybe a
elmHead [[a]]
xss
tails :: [[a]]
tails = ([a] -> Maybe [a]) -> [[a]] -> [[a]]
forall a b. (a -> Maybe b) -> [a] -> [b]
filterMap [a] -> Maybe [a]
forall a. [a] -> Maybe [a]
elmTail [[a]]
xss
elmHead :: [a] -> Maybe a
elmHead (a
h:[a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
h
elmHead [] = Maybe a
forall a. Maybe a
Nothing
elmTail :: [a] -> Maybe [a]
elmTail [] = Maybe [a]
forall a. Maybe a
Nothing
elmTail (a
_:[a]
ts) = [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
ts
filterMap :: (a -> Maybe b) -> [a] -> [b]
filterMap = (a -> Maybe b) -> [a] -> [b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
in (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
heads) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]] -> [[a]]
forall a. [[a]] -> [[a]]
transpose ([a]
xs [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
tails)
dataFromJson :: VLSpec -> [Format] -> Data
dataFromJson :: Value -> [Format] -> Data
dataFromJson Value
vlspec [Format]
fmts =
let js :: Value
js = if [Format] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Format]
fmts
then [Pair] -> Value
object [(Key
"values", Value
vlspec)]
else [Pair] -> Value
object [ (Key
"values", Value
vlspec)
, (Key
"format",
[Pair] -> Value
object ((Format -> [Pair]) -> [Format] -> [Pair]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Format -> [Pair]
formatProperty [Format]
fmts)) ]
in (VLProperty
VLData, Value
js)
dataColumn :: FieldName -> DataValues -> [DataColumn] -> [DataColumn]
dataColumn :: Text -> DataValues -> [[LabelledSpec]] -> [[LabelledSpec]]
dataColumn Text
colName DataValues
dVals [[LabelledSpec]]
xs =
let col :: [Value]
col = case DataValues
dVals of
Booleans [Bool]
cs -> (Bool -> Value) -> [Bool] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Bool -> Value
forall a. ToJSON a => a -> Value
toJSON [Bool]
cs
DateTimes [[DateTime]]
cs -> ([DateTime] -> Value) -> [[DateTime]] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map [DateTime] -> Value
dateTimeSpec [[DateTime]]
cs
Numbers [Double]
cs -> (Double -> Value) -> [Double] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Double -> Value
forall a. ToJSON a => a -> Value
toJSON [Double]
cs
Strings [Text]
cs -> (Text -> Value) -> [Text] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Value
forall a. ToJSON a => a -> Value
toJSON [Text]
cs
x :: [LabelledSpec]
x = (Value -> LabelledSpec) -> [Value] -> [LabelledSpec]
forall a b. (a -> b) -> [a] -> [b]
map (Text
colName,) [Value]
col
in [LabelledSpec]
x [LabelledSpec] -> [[LabelledSpec]] -> [[LabelledSpec]]
forall a. a -> [a] -> [a]
: [[LabelledSpec]]
xs
dataFromRows ::
[Format]
-> [DataRow]
-> Data
dataFromRows :: [Format] -> [Value] -> Data
dataFromRows [Format]
fmts [Value]
rows =
let kvs :: [Pair]
kvs = (Key
"values", [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON [Value]
rows)
Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: if [Format] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Format]
fmts
then []
else [(Key
"format", [Pair] -> Value
object ((Format -> [Pair]) -> [Format] -> [Pair]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Format -> [Pair]
formatProperty [Format]
fmts))]
in (VLProperty
VLData, [Pair] -> Value
object [Pair]
kvs)
dataFromSource :: T.Text -> [Format] -> Data
dataFromSource :: Text -> [Format] -> Data
dataFromSource Text
sourceName [Format]
fmts =
let kvs :: [Pair]
kvs = (Key
"name" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
sourceName)
Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: if [Format] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Format]
fmts
then []
else [(Key
"format", [Pair] -> Value
object ((Format -> [Pair]) -> [Format] -> [Pair]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Format -> [Pair]
formatProperty [Format]
fmts))]
in (VLProperty
VLData, [Pair] -> Value
object [Pair]
kvs)
dataFromUrl :: T.Text -> [Format] -> Data
dataFromUrl :: Text -> [Format] -> Data
dataFromUrl Text
url [Format]
fmts =
let kvs :: [Pair]
kvs = (Key
"url" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
url)
Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: if [Format] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Format]
fmts
then []
else [(Key
"format", [Pair] -> Value
object ((Format -> [Pair]) -> [Format] -> [Pair]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Format -> [Pair]
formatProperty [Format]
fmts))]
in (VLProperty
VLData, [Pair] -> Value
object [Pair]
kvs)
dataSequence ::
Double
-> Double
-> Double
-> Data
dataSequence :: Double -> Double -> Double -> Data
dataSequence Double
start Double
stop Double
step =
let vals :: [Pair]
vals = [(Key
"sequence", [Pair] -> Value
object [Pair]
svals)]
svals :: [Pair]
svals = [ Key
"start" Key -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
start
, Key
"stop" Key -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
stop
, Key
"step" Key -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
step
]
in (VLProperty
VLData, [Pair] -> Value
object [Pair]
vals)
dataSequenceAs ::
Double
-> Double
-> Double
-> FieldName
-> Data
dataSequenceAs :: Double -> Double -> Double -> Text -> Data
dataSequenceAs Double
start Double
stop Double
step Text
outName =
let vals :: [Pair]
vals = [ Key
"sequence" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object [Pair]
svals ]
svals :: [Pair]
svals = [ Key
"start" Key -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
start
, Key
"stop" Key -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
stop
, Key
"step" Key -> Double -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
step
, Key
"as" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
outName
]
in (VLProperty
VLData, [Pair] -> Value
object [Pair]
vals)