default aggregation in codecs

default aggregation in codecs

module Model.Notebook.Cell.Viz where

import Data.Maybe (Maybe(..), maybe, fromMaybe)
import ECharts.Chart
import ECharts.Options

import Data.Argonaut.JCursor (JCursor())
import Data.Map (Map(), empty, keys)
import Model.Notebook.ECharts (Semanthic(..), Axis(..), dependsOn)
import Data.Argonaut.JCursor (JCursor())
import Optic.Core (Lens(), lens, LensP(), (^.), (%~))
import qualified Data.Set as S
import Data.Argonaut.Core (JArray())
import Data.Array (findIndex, filter, head, sort, reverse, length)
import Data.Foldable (foldl)
import Data.Argonaut.Decode (DecodeJson, decodeJson)
import Data.Argonaut.Encode (EncodeJson)
import Data.Argonaut.Combinators ((~>), (:=), (.?))
import Data.Argonaut.Core (fromString, Json(), JArray(), jsonEmptyObject, toString)
import Data.Either
import Control.Alt ((<|>))

data ChartType
  = Pie
  | Line
  | Bar

chartType2str :: ChartType -> String
chartType2str Pie = "Pie"
chartType2str Line = "Line"
chartType2str Bar = "Bar"

instance chartTypeEq :: Eq ChartType where
  (==) Pie Pie = true
  (==) Line Line = true
  (==) Bar Bar = true
  (==) _ _ = false
  (/=) a b = not $ a == b

instance chartTypeOrd :: Ord ChartType where
  compare Pie Pie = EQ
  compare Line Line = EQ
  compare Bar Bar = EQ
  compare Pie _ = LT
  compare _ Pie = GT
  compare Line _ = LT
  compare _ Line = GT

instance encodeJsonChartType :: EncodeJson ChartType where
  encodeJson Pie = fromString "pie"
  encodeJson Line = fromString "line"
  encodeJson Bar = fromString "bar"

instance decodeJson :: DecodeJson ChartType where
  decodeJson json = maybe (Left "incorrect chart type string") Right do
    str <- toString json
    str2chartType str

str2chartType :: String -> Maybe ChartType
str2chartType str = case str of
  "pie" -> pure Pie
  "line" -> pure Line
  "bar" -> pure Bar
  _ -> Nothing

type SelectionR a =
  { variants :: [a]
  , selection :: Maybe a
  }
newtype Selection a = Selection (SelectionR a)

_Selection :: forall a. LensP (Selection a) (SelectionR a)
_Selection = lens (\(Selection obj) -> obj) (const Selection)

_variants :: forall a. LensP (Selection a) [a]
_variants = _Selection <<< lens _.variants _{variants = _}

_selR :: forall a. LensP (SelectionR a) (Maybe a)
_selR = lens _.selection _{selection = _}

_selection :: forall a. LensP (Selection a) (Maybe a)
_selection = _Selection <<< _selR

initialSelection :: forall a. Selection a
initialSelection = Selection {variants: [], selection: Nothing}

newSelection :: forall a. [a] -> Selection a
newSelection as = Selection {variants: as, selection: Nothing}

except :: forall a. (Eq a) => Selection a -> Selection a -> Selection a
except sel sel' = sel # (_variants %~ (flip except' sel'))

except' :: forall a. (Eq a) => [a] -> Selection a -> [a]
except' lst sel = filter (\x -> Just x /= (sel ^._selection)) lst

instance encodeJsonSelection :: (EncodeJson a) => EncodeJson (Selection a) where
  encodeJson (Selection r) = "variants" := r.variants
                             ~> "selection" := r.selection
                             ~> jsonEmptyObject

instance decodeJsonSelection :: (DecodeJson a) => DecodeJson (Selection a) where
  decodeJson json = do
    obj <- decodeJson json
    r <- { variants: _
         , selection: _
         } <$>
         (obj .? "variants") <*>
         (obj .? "selection")
    pure $ Selection r

type JSelection = Selection JCursor

depends :: JSelection -> [JCursor] -> [JCursor]
depends sel lst = maybe lst go (sel ^._selection)
  where
  go y = filter (dependsOn y) lst

data Aggregation
  = Maximum
  | Minimum
  | Average
  | Sum
  | Product

instance eqAggregation :: Eq Aggregation where
  (==) Maximum Maximum = true
  (==) Minimum Minimum = true
  (==) Average Average = true
  (==) Sum Sum = true
  (==) Product Product = true
  (==) _ _ = false
  (/=) a b = not $ a == b

allAggregation :: [Aggregation]
allAggregation = [ Maximum
                 , Minimum
                 , Average
                 , Sum
                 , Product
                 ]

aggregation2str :: Aggregation -> String
aggregation2str Maximum = "⋀"
aggregation2str Minimum = "⋁"
aggregation2str Average = "μ"
aggregation2str Sum = "Σ"
aggregation2str Product = "Π"

str2aggregation :: String -> Maybe Aggregation
str2aggregation "⋀" = pure Maximum
str2aggregation "⋁" = pure Minimum
str2aggregation "μ" = pure Average
str2aggregation "Σ" = pure Sum
str2aggregation "Π" = pure Product
str2aggregation _ = Nothing

allAggregations :: [Aggregation]
allAggregations = [Maximum, Minimum, Average, Sum, Product]

aggregationDefault :: Aggregation
aggregationDefault = Sum

runAggregation :: Aggregation -> [Number] -> Number
runAggregation Maximum nums = fromMaybe 0 $ head $ reverse (sort nums)
runAggregation Minimum nums = fromMaybe 0 $ head (sort nums)
runAggregation Average nums = (foldl (+) 0 nums) / (length nums)
runAggregation Sum nums = foldl (+) 0 nums
runAggregation Product nums = foldl (*) 1 nums

instance encodeJsonAggregateion :: EncodeJson Aggregation where
  encodeJson = fromString <<< aggregation2str

instance decodeJsonAggregation :: DecodeJson Aggregation where
  decodeJson json = maybe (Left "incorrect aggregation string") Right do
    str <- toString json
    case str of
      "⋀" -> pure Maximum
      "⋁" -> pure Minimum
      "μ" -> pure Average
      "Σ" -> pure Sum
      "Π" -> pure Product
      _ -> Nothing

