echarts interpreters

gistfile1.purs

module Test.Main where

import Prelude
import Data.Maybe
import Data.Either (either)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Console (log)
import Control.Monad.Writer
import Control.Monad.Writer.Trans
import Control.Monad.Writer.Class
import Data.List
import Data.Foreign
import Data.Int
import Data.Foldable
import Data.Identity
import Data.Foreign.Class
import qualified Data.StrMap as SM

foreign import spy :: forall a. a -> a
foreign import null_ :: Foreign

uprint :: forall a e. a -> Eff e Unit
uprint a = let o = spy a in pure unit 

newtype JSOption = JSOption Foreign

runJSOption :: JSOption -> Foreign
runJSOption (JSOption f) = f

newtype JSSeries = JSSeries Foreign

runJSSeries :: JSSeries -> Foreign
runJSSeries (JSSeries f) = f

newtype JSLegend = JSLegend Foreign

runJSLegend :: JSLegend -> Foreign
runJSLegend (JSLegend f) = f 

newtype JSTooltip = JSTooltip Foreign

runJSTooltip :: JSTooltip -> Foreign
runJSTooltip (JSTooltip f) = f

newtype JSData = JSData Foreign

runJSData :: JSData -> Foreign
runJSData (JSData a) = a

newtype Legend a = Legend (Writer (List LegendCommand) a)
runLegend :: forall a. Legend a -> Writer (List LegendCommand) a
runLegend (Legend a) = a

newtype Option a = Option (Writer (List OptionCommand) a)
runOption :: forall a. Option a -> Writer (List OptionCommand) a
runOption (Option a) = a

newtype Tooltip a = Tooltip (Writer (List TooltipCommand) a)
runTooltip :: forall a. Tooltip a -> Writer (List TooltipCommand) a
runTooltip (Tooltip a) = a

newtype Series a = Series (Writer (List SeriesCommand) a)
runSeries :: forall a. Series a -> Writer (List SeriesCommand) a
runSeries (Series a) = a

instance functorLegend :: Functor Legend where
  map f (Legend a) = Legend (f <$> a)

instance applyLegend :: Apply Legend where
  apply (Legend f) (Legend w) = Legend $ f <*> w