newtype PieConfiguration = PieConfiguration
  { cats :: JSelection
  , firstMeasures :: JSelection
  , firstSeries :: JSelection
  , secondSeries :: JSelection
  , firstAggregation :: Aggregation
  }

initialPieConfiguration :: PieConfiguration
initialPieConfiguration = PieConfiguration
  { cats: initialSelection
  , firstMeasures: initialSelection
  , firstSeries: initialSelection
  , secondSeries: initialSelection
  , firstAggregation: aggregationDefault
  }

instance encodeJsonPieConfiguration :: EncodeJson PieConfiguration where
  encodeJson (PieConfiguration p) = "cats" := p.cats
                                    ~> "firstMeasures" := p.firstMeasures
                                    ~> "firstSeries" := p.firstSeries
                                    ~> "secondSeries" := p.secondSeries
                                    ~> "firstAggregation" := p.firstAggregation
                                    ~> jsonEmptyObject

instance decodeJsonPieConfiguration :: DecodeJson PieConfiguration where
  decodeJson json = do
    obj <- decodeJson json
    r <- { cats: _
         , firstMeasures: _
         , firstSeries: _
         , secondSeries: _
         , firstAggregation: _} <$>
         (obj .? "cats") <*>
         (obj .? "firstMeasures") <*>
         (obj .? "firstSeries") <*>
         (obj .? "secondSeries") <*>
         ((obj .? "firstAggregation") <|> pure Sum)
    pure $ PieConfiguration r

newtype LineConfiguration = LineConfiguration
  { dims :: JSelection
  , firstMeasures :: JSelection
  , secondMeasures :: JSelection
  , firstSeries :: JSelection
  , secondSeries :: JSelection
  , firstAggregation :: Aggregation
  , secondAggregation :: Aggregation
  }

initialLineConfiguration :: LineConfiguration
initialLineConfiguration = LineConfiguration
  { dims: initialSelection
  , firstMeasures: initialSelection
  , secondMeasures: initialSelection
  , firstSeries: initialSelection
  , secondSeries: initialSelection
  , firstAggregation: aggregationDefault
  , secondAggregation: aggregationDefault
  }

instance encodeJsonLineConfiguration :: EncodeJson LineConfiguration where
  encodeJson (LineConfiguration p) = "dims" := p.dims
                                     ~> "firstMeasures" := p.firstMeasures
                                     ~> "secondMeasures" := p.secondMeasures
                                     ~> "firstSeries" := p.firstSeries
                                     ~> "secondSeries" := p.secondSeries
                                     ~> "firstAggregation" := p.firstAggregation
                                     ~> "secondAggregation" := p.secondAggregation
                                     ~> jsonEmptyObject

instance decodeJsonLineConfiguration :: DecodeJson LineConfiguration where
  decodeJson json = do
    obj <- decodeJson json
    r <- { dims: _
         , firstMeasures: _
         , secondMeasures: _
         , firstSeries: _
         , secondSeries: _
         , firstAggregation: _
         , secondAggregation: _} <$>
         (obj .? "dims") <*>
         (obj .? "firstMeasures") <*>
         (obj .? "secondMeasures") <*>
         (obj .? "firstSeries") <*>
         (obj .? "secondSeries") <*>
         ((obj .? "firstAggregation") <|> pure Sum) <*>
         ((obj .? "secondAggregation") <|> pure Sum)
    pure $ LineConfiguration r

newtype BarConfiguration = BarConfiguration
  { cats :: JSelection
  , firstMeasures :: JSelection
  , firstSeries :: JSelection
  , secondSeries :: JSelection
  , firstAggregation :: Aggregation
  }

initialBarConfiguration :: BarConfiguration
initialBarConfiguration = BarConfiguration
  { cats: initialSelection
  , firstMeasures: initialSelection
  , firstSeries: initialSelection
  , secondSeries: initialSelection
  , firstAggregation: aggregationDefault
  }

instance encodeBarConfiguration :: EncodeJson BarConfiguration where
  encodeJson (BarConfiguration p) = "cats" := p.cats
                                   ~> "firstMeasures" := p.firstMeasures
                                   ~> "firstSeries" := p.firstSeries
                                   ~> "secondSeries" := p.secondSeries
                                   ~> "firstAggregation" := p.firstAggregation
                                   ~> jsonEmptyObject

instance decodeJsonBarConfiguration :: DecodeJson BarConfiguration where
  decodeJson json = do
    obj <- decodeJson json
    r <- { cats: _
         , firstMeasures: _
         , firstSeries: _
         , secondSeries: _
         , firstAggregation: _} <$>
         (obj .? "cats") <*>
         (obj .? "firstMeasures") <*>
         (obj .? "firstSeries") <*>
         (obj .? "secondSeries") <*>
         ((obj .? "firstAggregation") <|> pure Sum)
    pure $ BarConfiguration r

_BarConfiguration :: LensP BarConfiguration _
_BarConfiguration = lens (\(BarConfiguration obj) -> obj) (const BarConfiguration)

_LineConfiguraion :: LensP LineConfiguration _
_LineConfiguraion = lens (\(LineConfiguration obj) -> obj) (const LineConfiguration)

_PieConfiguration :: LensP PieConfiguration _
_PieConfiguration = lens (\(PieConfiguration obj) -> obj) (const PieConfiguration)

_cats :: forall a b r. Lens {cats::a|r} {cats::b|r} a b
_cats = lens _.cats _{cats = _}

_dims :: forall a b r. Lens {dims::a|r} {dims::b|r} a b
_dims = lens _.dims _{dims = _}

_firstMeasures :: forall a b r. Lens {firstMeasures :: a |r} {firstMeasures :: b |r} a b
_firstMeasures = lens _.firstMeasures _{firstMeasures = _}

_secondMeasures :: forall a b r. Lens {secondMeasures :: a |r} {secondMeasures :: b |r} a b
_secondMeasures = lens _.secondMeasures _{secondMeasures = _}

_firstSeries :: forall a b r. Lens {firstSeries :: a |r} {firstSeries :: b |r} a b
_firstSeries = lens _.firstSeries _{firstSeries = _}

_secondSeries :: forall a b r. Lens {secondSeries :: a|r} {secondSeries :: b|r} a b
_secondSeries = lens _.secondSeries _{secondSeries = _}

--_firstAggregation :: forall a b r. Lens {firstAggregation :: a |r} {firstAggregation :: b | r} a b
_firstAggregation = lens _.firstAggregation _{firstAggregation = _}

--_secondAggregation :: forall a b r. Lens {secondAggregation :: a } {secondAggregation :: b | r} a b
_secondAggregation = lens _.secondAggregation _{secondAggregation = _}

newtype VizRec = VizRec
  { output :: Option
  , all :: Map JCursor Axis
  , sample :: Map JCursor Axis
  , error :: String
  , availableChartTypes :: S.Set ChartType
  , chartType :: ChartType
    -- product because we don't need to drop selection when user choice
    -- another type of chart
  , pieConfiguration :: PieConfiguration
  , lineConfiguration :: LineConfiguration
  , barConfiguration :: BarConfiguration
  , chartHeight :: Number
  , chartWidth :: Number
  }

initialVizRec :: VizRec
initialVizRec = VizRec
  { output: Option optionDefault
  , all: empty
  , sample: empty
  , error: ""
  , availableChartTypes: S.empty
  , chartType: Pie
  , pieConfiguration: initialPieConfiguration
  , lineConfiguration: initialLineConfiguration
  , barConfiguration: initialBarConfiguration
  , chartHeight: 400
  , chartWidth: 600
  }

instance encodeJsonVizRec :: EncodeJson VizRec where
  encodeJson (VizRec r) = "sample" := r.sample
                          ~> "error" := r.error
                          ~> "availableChartTypes" := (S.toList r.availableChartTypes)
                          ~> "chartType" := r.chartType
                          ~> "pie" := r.pieConfiguration
                          ~> "line" := r.lineConfiguration
                          ~> "bar" := r.barConfiguration
                          ~> "height" := r.chartHeight
                          ~> "width" := r.chartWidth
                          ~> jsonEmptyObject

instance decodeJsonVizRec :: DecodeJson VizRec where
  decodeJson json = do
    obj <- decodeJson json
    av <- obj .? "availableChartTypes"
    r <- { output: Option optionDefault
        , all: empty
        , sample: _
        , error: _
        , availableChartTypes: S.fromList av
        , chartType: _
        , pieConfiguration: _
        , lineConfiguration: _
        , barConfiguration: _
        , chartHeight: _
        , chartWidth: _} <$>
        (obj .? "sample") <*>
        (obj .? "error") <*>
        (obj .? "chartType") <*>
        (obj .? "pie") <*>
        (obj .? "line") <*>
        (obj .? "bar") <*>
        ((obj .? "height") <|> pure 400) <*>
        ((obj .? "width") <|> pure 600)
    pure $ VizRec r

_VizRec :: LensP VizRec _
_VizRec = lens (\(VizRec o) -> o) (const VizRec)

_output :: LensP VizRec Option
_output = _VizRec <<< lens _.output _{output = _}

_error :: LensP VizRec String
_error = _VizRec <<< lens _.error _{error = _}

_sample :: LensP VizRec (Map JCursor Axis)
_sample = _VizRec <<< lens _.sample _{sample = _}

_all :: LensP VizRec (Map JCursor Axis)
_all = _VizRec <<< lens _.all _{all = _}

_chartType :: LensP VizRec ChartType
_chartType = _VizRec <<< lens _.chartType _{chartType = _}

_chartHeight :: LensP VizRec Number
_chartHeight = _VizRec <<< lens _.chartHeight _{chartHeight = _}

_chartWidth :: LensP VizRec Number
_chartWidth = _VizRec <<< lens _.chartWidth _{chartWidth = _}

_availableChartTypes :: LensP VizRec (S.Set ChartType)
_availableChartTypes = _VizRec <<< lens _.availableChartTypes _{availableChartTypes = _}

_pieConfiguration :: LensP VizRec _
_pieConfiguration = _VizRec <<<
                    (lens _.pieConfiguration _{pieConfiguration = _} ) <<<
                    _PieConfiguration

_lineConfiguration :: LensP VizRec _
_lineConfiguration = _VizRec <<<
                     (lens _.lineConfiguration _{lineConfiguration = _} ) <<<
                     _LineConfiguraion

_barConfiguration :: LensP VizRec _
_barConfiguration = _VizRec <<<
                    (lens _.barConfiguration _{barConfiguration = _}) <<<
                    _BarConfiguration

module Model.Notebook.Cell.Viz where

import Data.Maybe (Maybe(..), maybe, fromMaybe)
import ECharts.Chart
import ECharts.Options

import Data.Argonaut.JCursor (JCursor())
import Data.Map (Map(), empty, keys)
import Model.Notebook.ECharts (Semanthic(..), Axis(..), dependsOn)
import Data.Argonaut.JCursor (JCursor())
import Optic.Core (Lens(), lens, LensP(), (^.), (%~))
import qualified Data.Set as S
import Data.Argonaut.Core (JArray())
import Data.Array (findIndex, filter, head, sort, reverse, length)
import Data.Foldable (foldl)
import Data.Argonaut.Decode (DecodeJson, decodeJson)
import Data.Argonaut.Encode (EncodeJson)
import Data.Argonaut.Combinators ((~>), (:=), (.?))
import Data.Argonaut.Core (fromString, Json(), JArray(), jsonEmptyObject, toString)
import Data.Either
import Control.Alt ((<|>))

data ChartType
  = Pie
  | Line
  | Bar

chartType2str :: ChartType -> String
chartType2str Pie = "Pie"
chartType2str Line = "Line"
chartType2str Bar = "Bar"

instance chartTypeEq :: Eq ChartType where
  (==) Pie Pie = true
  (==) Line Line = true
  (==) Bar Bar = true
  (==) _ _ = false
  (/=) a b = not $ a == b

instance chartTypeOrd :: Ord ChartType where
  compare Pie Pie = EQ
  compare Line Line = EQ
  compare Bar Bar = EQ
  compare Pie _ = LT
  compare _ Pie = GT
  compare Line _ = LT
  compare _ Line = GT

instance encodeJsonChartType :: EncodeJson ChartType where
  encodeJson Pie = fromString "pie"
  encodeJson Line = fromString "line"
  encodeJson Bar = fromString "bar"

instance decodeJson :: DecodeJson ChartType where
  decodeJson json = maybe (Left "incorrect chart type string") Right do
    str <- toString json
    str2chartType str