instance bindLegend :: Bind Legend where
  bind (Legend w) f = Legend $ w >>= (\(Legend w') -> w') <<< f

instance applicativeLegend :: Applicative Legend where
  pure = Legend <<< pure

instance monadLegend :: Monad Legend

instance monadWriterLegend :: MonadWriter (List LegendCommand) Legend where
  writer = writer >>> Legend
  listen (Legend m) = Legend $ listen m
  pass (Legend m) = Legend $ pass m

instance functorOption :: Functor Option where
  map f (Option a) = Option (f <$> a)

instance applyOption :: Apply Option where
  apply (Option f) (Option w) = Option $ f <*> w

instance bindOption :: Bind Option where
  bind (Option w) f = Option $ w >>= (\(Option w') -> w') <<< f

instance applicativeOption :: Applicative Option where
  pure = Option <<< pure

instance monadOption :: Monad Option

instance monadWriterOption :: MonadWriter (List OptionCommand) Option where
  writer = writer >>> Option
  listen (Option m) = Option $ listen m
  pass (Option m) = Option $ pass m


instance functorTooltip :: Functor Tooltip where
  map f (Tooltip a) = Tooltip (f <$> a)

instance applyTooltip :: Apply Tooltip where
  apply (Tooltip f) (Tooltip w) = Tooltip $ f <*> w

instance bindTooltip :: Bind Tooltip where
  bind (Tooltip w) f = Tooltip $ w >>= (\(Tooltip w') -> w') <<< f

instance applicativeTooltip :: Applicative Tooltip where
  pure = Tooltip <<< pure

instance monadTooltip :: Monad Tooltip

instance monadWriterTooltip :: MonadWriter (List TooltipCommand) Tooltip where
  writer = writer >>> Tooltip
  listen (Tooltip m) = Tooltip $ listen m
  pass (Tooltip m) = Tooltip $ pass m


instance seriesFunctor :: Functor Series where
  map f (Series a) = Series (f <$> a)

instance seriesApply :: Apply Series where
  apply (Series f) (Series w) = Series $ f <*> w

instance seriesBind :: Bind Series where
  bind (Series w) f = Series $ w >>= (\(Series w') -> w') <<< f

instance applicativeSeries :: Applicative Series where
  pure = Series <<< pure

instance monadSeries :: Monad Series

instance monadWriterSeries :: MonadWriter (List SeriesCommand) Series where
  writer = writer >>> Series
  listen (Series m) = Series $ listen m
  pass (Series m) = Series $ pass m
  

data OptionCommand
  = SeriesC JSSeries
  | TooltipC JSTooltip
  | LegendC JSLegend

data LegendCommand
  = Vertical
  | Horizontal
  | Left
  | Right
  | Item JSData
                 
data SeriesCommand
  = Pie
  | ItemSeries JSData
  | ItemStyle String

data TooltipCommand
  = TriggerItem
  | TriggerAxis

data CanonicalValue
  = None
  | Value Number
  | Pair Number Number
  | Many (List Number)

data CanonicalData
  = Simple CanonicalValue
  | Full {value :: CanonicalValue, tooltip :: String, style :: String }
  | Label String

canonicalToJSData :: CanonicalData -> JSData
canonicalToJSData (Simple v) = JSData $ toForeign (val2f v)
canonicalToJSData (Label s) = JSData $ toForeign {label: s}
canonicalToJSData (Full {value: v, tooltip: t, style: s}) =
  JSData $ toForeign {value: val2f, tooltip: t, style: s}


val2f :: CanonicalValue -> Foreign
val2f None = null_
val2f (Value n) = toForeign n
val2f (Pair a b) = toForeign [a, b]
val2f (Many lst) =
  let arr :: Array Number
      arr = fromList lst 
  in toForeign arr

class DataLike a where
  toCanonical :: a -> CanonicalData

class Collection a where
  itemCommand :: JSData -> a Unit

instance collectionLegend :: Collection Legend where
  itemCommand = tell <<< singleton <<< Item

instance collectionSeries :: Collection Series where
  itemCommand = tell <<< singleton <<< ItemSeries

instance canonicalDataLike :: DataLike CanonicalData where
  toCanonical = id

instance numberDataLike :: DataLike Number where
  toCanonical = Simple <<< Value

instance intDataLike :: DataLike Int where
  toCanonical = toCanonical <<< toNumber

interpretLegend :: Legend Unit -> JSLegend
interpretLegend (Legend commands) =
  JSLegend $ toForeign $ foldl foldFn initial $ execWriter commands
  where
  initial = SM.empty

  foldFn :: SM.StrMap Foreign -> LegendCommand -> SM.StrMap Foreign
  foldFn m (Vertical) = SM.insert "orient" (toForeign "vertical") m
  foldFn m (Horizontal) = SM.insert "orient" (toForeign "horizontal") m
  foldFn m (Left) = SM.insert "position" (toForeign "left") m
  foldFn m (Right) = SM.insert "position" (toForeign "right") m
  foldFn m (Item (JSData j)) = SM.alter (insertFn j) "data" m

  insertFn j Nothing = Just $ toForeign [j]
  insertFn j (Just arr) =
    either (const $ insertFn j Nothing) (pure <<< toForeign <<< (<> [j])) $ read arr

toData :: forall d. (DataLike d) => d -> JSData
toData = canonicalToJSData <<< toCanonical 

legend :: Legend Unit -> Option Unit
legend coms = tell $ singleton $ LegendC (interpretLegend coms)

vertical :: Legend Unit
vertical = tell $ singleton Vertical

horizontal :: Legend Unit
horizontal = tell $ singleton Horizontal

left :: Legend Unit
left = tell $ singleton Left

right :: Legend Unit
right = tell $ singleton Right

items :: forall f d q. (Foldable f, Functor f, DataLike d, Collection q, Applicative q) =>
         f d -> q Unit 
items coll = for_ coll (toData >>> itemCommand)

addItem :: forall d q. (DataLike d, Collection q) =>
           d -> q Unit
addItem = toData >>> itemCommand

pie :: Series Unit
pie = tell $ singleton Pie


tooltip :: Tooltip Unit -> Option Unit
tooltip commands = tell $ singleton $ TooltipC $ interpretTooltip commands

interpretTooltip :: Tooltip Unit -> JSTooltip
interpretTooltip (Tooltip commands) =
  JSTooltip $ toForeign $ foldl foldFn initial $ execWriter commands
  where
  initial = SM.empty
  foldFn :: SM.StrMap Foreign -> TooltipCommand -> SM.StrMap Foreign
  foldFn m TriggerAxis = SM.insert "trigger" (toForeign "axis") m
  foldFn m TriggerItem = SM.insert "trigger" (toForeign "item") m

triggerItem :: Tooltip Unit
triggerItem = tell $ singleton $ TriggerItem

triggerAxis :: Tooltip Unit
triggerAxis = tell $ singleton $ TriggerAxis

addSeries :: Series Unit -> Option Unit
addSeries commands = tell $ singleton $ SeriesC $ interpretSeries commands

interpretSeries :: Series Unit -> JSSeries
interpretSeries (Series commands) =
  JSSeries $ toForeign $ foldl foldFn initial $ execWriter commands
  where
  initial = SM.empty

  foldFn :: SM.StrMap Foreign -> SeriesCommand -> SM.StrMap Foreign
  foldFn m (ItemSeries (JSData j)) = SM.alter (insertFn j) "data" m
  foldFn m (ItemStyle str) = SM.insert "style" (toForeign str) m
  foldFn m Pie = SM.insert "type" (toForeign "pie") m

  insertFn j Nothing = Just $ toForeign [j]
  insertFn j (Just arr) =
    either (const $ insertFn j Nothing) (pure <<< toForeign <<< (<> [j])) $ read arr


interpretOption :: Option Unit -> JSOption
interpretOption (Option commands) =
  JSOption $ toForeign (foldl foldFn initial $ execWriter commands)
  where
  initial = SM.empty

  foldFn :: SM.StrMap Foreign -> OptionCommand -> SM.StrMap Foreign
  foldFn m (SeriesC j) = SM.insert "series" (runJSSeries j) m
  foldFn m (TooltipC j) = SM.insert "tooltip" (runJSTooltip j) m
  foldFn m (LegendC j) = SM.insert "legend" (runJSLegend j) m
  

option :: Option Unit 
option = do
  legend do
    vertical
    left 
    items [1, 2, 3]
  tooltip triggerItem
  addSeries do
    pie 
    addItem 1
    addItem 2.0
    addItem $ Simple $ None


main :: Eff _ Unit
main = do
  uprint $ interpretOption option
  log "TROLOLO"