str2chartType :: String -> Maybe ChartType
str2chartType str = case str of
  "pie" -> pure Pie
  "line" -> pure Line
  "bar" -> pure Bar
  _ -> Nothing

type SelectionR a =
  { variants :: [a]
  , selection :: Maybe a
  }
newtype Selection a = Selection (SelectionR a)

_Selection :: forall a. LensP (Selection a) (SelectionR a)
_Selection = lens (\(Selection obj) -> obj) (const Selection)

_variants :: forall a. LensP (Selection a) [a]
_variants = _Selection <<< lens _.variants _{variants = _}

_selR :: forall a. LensP (SelectionR a) (Maybe a)
_selR = lens _.selection _{selection = _}

_selection :: forall a. LensP (Selection a) (Maybe a)
_selection = _Selection <<< _selR

initialSelection :: forall a. Selection a
initialSelection = Selection {variants: [], selection: Nothing}

newSelection :: forall a. [a] -> Selection a
newSelection as = Selection {variants: as, selection: Nothing}

except :: forall a. (Eq a) => Selection a -> Selection a -> Selection a
except sel sel' = sel # (_variants %~ (flip except' sel'))

except' :: forall a. (Eq a) => [a] -> Selection a -> [a]
except' lst sel = filter (\x -> Just x /= (sel ^._selection)) lst

instance encodeJsonSelection :: (EncodeJson a) => EncodeJson (Selection a) where
  encodeJson (Selection r) = "variants" := r.variants
                             ~> "selection" := r.selection
                             ~> jsonEmptyObject

instance decodeJsonSelection :: (DecodeJson a) => DecodeJson (Selection a) where
  decodeJson json = do
    obj <- decodeJson json
    r <- { variants: _
         , selection: _
         } <$>
         (obj .? "variants") <*>
         (obj .? "selection")
    pure $ Selection r

type JSelection = Selection JCursor

depends :: JSelection -> [JCursor] -> [JCursor]
depends sel lst = maybe lst go (sel ^._selection)
  where
  go y = filter (dependsOn y) lst

data Aggregation
  = Maximum
  | Minimum
  | Average
  | Sum
  | Product

instance eqAggregation :: Eq Aggregation where
  (==) Maximum Maximum = true
  (==) Minimum Minimum = true
  (==) Average Average = true
  (==) Sum Sum = true
  (==) Product Product = true
  (==) _ _ = false
  (/=) a b = not $ a == b

allAggregation :: [Aggregation]
allAggregation = [ Maximum
                 , Minimum
                 , Average
                 , Sum
                 , Product
                 ]

aggregation2str :: Aggregation -> String
aggregation2str Maximum = "⋀"
aggregation2str Minimum = "⋁"
aggregation2str Average = "μ"
aggregation2str Sum = "Σ"
aggregation2str Product = "Π"

str2aggregation :: String -> Maybe Aggregation
str2aggregation "⋀" = pure Maximum
str2aggregation "⋁" = pure Minimum
str2aggregation "μ" = pure Average
str2aggregation "Σ" = pure Sum
str2aggregation "Π" = pure Product
str2aggregation _ = Nothing

allAggregations :: [Aggregation]
allAggregations = [Maximum, Minimum, Average, Sum, Product]

aggregationDefault :: Aggregation
aggregationDefault = Sum

runAggregation :: Aggregation -> [Number] -> Number
runAggregation Maximum nums = fromMaybe 0 $ head $ reverse (sort nums)
runAggregation Minimum nums = fromMaybe 0 $ head (sort nums)
runAggregation Average nums = (foldl (+) 0 nums) / (length nums)
runAggregation Sum nums = foldl (+) 0 nums
runAggregation Product nums = foldl (*) 1 nums

instance encodeJsonAggregateion :: EncodeJson Aggregation where
  encodeJson = fromString <<< aggregation2str

instance decodeJsonAggregation :: DecodeJson Aggregation where
  decodeJson json = maybe (Left "incorrect aggregation string") Right do
    str <- toString json
    case str of
      "⋀" -> pure Maximum
      "⋁" -> pure Minimum
      "μ" -> pure Average
      "Σ" -> pure Sum
      "Π" -> pure Product
      _ -> Nothing

newtype PieConfiguration = PieConfiguration
  { cats :: JSelection
  , firstMeasures :: JSelection
  , firstSeries :: JSelection
  , secondSeries :: JSelection
  , firstAggregation :: Aggregation
  }

initialPieConfiguration :: PieConfiguration
initialPieConfiguration = PieConfiguration
  { cats: initialSelection
  , firstMeasures: initialSelection
  , firstSeries: initialSelection
  , secondSeries: initialSelection
  , firstAggregation: aggregationDefault
  }

instance encodeJsonPieConfiguration :: EncodeJson PieConfiguration where
  encodeJson (PieConfiguration p) = "cats" := p.cats
                                    ~> "firstMeasures" := p.firstMeasures
                                    ~> "firstSeries" := p.firstSeries
                                    ~> "secondSeries" := p.secondSeries
                                    ~> "firstAggregation" := p.firstAggregation
                                    ~> jsonEmptyObject

instance decodeJsonPieConfiguration :: DecodeJson PieConfiguration where
  decodeJson json = do
    obj <- decodeJson json
    r <- { cats: _
         , firstMeasures: _
         , firstSeries: _
         , secondSeries: _
         , firstAggregation: _} <$>
         (obj .? "cats") <*>
         (obj .? "firstMeasures") <*>
         (obj .? "firstSeries") <*>
         (obj .? "secondSeries") <*>
         (obj .? "firstAggregation")
    pure $ PieConfiguration r

newtype LineConfiguration = LineConfiguration
  { dims :: JSelection
  , firstMeasures :: JSelection
  , secondMeasures :: JSelection
  , firstSeries :: JSelection
  , secondSeries :: JSelection
  , firstAggregation :: Aggregation
  , secondAggregation :: Aggregation
  }

initialLineConfiguration :: LineConfiguration
initialLineConfiguration = LineConfiguration
  { dims: initialSelection
  , firstMeasures: initialSelection
  , secondMeasures: initialSelection
  , firstSeries: initialSelection
  , secondSeries: initialSelection
  , firstAggregation: aggregationDefault
  , secondAggregation: aggregationDefault
  }

instance encodeJsonLineConfiguration :: EncodeJson LineConfiguration where
  encodeJson (LineConfiguration p) = "dims" := p.dims
                                     ~> "firstMeasures" := p.firstMeasures
                                     ~> "secondMeasures" := p.secondMeasures
                                     ~> "firstSeries" := p.firstSeries
                                     ~> "secondSeries" := p.secondSeries
                                     ~> "firstAggregation" := p.firstAggregation
                                     ~> "secondAggregation" := p.secondAggregation
                                     ~> jsonEmptyObject

instance decodeJsonLineConfiguration :: DecodeJson LineConfiguration where
  decodeJson json = do
    obj <- decodeJson json
    r <- { dims: _
         , firstMeasures: _
         , secondMeasures: _
         , firstSeries: _
         , secondSeries: _
         , firstAggregation: _
         , secondAggregation: _} <$>
         (obj .? "dims") <*>
         (obj .? "firstMeasures") <*>
         (obj .? "secondMeasures") <*>
         (obj .? "firstSeries") <*>
         (obj .? "secondSeries") <*>
         (obj .? "firstAggregation") <*>
         (obj .? "secondAggregation")
    pure $ LineConfiguration r

newtype BarConfiguration = BarConfiguration
  { cats :: JSelection
  , firstMeasures :: JSelection
  , firstSeries :: JSelection
  , secondSeries :: JSelection
  , firstAggregation :: Aggregation
  }

initialBarConfiguration :: BarConfiguration
initialBarConfiguration = BarConfiguration
  { cats: initialSelection
  , firstMeasures: initialSelection
  , firstSeries: initialSelection
  , secondSeries: initialSelection
  , firstAggregation: aggregationDefault
  }

instance encodeBarConfiguration :: EncodeJson BarConfiguration where
  encodeJson (BarConfiguration p) = "cats" := p.cats
                                   ~> "firstMeasures" := p.firstMeasures
                                   ~> "firstSeries" := p.firstSeries
                                   ~> "secondSeries" := p.secondSeries
                                   ~> "firstAggregation" := p.firstAggregation
                                   ~> jsonEmptyObject

instance decodeJsonBarConfiguration :: DecodeJson BarConfiguration where
  decodeJson json = do
    obj <- decodeJson json
    r <- { cats: _
         , firstMeasures: _
         , firstSeries: _
         , secondSeries: _
         , firstAggregation: _} <$>
         (obj .? "cats") <*>
         (obj .? "firstMeasures") <*>
         (obj .? "firstSeries") <*>
         (obj .? "secondSeries") <*>
         (obj .? "firstAggregation")
    pure $ BarConfiguration r

_BarConfiguration :: LensP BarConfiguration _
_BarConfiguration = lens (\(BarConfiguration obj) -> obj) (const BarConfiguration)

_LineConfiguraion :: LensP LineConfiguration _
_LineConfiguraion = lens (\(LineConfiguration obj) -> obj) (const LineConfiguration)

_PieConfiguration :: LensP PieConfiguration _
_PieConfiguration = lens (\(PieConfiguration obj) -> obj) (const PieConfiguration)

_cats :: forall a b r. Lens {cats::a|r} {cats::b|r} a b
_cats = lens _.cats _{cats = _}

_dims :: forall a b r. Lens {dims::a|r} {dims::b|r} a b
_dims = lens _.dims _{dims = _}

_firstMeasures :: forall a b r. Lens {firstMeasures :: a |r} {firstMeasures :: b |r} a b
_firstMeasures = lens _.firstMeasures _{firstMeasures = _}

_secondMeasures :: forall a b r. Lens {secondMeasures :: a |r} {secondMeasures :: b |r} a b
_secondMeasures = lens _.secondMeasures _{secondMeasures = _}

_firstSeries :: forall a b r. Lens {firstSeries :: a |r} {firstSeries :: b |r} a b
_firstSeries = lens _.firstSeries _{firstSeries = _}

_secondSeries :: forall a b r. Lens {secondSeries :: a|r} {secondSeries :: b|r} a b
_secondSeries = lens _.secondSeries _{secondSeries = _}

--_firstAggregation :: forall a b r. Lens {firstAggregation :: a |r} {firstAggregation :: b | r} a b
_firstAggregation = lens _.firstAggregation _{firstAggregation = _}

--_secondAggregation :: forall a b r. Lens {secondAggregation :: a } {secondAggregation :: b | r} a b
_secondAggregation = lens _.secondAggregation _{secondAggregation = _}

newtype VizRec = VizRec
  { output :: Option
  , all :: Map JCursor Axis
  , sample :: Map JCursor Axis
  , error :: String
  , availableChartTypes :: S.Set ChartType
  , chartType :: ChartType
    -- product because we don't need to drop selection when user choice
    -- another type of chart
  , pieConfiguration :: PieConfiguration
  , lineConfiguration :: LineConfiguration
  , barConfiguration :: BarConfiguration
  , chartHeight :: Number
  , chartWidth :: Number
  }

initialVizRec :: VizRec
initialVizRec = VizRec
  { output: Option optionDefault
  , all: empty
  , sample: empty
  , error: ""
  , availableChartTypes: S.empty
  , chartType: Pie
  , pieConfiguration: initialPieConfiguration
  , lineConfiguration: initialLineConfiguration
  , barConfiguration: initialBarConfiguration
  , chartHeight: 400
  , chartWidth: 600
  }

instance encodeJsonVizRec :: EncodeJson VizRec where
  encodeJson (VizRec r) = "sample" := r.sample
                          ~> "error" := r.error
                          ~> "availableChartTypes" := (S.toList r.availableChartTypes)
                          ~> "chartType" := r.chartType
                          ~> "pie" := r.pieConfiguration
                          ~> "line" := r.lineConfiguration
                          ~> "bar" := r.barConfiguration
                          ~> "height" := r.chartHeight
                          ~> "width" := r.chartWidth
                          ~> jsonEmptyObject

instance decodeJsonVizRec :: DecodeJson VizRec where
  decodeJson json = do
    obj <- decodeJson json
    av <- obj .? "availableChartTypes"
    r <- { output: Option optionDefault
        , all: empty
        , sample: _
        , error: _
        , availableChartTypes: S.fromList av
        , chartType: _
        , pieConfiguration: _
        , lineConfiguration: _
        , barConfiguration: _
        , chartHeight: _
        , chartWidth: _} <$>
        (obj .? "sample") <*>
        (obj .? "error") <*>
        (obj .? "chartType") <*>
        (obj .? "pie") <*>
        (obj .? "line") <*>
        (obj .? "bar") <*>
        ((obj .? "height") <|> pure 400) <*>
        ((obj .? "width") <|> pure 600)
    pure $ VizRec r

_VizRec :: LensP VizRec _
_VizRec = lens (\(VizRec o) -> o) (const VizRec)

_output :: LensP VizRec Option
_output = _VizRec <<< lens _.output _{output = _}

_error :: LensP VizRec String
_error = _VizRec <<< lens _.error _{error = _}

_sample :: LensP VizRec (Map JCursor Axis)
_sample = _VizRec <<< lens _.sample _{sample = _}

_all :: LensP VizRec (Map JCursor Axis)
_all = _VizRec <<< lens _.all _{all = _}

_chartType :: LensP VizRec ChartType
_chartType = _VizRec <<< lens _.chartType _{chartType = _}

_chartHeight :: LensP VizRec Number
_chartHeight = _VizRec <<< lens _.chartHeight _{chartHeight = _}

_chartWidth :: LensP VizRec Number
_chartWidth = _VizRec <<< lens _.chartWidth _{chartWidth = _}

_availableChartTypes :: LensP VizRec (S.Set ChartType)
_availableChartTypes = _VizRec <<< lens _.availableChartTypes _{availableChartTypes = _}

_pieConfiguration :: LensP VizRec _
_pieConfiguration = _VizRec <<<
                    (lens _.pieConfiguration _{pieConfiguration = _} ) <<<
                    _PieConfiguration

_lineConfiguration :: LensP VizRec _
_lineConfiguration = _VizRec <<<
                     (lens _.lineConfiguration _{lineConfiguration = _} ) <<<
                     _LineConfiguraion

_barConfiguration :: LensP VizRec _
_barConfiguration = _VizRec <<<
                    (lens _.barConfiguration _{barConfiguration = _}) <<<
                    _BarConfiguration


reference Object.prototype.hasOwnProperty directly

module Data.Foreign.Index
  ( Index

  , prop
  , index

  , (!)
  , hasProperty
  , hasOwnProperty
  , errorAt
  ) where

import Data.Either
import Data.Foreign
import Data.Function

infixl 9 !

class Index i where
  (!) :: Foreign -> i -> F Foreign
  hasProperty :: i -> Foreign -> Boolean
  hasOwnProperty :: i -> Foreign -> Boolean
  errorAt :: i -> ForeignError -> ForeignError

foreign import unsafeReadPropImpl
  """
  function unsafeReadPropImpl(f, s, key, value) {
    if (value && typeof value === 'object') {
      return s(value[key]);
    } else {
      return f;
    }
  }
  """ :: forall r k. Fn4 r (Foreign -> r) k Foreign (F Foreign)

unsafeReadProp :: forall k. k -> Foreign -> F Foreign
unsafeReadProp k value = runFn4 unsafeReadPropImpl (Left (TypeMismatch "object" (typeOf value))) pure k value

prop :: String -> Foreign -> F Foreign
prop = unsafeReadProp

index :: Number -> Foreign -> F Foreign
index = unsafeReadProp

foreign import unsafeHasOwnProperty
  """
  function unsafeHasOwnProperty(prop, value) {
    return Object.prototype.hasOwnProperty.call(value, prop);
  }
  """ :: forall k. Fn2 k Foreign Boolean

hasOwnPropertyImpl :: forall k. k -> Foreign -> Boolean
hasOwnPropertyImpl _    value | isNull value = false
hasOwnPropertyImpl _    value | isUndefined value = false
hasOwnPropertyImpl prop value | typeOf value == "object" || typeOf value == "function" = runFn2 unsafeHasOwnProperty prop value
hasOwnPropertyImpl _    value = false

foreign import unsafeHasProperty
  """
  function unsafeHasProperty(prop, value) {
    return prop in value;
  }
  """ :: forall k. Fn2 k Foreign Boolean

hasPropertyImpl :: forall k. k -> Foreign -> Boolean
hasPropertyImpl _    value | isNull value = false
hasPropertyImpl _    value | isUndefined value = false
hasPropertyImpl prop value | typeOf value == "object" || typeOf value == "function" = runFn2 unsafeHasProperty prop value
hasPropertyImpl _    value = false

instance indexString :: Index String where
  (!) = flip prop
  hasProperty = hasPropertyImpl
  hasOwnProperty = hasOwnPropertyImpl
  errorAt = ErrorAtProperty

instance indexNumber :: Index Number where
  (!) = flip index
  hasProperty = hasPropertyImpl
  hasOwnProperty = hasOwnPropertyImpl
  errorAt = ErrorAtIndex

module Data.Foreign.Index
  ( Index

  , prop
  , index

  , (!)
  , hasProperty
  , hasOwnProperty
  , errorAt
  ) where

import Data.Either
import Data.Foreign
import Data.Function

infixl 9 !

class Index i where
  (!) :: Foreign -> i -> F Foreign
  hasProperty :: i -> Foreign -> Boolean
  hasOwnProperty :: i -> Foreign -> Boolean
  errorAt :: i -> ForeignError -> ForeignError

foreign import unsafeReadPropImpl
  """
  function unsafeReadPropImpl(f, s, key, value) {
    if (value && typeof value === 'object') {
      return s(value[key]);
    } else {
      return f;
    }
  }
  """ :: forall r k. Fn4 r (Foreign -> r) k Foreign (F Foreign)

unsafeReadProp :: forall k. k -> Foreign -> F Foreign
unsafeReadProp k value = runFn4 unsafeReadPropImpl (Left (TypeMismatch "object" (typeOf value))) pure k value

prop :: String -> Foreign -> F Foreign
prop = unsafeReadProp

index :: Number -> Foreign -> F Foreign
index = unsafeReadProp

foreign import unsafeHasOwnProperty
  """
  function unsafeHasOwnProperty(prop, value) {
    return value.hasOwnProperty(prop);
  }
  """ :: forall k. Fn2 k Foreign Boolean

hasOwnPropertyImpl :: forall k. k -> Foreign -> Boolean
hasOwnPropertyImpl _    value | isNull value = false
hasOwnPropertyImpl _    value | isUndefined value = false
hasOwnPropertyImpl prop value | typeOf value == "object" || typeOf value == "function" = runFn2 unsafeHasOwnProperty prop value
hasOwnPropertyImpl _    value = false

foreign import unsafeHasProperty
  """
  function unsafeHasProperty(prop, value) {
    return prop in value;
  }
  """ :: forall k. Fn2 k Foreign Boolean

hasPropertyImpl :: forall k. k -> Foreign -> Boolean
hasPropertyImpl _    value | isNull value = false
hasPropertyImpl _    value | isUndefined value = false
hasPropertyImpl prop value | typeOf value == "object" || typeOf value == "function" = runFn2 unsafeHasProperty prop value
hasPropertyImpl _    value = false

instance indexString :: Index String where
  (!) = flip prop
  hasProperty = hasPropertyImpl
  hasOwnProperty = hasOwnPropertyImpl
  errorAt = ErrorAtProperty

instance indexNumber :: Index Number where
  (!) = flip index
  hasProperty = hasPropertyImpl
  hasOwnProperty = hasOwnPropertyImpl
  errorAt = ErrorAtIndex


Add the qualifier to the import args

Add the qualifier to the import args

module IdePurescript.VSCode.Imports where

import Prelude

import Control.Monad.Except (runExcept)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Nullable (toNullable)
import Data.Traversable (traverse)
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Foreign (readArray, readString, unsafeToForeign)
import IdePurescript.VSCode.Assist (getActivePosInfo)
import IdePurescript.VSCode.Editor (identifierAtCursor)
import IdePurescript.VSCode.Types (launchAffAndRaise)
import LanguageServer.IdePurescript.Commands (addCompletionImport, addModuleImportCmd, cmdName, getAvailableModulesCmd)
import LanguageServer.Types (Command(..), DocumentUri)
import LanguageServer.Uri (filenameToUri)
import VSCode.Input (showQuickPick, defaultInputOptions, getInput)
import VSCode.LanguageClient (LanguageClient, sendCommand)
import VSCode.TextDocument (getPath)
import VSCode.TextEditor (getDocument)
import VSCode.Window (getActiveTextEditor)

addIdentImport :: LanguageClient -> Effect Unit
addIdentImport client = launchAffAndRaise $ void $ do
  liftEffect getActivePosInfo >>= maybe (pure unit) \{ pos, uri, ed } -> do
    atCursor <- liftEffect $ identifierAtCursor ed
    let defaultIdent = maybe "" _.word atCursor
    ident <- getInput (defaultInputOptions { prompt = toNullable $ Just "Identifier", value = toNullable $ Just defaultIdent })
    addIdentImportMod ident uri Nothing
  where
    addIdentImportMod :: String -> DocumentUri -> Maybe String -> Aff Unit
    addIdentImportMod ident uri mod = do
      let Command { command, arguments } = addCompletionImport ident mod Nothing uri
      res <- sendCommand client command arguments
      case runExcept $ readArray res of
        Right forArr
          | Right arr <- runExcept $ traverse readString forArr
          -> showQuickPick arr >>= maybe (pure unit) (addIdentImportMod ident uri <<< Just)
        _ -> pure unit

addModuleImport :: LanguageClient -> Effect Unit
addModuleImport client = launchAffAndRaise $ void $ do
  modulesForeign <- sendCommand client (cmdName getAvailableModulesCmd) (toNullable Nothing)
  ed' <- liftEffect $ getActiveTextEditor
  case runExcept $ readArray modulesForeign, ed' of
    Right arr1, Just ed
      | Right modules <- runExcept $ traverse readString arr1
      -> do
        pick <- showQuickPick modules
        uri <- liftEffect $ filenameToUri =<< (getPath $ getDocument ed)
        atCursor <- liftEffect $ identifierAtCursor ed
        qual <- pure $ toNullable $ _.qualifier =<< atCursor
        case pick of
          Just modName -> void $ sendCommand client (cmdName addModuleImportCmd)
            (toNullable $ Just [ unsafeToForeign modName, unsafeToForeign qual, unsafeToForeign uri ])
          _ -> pure unit
    _, _ -> pure unit

module IdePurescript.VSCode.Imports where

import Prelude

import Control.Monad.Except (runExcept)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Nullable (toNullable)
import Data.Traversable (traverse)
import Effect (Effect)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Foreign (readArray, readString, unsafeToForeign)
import IdePurescript.VSCode.Assist (getActivePosInfo)
import IdePurescript.VSCode.Editor (identifierAtCursor)
import IdePurescript.VSCode.Types (launchAffAndRaise)
import LanguageServer.IdePurescript.Commands (addCompletionImport, addModuleImportCmd, cmdName, getAvailableModulesCmd)
import LanguageServer.Types (Command(..), DocumentUri)
import LanguageServer.Uri (filenameToUri)
import VSCode.Input (showQuickPick, defaultInputOptions, getInput)
import VSCode.LanguageClient (LanguageClient, sendCommand)
import VSCode.TextDocument (getPath)
import VSCode.TextEditor (getDocument)
import VSCode.Window (getActiveTextEditor)

addIdentImport :: LanguageClient -> Effect Unit
addIdentImport client = launchAffAndRaise $ void $ do
  liftEffect getActivePosInfo >>= maybe (pure unit) \{ pos, uri, ed } -> do
    atCursor <- liftEffect $ identifierAtCursor ed
    let defaultIdent = maybe "" _.word atCursor
    ident <- getInput (defaultInputOptions { prompt = toNullable $ Just "Identifier", value = toNullable $ Just defaultIdent })
    addIdentImportMod ident uri Nothing
  where
    addIdentImportMod :: String -> DocumentUri -> Maybe String -> Aff Unit
    addIdentImportMod ident uri mod = do
      let Command { command, arguments } = addCompletionImport ident mod Nothing uri
      res <- sendCommand client command arguments
      case runExcept $ readArray res of
        Right forArr
          | Right arr <- runExcept $ traverse readString forArr
          -> showQuickPick arr >>= maybe (pure unit) (addIdentImportMod ident uri <<< Just)
        _ -> pure unit

addModuleImport :: LanguageClient -> Effect Unit
addModuleImport client = launchAffAndRaise $ void $ do
  modulesForeign <- sendCommand client (cmdName getAvailableModulesCmd) (toNullable Nothing)
  ed' <- liftEffect $ getActiveTextEditor
  case runExcept $ readArray modulesForeign, ed' of
    Right arr1, Just ed
      | Right modules <- runExcept $ traverse readString arr1
      -> do
        pick <- showQuickPick modules
        uri <- liftEffect $ filenameToUri =<< (getPath $ getDocument ed)
        case pick of
          Just modName -> void $ sendCommand client (cmdName addModuleImportCmd)
            (toNullable $ Just [ unsafeToForeign modName, unsafeToForeign $ toNullable Nothing, unsafeToForeign uri ])
          _ -> pure unit
    _, _ -> pure unit


Break up ContT and ErrorT examples

Break up ContT and ErrorT examples

module Files where

import Data.Either
import Data.Function

import Control.Monad.Eff

import Control.Monad.Cont.Trans
import Control.Monad.Error.Trans

foreign import data FS :: !

type ErrorCode = String

type FilePath = String

foreign import readFileImpl
  "function readFileImpl(path, onSuccess, onFailure) {\
  \  return function() {\
  \    require('fs').readFile(path, { encoding: 'utf-8' }, function(error, data) {\
  \      if (error) {\
  \        onFailure(error.code)();\
  \      } else {\
  \        onSuccess(data)();\
  \      }\
  \    });\
  \  };\
  \}" :: forall eff. Fn3 FilePath
                         (String -> Eff (fs :: FS | eff) Unit)
                         (ErrorCode -> Eff (fs :: FS | eff) Unit)
                         (Eff (fs :: FS | eff) Unit)

foreign import writeFileImpl
  "function writeFileImpl(path, data, onSuccess, onFailure) {\
  \  return function() {\
  \    require('fs').writeFile(path, data, { encoding: 'utf-8' }, function(error) {\
  \      if (error) {\
  \        onFailure(error.code)();\
  \      } else {\
  \        onSuccess();\
  \      }\
  \    });\
  \  };\
  \}" :: forall eff. Fn4 FilePath
                         String
                         (Eff (fs :: FS | eff) Unit)
                         (ErrorCode -> Eff (fs :: FS | eff) Unit)
                         (Eff (fs :: FS | eff) Unit)

readFile :: forall eff. FilePath -> (Either ErrorCode String -> Eff (fs :: FS | eff) Unit) -> Eff (fs :: FS | eff) Unit
readFile path k = runFn3 readFileImpl path (k <<< Right) (k <<< Left)

writeFile :: forall eff. FilePath -> String -> (Either ErrorCode Unit -> Eff (fs :: FS | eff) Unit) -> Eff (fs :: FS | eff) Unit
writeFile path text k = runFn4 writeFileImpl path text (k $ Right unit) (k <<< Left)

readFileCont :: forall eff. FilePath -> ContT Unit (Eff (fs :: FS | eff)) (Either ErrorCode String)
readFileCont path = ContT $ readFile path

writeFileCont :: forall eff. FilePath -> String -> ContT Unit (Eff (fs :: FS | eff)) (Either ErrorCode Unit)
writeFileCont path text = ContT $ writeFile path text

readFileContErr :: forall eff. FilePath -> ErrorT ErrorCode (ContT Unit (Eff (fs :: FS | eff))) String
readFileContErr path = ErrorT $ readFileCont path

writeFileContErr :: forall eff. FilePath -> String -> ErrorT ErrorCode (ContT Unit (Eff (fs :: FS | eff))) Unit
writeFileContErr path text = ErrorT $ writeFileCont path text

copyFileContErr :: forall eff. FilePath -> FilePath -> ErrorT ErrorCode (ContT Unit (Eff (fs :: FS | eff))) Unit
copyFileContErr src dest = do
  content <- readFileContErr src
  writeFileContErr dest content

module Files where

import Data.Either
import Data.Function

import Control.Monad.Eff

import Control.Monad.Cont.Trans
import Control.Monad.Error.Trans

foreign import data FS :: !

type ErrorCode = String

type FilePath = String

foreign import readFileImpl
  "function readFileImpl(path, onSuccess, onFailure) {\
  \  return function() {\
  \    require('fs').readFile(path, { encoding: 'utf-8' }, function(error, data) {\
  \      if (error) {\
  \        onFailure(error.code)();\
  \      } else {\
  \        onSuccess(data)();\
  \      }\
  \    });\
  \  };\
  \}" :: forall eff. Fn3 FilePath
                         (String -> Eff (fs :: FS | eff) Unit)
                         (ErrorCode -> Eff (fs :: FS | eff) Unit)
                         (Eff (fs :: FS | eff) Unit)

foreign import writeFileImpl
  "function writeFileImpl(path, data, onSuccess, onFailure) {\
  \  return function() {\
  \    require('fs').writeFile(path, data, { encoding: 'utf-8' }, function(error) {\
  \      if (error) {\
  \        onFailure(error.code)();\
  \      } else {\
  \        onSuccess();\
  \      }\
  \    });\
  \  };\
  \}" :: forall eff. Fn4 FilePath
                         String
                         (Eff (fs :: FS | eff) Unit)
                         (ErrorCode -> Eff (fs :: FS | eff) Unit)
                         (Eff (fs :: FS | eff) Unit)

readFile :: forall eff. FilePath -> (Either ErrorCode String -> Eff (fs :: FS | eff) Unit) -> Eff (fs :: FS | eff) Unit
readFile path k = runFn3 readFileImpl path (k <<< Right) (k <<< Left)

writeFile :: forall eff. FilePath -> String -> (Either ErrorCode Unit -> Eff (fs :: FS | eff) Unit) -> Eff (fs :: FS | eff) Unit
writeFile path text k = runFn4 writeFileImpl path text (k $ Right unit) (k <<< Left)

readFileCont :: forall eff. FilePath -> ErrorT ErrorCode (ContT Unit (Eff (fs :: FS | eff))) String
readFileCont path = ErrorT $ ContT $ readFile path

writeFileCont :: forall eff. FilePath -> String -> ErrorT ErrorCode (ContT Unit (Eff (fs :: FS | eff))) Unit
writeFileCont path text = ErrorT $ ContT $ writeFile path text

copyFileCont :: forall eff. FilePath -> FilePath -> ErrorT ErrorCode (ContT Unit (Eff (fs :: FS | eff))) Unit
copyFileCont src dest = do
  content <- readFileCont src
  writeFileCont dest content