Squashed commit of the following:

Squashed commit of the following:

commit 8535527a756a15a4d043249b4a88673099d0d49e
Author: Maxim Zimaliev <zimaliev@gmail.com>
Date:   Fri Sep 18 14:04:40 2015 +0300

    replaced $ with #

commit b92cce4cb920f2281852a74016429ca3805e2c2b
Author: Maxim Zimaliev <zimaliev@gmail.com>
Date:   Fri Sep 18 13:06:56 2015 +0300

    Squashed commit of the following:

    commit c9803c5545c0191b06c8f70026c9b9c6af9b7a4c
    Author: Maxim Zimaliev <zimaliev@gmail.com>
    Date:   Fri Sep 18 13:05:48 2015 +0300

        comments, analyzeString

    commit dd0fabcf9ca7d5644259dccb31352863b1c5f51c
    Author: Maxim Zimaliev <zimaliev@gmail.com>
    Date:   Fri Sep 18 02:20:53 2015 +0300

        SD-973 #done

{-
Copyright 2015 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module Model.Notebook.ECharts (
  analyzeJArray,
  getPossibleDependencies,
  dependsOn,
  isComplement,
  Axis(..),
  Semanthic(..),
  isValue,
  isPercent,
  isMoney,
  isBool,
  isTime,
  isCategory,
  isValAxis,
  isCatAxis,
  isTimeAxis,
  runAxis,
  catFromSemanthic,
  valFromSemanthic
  ) where

import Prelude
import Control.Alt ((<|>))
import Control.MonadPlus (guard)
import Data.Argonaut.Core (Json(), JArray(), toNumber, toString)
import Data.Argonaut.JCursor (JCursor(..), JsonPrim(), toPrims, runJsonPrim, insideOut)
import Data.Array (filter, concat, nubBy, singleton, sortBy, head, reverse, length, tail, (!!), (:), nub, elemIndex)
import Data.Bifunctor (rmap)
import Data.Foldable (for_, traverse_, foldl, fold, Foldable)
import Data.Traversable (traverse, sequence)
import Data.Function (on)
import Data.Map (fromList, Map(), toList, empty, alter, insert, keys, lookup, delete, update)
import Data.Maybe (Maybe(..), maybe, isJust, isNothing, fromMaybe)
import Data.Maybe.Unsafe (fromJust)
import Data.Monoid.Conj (Conj(..), runConj)
import Data.String (take)
import Data.String.Regex (noFlags, regex, match, test)
import Data.Tuple (Tuple(..), fst, snd)
import Global (readFloat, isNaN)
import Data.Argonaut.Decode (DecodeJson, decodeJson)
import Data.Argonaut.Encode (EncodeJson, encodeJson)
import Data.Argonaut.Combinators ((~>), (:=), (.?))
import Data.Argonaut.Core (fromString, jsonEmptyObject, JArray(), Json())
import Data.Either
import Data.Unfoldable (Unfoldable)
import Utils (s2n, s2i)
import qualified Data.List as L
import qualified Data.StrMap as Sm

dependsOn :: JCursor -> JCursor -> Boolean
dependsOn a b = a /= b &&
  dependsOn' (insideOut a) (insideOut b)
  where
  dependsOn' JCursorTop JCursorTop = true
  dependsOn' JCursorTop _ = true
  dependsOn' _ JCursorTop = true
  dependsOn' (JField _ c) (JField _ c') = dependsOn' c c'
  dependsOn' (JIndex _ c) (JIndex _ c') = dependsOn' c c'
  dependsOn' _ _ = false

data Semanthic
  = Value Number
  | Percent Number
  | Money Number String
  | Bool Boolean
  | Category String
  | Time String

instance encodeJsonSemanthic :: EncodeJson Semanthic where
  encodeJson (Value n) = "type" := "value"
                         ~> "value" := n
                         ~> jsonEmptyObject

  encodeJson (Percent n) = "type" := "percent"
                           ~> "value" := n
                           ~> jsonEmptyObject

  encodeJson (Money n v) = "type" := "money"
                           ~> "value" := n
                           ~> "currency" := v
                           ~> jsonEmptyObject

  encodeJson (Bool b) = "type" := "bool"
                        ~> "value" := b
                        ~> jsonEmptyObject

  encodeJson (Category c) = "type" := "category"
                            ~> "value" := c
                            ~> jsonEmptyObject

  encodeJson (Time t) = "type" := "time"
                        ~> "value" := t
                        ~> jsonEmptyObject

instance decodeJsonSemanthic :: DecodeJson Semanthic where
  decodeJson json = do
    obj <- decodeJson json
    ty <- obj .? "type"
    case ty of
      "money" -> do
        curr <- obj .? "currency"
        m <- obj .? "value"
        pure (Money m curr)
      "time" -> do
        t <- obj .? "value"
        pure $ Time t
      "bool" -> do
        b <- obj .? "value"
        pure $ Bool b
      "category" -> do
        c <- obj .? "value"
        pure $ Category c
      "value" -> do
        v <- obj .? "value"
        pure $ Value v
      "percent" -> do
        p <- obj .? "value"
        pure $ Percent p
      _ -> Left "incorrect type of semanthic"

data Axis
  = ValAxis (L.List (Maybe Semanthic))
  | CatAxis (L.List (Maybe Semanthic))
  | TimeAxis (L.List (Maybe Semanthic))

instance encodeJsonAxis :: EncodeJson Axis where
  encodeJson (ValAxis mbs) = "type" := "val-axis"
                             ~> "els" := mbs
                             ~> jsonEmptyObject

  encodeJson (CatAxis mbs) = "type" := "cat-axis"
                             ~> "els" := mbs
                             ~> jsonEmptyObject

  encodeJson (TimeAxis mbs) = "type" := "time-axis"
                              ~> "els" := mbs
                              ~> jsonEmptyObject

instance decodeJsonAxis :: DecodeJson Axis where
  decodeJson json = do
    obj <- decodeJson json
    ty <- obj .? "type"
    mbs <- obj .? "els"
    case ty of
      "val-axis" -> pure $ ValAxis mbs
      "cat-axis" -> pure $ CatAxis mbs
      "time-axis" -> pure $ TimeAxis mbs
      _ -> Left "incorrect axis type"

isValAxis :: Axis -> Boolean
isValAxis (ValAxis _) = true
isValAxis _ = false

isCatAxis :: Axis -> Boolean
isCatAxis (CatAxis _) = true
isCatAxis _ = false

isTimeAxis :: Axis -> Boolean
isTimeAxis (TimeAxis _) = true
isTimeAxis _ = false

runAxis :: Axis -> L.List (Maybe Semanthic)
runAxis (ValAxis a) = a
runAxis (CatAxis a) = a
runAxis (TimeAxis a) = a

instance axisShow :: Show Axis where
  show (ValAxis vs) = "(ValAxis " <> show vs <> ")"
  show (CatAxis vs) = "(CatAxis " <> show vs <> ")"
  show (TimeAxis vs) = "(TimeAxis " <> show vs <> ")"

isValue :: Semanthic -> Boolean
isValue (Value _) = true
isValue _ = false

isPercent :: Semanthic -> Boolean
isPercent (Percent _) = true
isPercent _ = false

isMoney :: Semanthic -> Boolean
isMoney (Money _ _) = true
isMoney _ = false

isBool :: Semanthic -> Boolean
isBool (Bool _) = true
isBool _ = false

isCategory :: Semanthic -> Boolean
isCategory (Category _) = true
isCategory _ = false

isTime :: Semanthic -> Boolean
isTime (Time _) = true
isTime _ = false

isComplement :: Axis -> Axis -> Boolean
isComplement (CatAxis _) (CatAxis _) = false
isComplement (TimeAxis _) (TimeAxis _) = false
isComplement _ _ = true

catFromSemanthic :: Semanthic -> Maybe String
catFromSemanthic v =
  case v of
    Value v -> pure $ show v
    Percent v -> pure $ show v <> "%"
    Money v m -> pure $ show v <> m
    Category s -> pure s
    Time t -> pure t

valFromSemanthic :: Semanthic -> Maybe Number
valFromSemanthic v =
  case v of
    Value v -> pure v
    Money v _ -> pure v
    Percent v -> pure v
    _ -> Nothing

check :: L.List (Maybe Semanthic) -> Maybe Axis
check lst =
  (ValAxis  <$> checkValues lst)   <|>
  (ValAxis  <$> checkMoney lst)    <|>
  (ValAxis  <$> checkPercent lst)  <|>
  (ValAxis  <$> checkBool lst)     <|>
  (TimeAxis <$> checkTime lst)     <|>
  (CatAxis  <$> checkCategory lst)

checkPredicate :: (Semanthic -> Boolean) -> L.List (Maybe Semanthic) ->
                  Maybe (L.List (Maybe Semanthic))
checkPredicate p lst =
  go 0 0 lst L.Nil
  where
  -- traversed. If there is more correct value then incorrect return
  -- list with filtered values. else nothing.
  go correct incorrect L.Nil acc
    | correct > incorrect = Just $ L.reverse acc
    | otherwise = Nothing
  -- There is no value. Just put it to acc don't touch counters
  go correct incorrect (L.Cons Nothing lst) acc =
    go correct incorrect lst (L.Cons Nothing acc)
  -- There is a value
  go correct incorrect (L.Cons (Just c) lst) acc
    -- It means nothing. Put Nothing to accum and don't touch counters
    | isJust $ elemIndex c nothings = go correct incorrect lst (L.Cons Nothing acc)
    -- It's correct. Increase correct counter, put value to accum
    | p c = go (correct + one) incorrect lst (L.Cons (Just c) acc)
    -- It's incorrect. Increase incorrect counter, put nothing to accum
    | otherwise = go correct (incorrect + one) lst (L.Cons Nothing acc)

  nothings :: Array Semanthic
  nothings = map Category [ "undefined"
                          , "null"
                          , "NA"
                          , "N/A"
                          ]

checkValues :: L.List (Maybe Semanthic) -> Maybe (L.List (Maybe Semanthic))
checkValues = checkPredicate isValue

checkMoney :: L.List (Maybe Semanthic) -> Maybe (L.List (Maybe Semanthic))
checkMoney = checkPredicate isMoney

checkPercent :: L.List (Maybe Semanthic) -> Maybe (L.List (Maybe Semanthic))
checkPercent = checkPredicate isPercent

checkBool :: L.List (Maybe Semanthic) -> Maybe (L.List (Maybe Semanthic))
checkBool = checkPredicate isBool

checkTime :: L.List (Maybe Semanthic) -> Maybe (L.List (Maybe Semanthic))
checkTime = checkPredicate isTime

checkCategory :: L.List (Maybe Semanthic) -> Maybe (L.List (Maybe Semanthic))
checkCategory = checkPredicate isCategory

instance semanthicShow :: Show Semanthic where
  show (Value v) = "(Value " <> show v <> ")"
  show (Percent p) = "(Percent " <> show p <> ")"
  show (Money n s) = "(Money " <> show n <> s <> ")"
  show (Bool b) = "(Bool " <> show b <> ")"
  show (Category s) = "(Category " <> s <> ")"
  show (Time t) = "(Time " <> t <> ")"

instance semanthicEq :: Eq Semanthic where
  eq (Value v) (Value v') = v == v'
  eq (Percent p) (Percent p') = p == p'
  eq (Money m c) (Money m' c') = m == m' && c == c'
  eq (Time t) (Time t') = t == t'
  eq (Category c) (Category c') = c == c'
  eq _ _ = false

instance semanthicOrd :: Ord Semanthic where
  compare (Time t) (Time t') = compare t t'
  compare (Time _) _ = LT
  compare (Money v a) (Money v' a') =
    if curComp == EQ
    then compare v v'
    else curComp
    where
    curComp = compare a a'
  compare (Money _ _) _ = LT
  compare (Percent v) (Percent v') = compare v v'
  compare (Percent _) _ = LT
  compare (Value v) (Value v') = compare v v'
  compare (Value _) _ = LT
  compare (Category c) (Category c') = compare c c'

analyze :: JsonPrim -> Maybe Semanthic
analyze p = runJsonPrim p
            (const Nothing)
            (Just <<< Bool)
            (Just <<< Value)
            analyzeString

analyzeString :: String -> Maybe Semanthic
analyzeString str =
  (analyzeDate str) <|>
  (analyzeNumber str) <|>
  (analyzeMoney str) <|>
  (analyzePercent str) <|>
  (Just $ Category str)

analyzeNumber :: String -> Maybe Semanthic
analyzeNumber s = do
  num <- s2n s
  i <- s2i s
  guard $ show num == s || show i == s
  pure $ Value num

analyzePercent :: String -> Maybe Semanthic
analyzePercent input = do
  ms <- match rgx input
  s <- (ms !! 1)
  n <- (s >>= s2n)
  pure $ Percent n
  where rgx = regex """^(-?\d+(\.\d+)?)\%$""" noFlags

curSymbols :: String
curSymbols = """[\$\u20A0-\u20CF\u00A2\u00A3\u00A4\u00A5\u058F\u060B\u09F2\u09F3\u09FB\u0AF1\u0BF9\u0E3F\u17DB\uA838\uFDFC\uFE69\uFF04\uFFE0\uFFE1\uFFE5\uFFE6]"""

analyzeMoney :: String -> Maybe Semanthic
analyzeMoney str = do
  ms <- match rgx str
  s <- (ms !! 1)
  n <- (s >>= s2n)
  curSymbol <- let fstSymbol = take 1 str
               in if fstSymbol == ""
                  then Nothing
                  else pure fstSymbol

  pure $ Money n curSymbol
  where
  rgx = regex rgxStr noFlags
  rgxStr = "^" <> curSymbols <> """?(([0-9]{1,3},([0-9]{3},)*[0-9]{3}|[0-9]+)(.[0-9][0-9])?)$"""

analyzeDate :: String -> Maybe Semanthic
analyzeDate str =
  if test rgx str
  then Just $ Time str
  else Nothing
  where
  rgxStr = "^(-?(?:[1-9][0-9]*)?[0-9]{4})-(1[0-2]|0[1-9])-(3[0-1]|0[1-9]|[1-2][0-9]) (2[0-3]|[0-1][0-9]):([0-5][0-9]):([0-5][0-9])(\\.[0-9]+)?(Z|[+-](?:2[0-3]|[0-1][0-9]):[0-5][0-9])?$"
  rgx = regex rgxStr noFlags

toSemanthic :: Json -> Map JCursor Semanthic
toSemanthic j = fromList $ L.catMaybes ((traverse analyze) <$> toPrims j)

toSemanthic' :: JArray -> Map JCursor (L.List (Maybe Semanthic))
toSemanthic' arr =
  step initial mapLst
  where
  mapArr = map toSemanthic $ reverse arr
  mapLst = L.toList mapArr
  ks = L.toList $ nub $ concat $ map (L.fromList <<< keys) mapArr
  initial = fromList $ map (flip Tuple L.Nil) ks

  step acc L.Nil = acc
  step acc (L.Cons m lst) =
    step (insertOne acc m ks) lst

  insertOne acc m L.Nil = acc
  insertOne acc m (L.Cons k ks) =
    insertOne (update (pure <<< L.Cons (lookup k m)) k acc) m ks

analyzeJArray :: JArray -> Map JCursor Axis
analyzeJArray arr =
  -- If array has exactly one element return it
  do guard $ length arr == 1
     arr !! 0
  -- If element returned transpose it else take initial array
  # maybe arr transpose
  -- Produce map from JCursor to List of values (Maybe Semanthic) for every Json
  # toSemanthic'
  -- Check if values of that map can be converted to axises (if can it will be Just)
  # map check
  -- Make list of Tuple JCursor (Maybe Axis)
  # toList
  -- lift Maybe to Tuple from Axis
  # map sequence
  -- Drop Nothings
  # L.catMaybes
  -- Create new Map
  # fromList
  -- Drop records those keys have no relations to other keys
  # checkPairs

  where
  transpose :: Json -> JArray
  transpose =
    -- decoding Json it should be a JObject to success
    decodeJson
    -- mapping Either
    -- convert StrMap to list of Tuples
    >>> map (Sm.toList
             -- mapping list
             -- make pair of Tuples from this one. One for key. One for value
             >>> map (tpl2sm
                      -- make StrMap from that pair {key: a, value: b}
                      >>> Sm.fromList
                      -- encode it to json
                      >>> encodeJson))
    -- if decoding to StrMap has no success return empty JArray it will
    -- not produce any Axises. Else convert List of JObjects to Array
    >>> either (const []) L.fromList

  tpl2sm :: Tuple String Json -> L.List (Tuple String Json)
  tpl2sm (Tuple key val) = L.Cons (Tuple "key" $ encodeJson key)
                           $ L.Cons (Tuple "value" val)
                           $ L.Nil

getPossibleDependencies :: JCursor -> Map JCursor Axis -> L.List JCursor
getPossibleDependencies cursor m =
  L.filter (dependsOn cursor) $ keys m

checkPairs :: Map JCursor Axis -> Map JCursor Axis
checkPairs m =
  foldl check m ks
  where
  ks = keys m
  check :: Map JCursor Axis -> JCursor -> Map JCursor Axis
  check m cursor =
    case getPossibleDependencies cursor m of
      L.Nil -> delete cursor m
      _ -> m

{-
Copyright 2015 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module Model.Notebook.ECharts (
  analyzeJArray,
  getPossibleDependencies,
  dependsOn,
  isComplement,
  Axis(..),
  Semanthic(..),
  isValue,
  isPercent,
  isMoney,
  isBool,
  isTime,
  isCategory,
  isValAxis,
  isCatAxis,
  isTimeAxis,
  runAxis,
  catFromSemanthic,
  valFromSemanthic
  ) where

import Prelude
import Control.Alt ((<|>))
import Data.Argonaut.Core (Json(), JArray(), toNumber, toString)
import Data.Argonaut.JCursor (JCursor(..), JsonPrim(), toPrims, runJsonPrim, insideOut)
import Data.Array (filter, concat, nubBy, singleton, sortBy, head, reverse, length, tail, (!!), (:), nub)
import Data.Bifunctor (rmap)
import Data.Foldable (for_, traverse_, foldl, fold, Foldable)
import Data.Traversable (traverse, sequence)
import Data.Function (on)
import Data.Map (fromList, Map(), toList, empty, alter, insert, keys, lookup, delete, update)
import Data.Maybe (Maybe(..), maybe, isJust, isNothing, fromMaybe)
import Data.Maybe.Unsafe (fromJust)
import Data.Monoid.Conj (Conj(..), runConj)
import Data.String (take)
import Data.String.Regex (noFlags, regex, match, test)
import Data.Tuple (Tuple(..), fst, snd)
import Global (readFloat, isNaN)
import Data.Argonaut.Decode (DecodeJson, decodeJson)
import Data.Argonaut.Encode (EncodeJson)
import Data.Argonaut.Combinators ((~>), (:=), (.?))
import Data.Argonaut.Core (fromString, jsonEmptyObject, JArray(), Json())
import Data.Either
import Data.Unfoldable (Unfoldable)
import Utils (s2n)
import qualified Data.List as L

dependsOn :: JCursor -> JCursor -> Boolean
dependsOn a b = a /= b &&
  dependsOn' (insideOut a) (insideOut b)
  where
  dependsOn' JCursorTop JCursorTop = true
  dependsOn' JCursorTop _ = true
  dependsOn' _ JCursorTop = true
  dependsOn' (JField _ c) (JField _ c') = dependsOn' c c'
  dependsOn' (JIndex _ c) (JIndex _ c') = dependsOn' c c'
  dependsOn' _ _ = false

data Semanthic
  = Value Number
  | Percent Number
  | Money Number String
  | Bool Boolean
  | Category String
  | Time String

instance encodeJsonSemanthic :: EncodeJson Semanthic where
  encodeJson (Value n) = "type" := "value"
                         ~> "value" := n
                         ~> jsonEmptyObject

  encodeJson (Percent n) = "type" := "percent"
                           ~> "value" := n
                           ~> jsonEmptyObject

  encodeJson (Money n v) = "type" := "money"
                           ~> "value" := n
                           ~> "currency" := v
                           ~> jsonEmptyObject

  encodeJson (Bool b) = "type" := "bool"
                        ~> "value" := b
                        ~> jsonEmptyObject

  encodeJson (Category c) = "type" := "category"
                            ~> "value" := c
                            ~> jsonEmptyObject

  encodeJson (Time t) = "type" := "time"
                        ~> "value" := t
                        ~> jsonEmptyObject

instance decodeJsonSemanthic :: DecodeJson Semanthic where
  decodeJson json = do
    obj <- decodeJson json
    ty <- obj .? "type"
    case ty of
      "money" -> do
        curr <- obj .? "currency"
        m <- obj .? "value"
        pure (Money m curr)
      "time" -> do
        t <- obj .? "value"
        pure $ Time t
      "bool" -> do
        b <- obj .? "value"
        pure $ Bool b
      "category" -> do
        c <- obj .? "value"
        pure $ Category c
      "value" -> do
        v <- obj .? "value"
        pure $ Value v
      "percent" -> do
        p <- obj .? "value"
        pure $ Percent p
      _ -> Left "incorrect type of semanthic"

data Axis
  = ValAxis (L.List (Maybe Semanthic))
  | CatAxis (L.List (Maybe Semanthic))
  | TimeAxis (L.List (Maybe Semanthic))

instance encodeJsonAxis :: EncodeJson Axis where
  encodeJson (ValAxis mbs) = "type" := "val-axis"
                             ~> "els" := mbs
                             ~> jsonEmptyObject

  encodeJson (CatAxis mbs) = "type" := "cat-axis"
                             ~> "els" := mbs
                             ~> jsonEmptyObject

  encodeJson (TimeAxis mbs) = "type" := "time-axis"
                              ~> "els" := mbs
                              ~> jsonEmptyObject

instance decodeJsonAxis :: DecodeJson Axis where
  decodeJson json = do
    obj <- decodeJson json
    ty <- obj .? "type"
    mbs <- obj .? "els"
    case ty of
      "val-axis" -> pure $ ValAxis mbs
      "cat-axis" -> pure $ CatAxis mbs
      "time-axis" -> pure $ TimeAxis mbs
      _ -> Left "incorrect axis type"

isValAxis :: Axis -> Boolean
isValAxis (ValAxis _) = true
isValAxis _ = false

isCatAxis :: Axis -> Boolean
isCatAxis (CatAxis _) = true
isCatAxis _ = false

isTimeAxis :: Axis -> Boolean
isTimeAxis (TimeAxis _) = true
isTimeAxis _ = false

runAxis :: Axis -> L.List (Maybe Semanthic)
runAxis (ValAxis a) = a
runAxis (CatAxis a) = a
runAxis (TimeAxis a) = a

instance axisShow :: Show Axis where
  show (ValAxis vs) = "(ValAxis " <> show vs <> ")"
  show (CatAxis vs) = "(CatAxis " <> show vs <> ")"
  show (TimeAxis vs) = "(TimeAxis " <> show vs <> ")"

isValue :: Semanthic -> Boolean
isValue (Value _) = true
isValue _ = false

isPercent :: Semanthic -> Boolean
isPercent (Percent _) = true
isPercent _ = false

isMoney :: Semanthic -> Boolean
isMoney (Money _ _) = true
isMoney _ = false

isBool :: Semanthic -> Boolean
isBool (Bool _) = true
isBool _ = false

isCategory :: Semanthic -> Boolean
isCategory (Category _) = true
isCategory _ = false

isTime :: Semanthic -> Boolean
isTime (Time _) = true
isTime _ = false

isComplement :: Axis -> Axis -> Boolean
isComplement (CatAxis _) (CatAxis _) = false
isComplement (TimeAxis _) (TimeAxis _) = false
isComplement _ _ = true

catFromSemanthic :: Semanthic -> Maybe String
catFromSemanthic v =
  case v of
    Value v -> pure $ show v
    Percent v -> pure $ show v <> "%"
    Money v m -> pure $ show v <> m
    Category s -> pure s
    Time t -> pure t

valFromSemanthic :: Semanthic -> Maybe Number
valFromSemanthic v =
  case v of
    Value v -> pure v
    Money v _ -> pure v
    Percent v -> pure v
    _ -> Nothing

check :: L.List (Maybe Semanthic) -> Maybe Axis
check lst =
  ((ValAxis  ) <$> checkValues lst)   <|>
  ((ValAxis  ) <$> checkMoney lst)    <|>
  ((ValAxis  ) <$> checkPercent lst)  <|>
  ((ValAxis  ) <$> checkBool lst)     <|>
  ((TimeAxis ) <$> checkTime lst)     <|>
  ((CatAxis  ) <$> checkCategory lst)

checkPredicate :: (Semanthic -> Boolean) -> L.List (Maybe Semanthic) ->
                  Maybe (L.List (Maybe Semanthic))
checkPredicate p lst = go true lst
  where
  go false L.Nil = Nothing
  go true L.Nil = Just lst
  go acc (L.Cons Nothing lst) = go acc lst
  go acc (L.Cons (Just c) lst) = go (acc && p c) lst

checkValues :: L.List (Maybe Semanthic) -> Maybe (L.List (Maybe Semanthic))
checkValues = checkPredicate isValue

checkMoney :: L.List (Maybe Semanthic) -> Maybe (L.List (Maybe Semanthic))
checkMoney = checkPredicate isMoney

checkPercent :: L.List (Maybe Semanthic) -> Maybe (L.List (Maybe Semanthic))
checkPercent = checkPredicate isPercent

checkBool :: L.List (Maybe Semanthic) -> Maybe (L.List (Maybe Semanthic))
checkBool = checkPredicate isBool

checkTime :: L.List (Maybe Semanthic) -> Maybe (L.List (Maybe Semanthic))
checkTime = checkPredicate isTime

checkCategory :: L.List (Maybe Semanthic) -> Maybe (L.List (Maybe Semanthic))
checkCategory = checkPredicate isCategory

instance semanthicShow :: Show Semanthic where
  show (Value v) = "(Value " <> show v <> ")"
  show (Percent p) = "(Percent " <> show p <> ")"
  show (Money n s) = "(Money " <> show n <> s <> ")"
  show (Bool b) = "(Bool " <> show b <> ")"
  show (Category s) = "(Category " <> s <> ")"
  show (Time t) = "(Time " <> t <> ")"

instance semanthicEq :: Eq Semanthic where
  eq (Value v) (Value v') = v == v'
  eq (Percent p) (Percent p') = p == p'
  eq (Money m c) (Money m' c') = m == m' && c == c'
  eq (Time t) (Time t') = t == t'
  eq (Category c) (Category c') = c == c'
  eq _ _ = false

instance semanthicOrd :: Ord Semanthic where
  compare (Time t) (Time t') = compare t t'
  compare (Time _) _ = LT
  compare (Money v a) (Money v' a') =
    if curComp == EQ
    then compare v v'
    else curComp
    where
    curComp = compare a a'
  compare (Money _ _) _ = LT
  compare (Percent v) (Percent v') = compare v v'
  compare (Percent _) _ = LT
  compare (Value v) (Value v') = compare v v'
  compare (Value _) _ = LT
  compare (Category c) (Category c') = compare c c'

analyze :: JsonPrim -> Maybe Semanthic
analyze p = runJsonPrim p
            (const Nothing)
            (Just <<< Bool)
            (Just <<< Value)
            analyzeString

analyzeString :: String -> Maybe Semanthic
analyzeString str =
  (analyzeDate str) <|>
  (analyzeMoney str) <|>
  (analyzePercent str) <|>
  (Just $ Category str)

analyzePercent :: String -> Maybe Semanthic
analyzePercent input = do
  ms <- match rgx input
  s <- (ms !! 1)
  n <- (s >>= s2n)
  pure $ Percent n
  where rgx = regex """^(-?\d+(\.\d+)?)\%$""" noFlags

curSymbols :: String
curSymbols = """[\$\u20A0-\u20CF\u00A2\u00A3\u00A4\u00A5\u058F\u060B\u09F2\u09F3\u09FB\u0AF1\u0BF9\u0E3F\u17DB\uA838\uFDFC\uFE69\uFF04\uFFE0\uFFE1\uFFE5\uFFE6]"""

analyzeMoney :: String -> Maybe Semanthic
analyzeMoney str = do
  ms <- match rgx str
  s <- (ms !! 1)
  n <- (s >>= s2n)
  curSymbol <- let fstSymbol = take 1 str
               in if fstSymbol == ""
                  then Nothing
                  else pure fstSymbol

  pure $ Money n curSymbol
  where
  rgx = regex rgxStr noFlags
  rgxStr = "^" <> curSymbols <> """?(([0-9]{1,3},([0-9]{3},)*[0-9]{3}|[0-9]+)(.[0-9][0-9])?)$"""

analyzeDate :: String -> Maybe Semanthic
analyzeDate str =
  if test rgx str
  then Just $ Time str
  else Nothing
  where
  rgxStr = "^(-?(?:[1-9][0-9]*)?[0-9]{4})-(1[0-2]|0[1-9])-(3[0-1]|0[1-9]|[1-2][0-9]) (2[0-3]|[0-1][0-9]):([0-5][0-9]):([0-5][0-9])(\\.[0-9]+)?(Z|[+-](?:2[0-3]|[0-1][0-9]):[0-5][0-9])?$"
  rgx = regex rgxStr noFlags

toSemanthic :: Json -> Map JCursor Semanthic
toSemanthic j = fromList $ L.catMaybes ((traverse analyze) <$> toPrims j)

toSemanthic' :: JArray -> Map JCursor (L.List (Maybe Semanthic))
toSemanthic' arr =
  step initial mapLst
  where
  mapArr = map toSemanthic $ reverse arr
  mapLst = L.toList mapArr
  ks = L.toList $ nub $ concat $ map (L.fromList <<< keys) mapArr
  initial = fromList $ map (flip Tuple L.Nil) ks

  step acc L.Nil = acc
  step acc (L.Cons m lst) =
    step (insertOne acc m ks) lst

  insertOne acc m L.Nil = acc
  insertOne acc m (L.Cons k ks) =
    insertOne (update (pure <<< L.Cons (lookup k m)) k acc) m ks

analyzeJArray :: JArray -> Map JCursor Axis
analyzeJArray arr =
  checkPairs
  $ fromList
  $ L.catMaybes
  $ map sequence
  $ toList
  $ map check
  $ toSemanthic' arr

getPossibleDependencies :: JCursor -> Map JCursor Axis -> L.List JCursor
getPossibleDependencies cursor m =
  L.filter (dependsOn cursor) $ keys m

checkPairs :: Map JCursor Axis -> Map JCursor Axis
checkPairs m =
  foldl check m ks
  where
  ks = keys m
  check :: Map JCursor Axis -> JCursor -> Map JCursor Axis
  check m cursor =
    case getPossibleDependencies cursor m of
      L.Nil -> delete cursor m
      _ -> m


Drop unused type variable

Drop unused type variable

module Node.FS.Async
  ( Callback (..)
  , rename
  , truncate
  , chown
  , chmod
  , stat
  , link
  , symlink
  , readlink
  , realpath
  , realpath'
  , unlink
  , rmdir
  , mkdir
  , mkdir'
  , readdir
  , utimes
  , readFile
  , readTextFile
  , writeFile
  , writeTextFile
  , appendFile
  , appendTextFile
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Data.Date
import Data.Either
import Data.Function
import Data.Maybe
import Node.Buffer (Buffer(..))
import Node.Encoding
import Node.FS
import Node.FS.Stats
import Node.Path (FilePath())

foreign import data Nullable :: * -> *

type JSCallback a = Fn2 (Nullable Error) a Unit

foreign import handleCallbackImpl
  "function handleCallbackImpl(left, right, f) {\
  \  return function(err, value) {\
  \    if (err) f(left(err))();\
  \    else f(right(value))();\
  \  };\
  \}" :: forall eff a. Fn3 (Error -> Either Error a)
                           (a -> Either Error a)
                           (Callback eff a)
                           (JSCallback a)

handleCallback :: forall eff a b. (Callback eff a) -> JSCallback a
handleCallback cb = runFn3 handleCallbackImpl Left Right cb

foreign import fs "var fs = require('fs');" ::
  { rename :: Fn3 FilePath FilePath (JSCallback Unit) Unit
  , truncate :: Fn3 FilePath Number (JSCallback Unit) Unit
  , chown :: Fn4 FilePath Number Number (JSCallback Unit) Unit
  , chmod :: Fn3 FilePath Number (JSCallback Unit) Unit
  , stat :: Fn2 FilePath (JSCallback StatsObj) Unit
  , link :: Fn3 FilePath FilePath (JSCallback Unit) Unit
  , symlink :: Fn4 FilePath FilePath String (JSCallback Unit) Unit
  , readlink :: Fn2 FilePath (JSCallback FilePath) Unit
  , realpath :: forall cache. Fn3 FilePath { | cache } (JSCallback FilePath) Unit
  , unlink :: Fn2 FilePath (JSCallback Unit) Unit
  , rmdir :: Fn2 FilePath (JSCallback Unit) Unit
  , mkdir :: Fn3 FilePath Number (JSCallback Unit) Unit
  , readdir :: Fn2 FilePath (JSCallback [FilePath]) Unit
  , utimes :: Fn4 FilePath Number Number (JSCallback Unit) Unit
  , readFile :: forall a opts. Fn3 FilePath { | opts } (JSCallback a) Unit
  , writeFile :: forall a opts. Fn4 FilePath a { | opts } (JSCallback Unit) Unit
  , appendFile :: forall a opts. Fn4 FilePath a { | opts } (JSCallback Unit) Unit
  }

-- |
-- Type synonym for callback functions.
--
type Callback eff a = Either Error a -> Eff eff Unit

-- |
-- Renames a file.
--
rename :: forall eff. FilePath
                   -> FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

rename oldFile newFile cb = return $ runFn3
  fs.rename oldFile newFile (handleCallback cb)

-- |
-- Truncates a file to the specified length.
--
truncate :: forall eff. FilePath
                     -> Number
                     -> Callback eff Unit
                     -> Eff (fs :: FS | eff) Unit

truncate file len cb = return $ runFn3
  fs.truncate file len (handleCallback cb)

-- |
-- Changes the ownership of a file.
--
chown :: forall eff. FilePath
                  -> Number
                  -> Number
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

chown file uid gid cb = return $ runFn4
  fs.chown file uid gid (handleCallback cb)

-- |
-- Changes the permissions of a file.
--
chmod :: forall eff. FilePath
                  -> Number
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

chmod file mode cb = return $ runFn3
  fs.chmod file mode (handleCallback cb)

-- |
-- Gets file statistics.
--
stat :: forall eff. FilePath
                 -> Callback eff Stats
                 -> Eff (fs :: FS | eff) Unit

stat file cb = return $ runFn2
  fs.stat file (handleCallback $ cb <<< (<$>) Stats)

-- |
-- Creates a link to an existing file.
--
link :: forall eff. FilePath
                 -> FilePath
                 -> Callback eff Unit
                 -> Eff (fs :: FS | eff) Unit

link src dst cb = return $ runFn3
  fs.link src dst (handleCallback cb)

-- |
-- Creates a symlink.
--
symlink :: forall eff. FilePath
                    -> FilePath
                    -> SymlinkType
                    -> Callback eff Unit
                    -> Eff (fs :: FS | eff) Unit

symlink src dest ty cb = return $ runFn4
  fs.symlink src dest (show ty) (handleCallback cb)

-- |
-- Reads the value of a symlink.
--
readlink :: forall eff. FilePath
                     -> Callback eff FilePath
                     -> Eff (fs :: FS | eff) Unit

readlink path cb = return $ runFn2
  fs.readlink path (handleCallback cb)

-- |
-- Find the canonicalized absolute location for a path.
--
realpath :: forall eff. FilePath
                     -> Callback eff FilePath
                     -> Eff (fs :: FS | eff) Unit

realpath path cb = return $ runFn3
  fs.realpath path {} (handleCallback cb)

-- |
-- Find the canonicalized absolute location for a path using a cache object for
-- already resolved paths.
--
realpath' :: forall eff cache. FilePath
                            -> { | cache }
                            -> Callback eff FilePath
                            -> Eff (fs :: FS | eff) Unit

realpath' path cache cb = return $ runFn3
  fs.realpath path cache (handleCallback cb)

-- |
-- Deletes a file.
--
unlink :: forall eff. FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

unlink file cb = return $ runFn2
  fs.unlink file (handleCallback cb)

-- |
-- Deletes a directory.
--
rmdir :: forall eff. FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

rmdir file cb = return $ runFn2
  fs.rmdir file (handleCallback cb)

-- |
-- Makes a new directory.
--
mkdir :: forall eff. FilePath
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

mkdir = flip mkdir' 777

-- |
-- Makes a new directory with the specified permissions.
--
mkdir' :: forall eff. FilePath
                   -> Number
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

mkdir' file mode cb = return $ runFn3
  fs.mkdir file mode (handleCallback cb)

-- |
-- Reads the contents of a directory.
--
readdir :: forall eff. FilePath
                    -> Callback eff [FilePath]
                    -> Eff (fs :: FS | eff) Unit

readdir file cb = return $ runFn2
  fs.readdir file (handleCallback cb)

-- |
-- Sets the accessed and modified times for the specified file.
--
utimes :: forall eff. FilePath
                   -> Date
                   -> Date
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

utimes file atime mtime cb = return $ runFn4
  fs.utimes file
            ((toEpochMilliseconds atime) / 1000)
            ((toEpochMilliseconds mtime) / 1000)
            (handleCallback cb)

-- |
-- Reads the entire contents of a file returning the result as a raw buffer.
--
readFile :: forall eff. FilePath
                     -> Callback eff Buffer
                     -> Eff (fs :: FS | eff) Unit

readFile file cb = return $ runFn3
  fs.readFile file {} (handleCallback cb)

-- |
-- Reads the entire contents of a text file with the specified encoding.
--
readTextFile :: forall eff. Encoding
                         -> FilePath
                         -> Callback eff String
                         -> Eff (fs :: FS | eff) Unit

readTextFile encoding file cb = return $ runFn3
  fs.readFile file { encoding: show encoding } (handleCallback cb)

-- |
-- Writes a buffer to a file.
--
writeFile :: forall eff. FilePath
                      -> Buffer
                      -> Callback eff Unit
                      -> Eff (fs :: FS | eff) Unit

writeFile file buff cb = return $ runFn4
  fs.writeFile file buff {} (handleCallback cb)

-- |
-- Writes text to a file using the specified encoding.
--
writeTextFile :: forall eff. Encoding
                          -> FilePath
                          -> String
                          -> Callback eff Unit
                          -> Eff (fs :: FS | eff) Unit

writeTextFile encoding file buff cb = return $ runFn4
  fs.writeFile file buff { encoding: show encoding } (handleCallback cb)

-- |
-- Appends the contents of a buffer to a file.
--
appendFile :: forall eff. FilePath
                       -> Buffer
                       -> Callback eff Unit
                       -> Eff (fs :: FS | eff) Unit

appendFile file buff cb = return $ runFn4
  fs.appendFile file buff {} (handleCallback cb)

-- |
-- Appends text to a file using the specified encoding.
--
appendTextFile :: forall eff. Encoding
                           -> FilePath
                           -> String
                           -> Callback eff Unit
                           -> Eff (fs :: FS | eff) Unit

appendTextFile encoding file buff cb = return $ runFn4
  fs.appendFile file buff { encoding: show encoding } (handleCallback cb)

module Node.FS.Async
  ( Callback (..)
  , rename
  , truncate
  , chown
  , chmod
  , stat
  , link
  , symlink
  , readlink
  , realpath
  , realpath'
  , unlink
  , rmdir
  , mkdir
  , mkdir'
  , readdir
  , utimes
  , readFile
  , readTextFile
  , writeFile
  , writeTextFile
  , appendFile
  , appendTextFile
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Data.Date
import Data.Either
import Data.Function
import Data.Maybe
import Node.Buffer (Buffer(..))
import Node.Encoding
import Node.FS
import Node.FS.Stats
import Node.Path (FilePath())

foreign import data Nullable :: * -> *

type JSCallback a = Fn2 (Nullable Error) a Unit

foreign import handleCallbackImpl
  "function handleCallbackImpl(left, right, f) {\
  \  return function(err, value) {\
  \    if (err) f(left(err))();\
  \    else f(right(value))();\
  \  };\
  \}" :: forall eff a b. Fn3 (Error -> Either Error a)
                             (a -> Either Error a)
                             (Callback eff a)
                             (JSCallback a)

handleCallback :: forall eff a b. (Callback eff a) -> JSCallback a
handleCallback cb = runFn3 handleCallbackImpl Left Right cb

foreign import fs "var fs = require('fs');" ::
  { rename :: Fn3 FilePath FilePath (JSCallback Unit) Unit
  , truncate :: Fn3 FilePath Number (JSCallback Unit) Unit
  , chown :: Fn4 FilePath Number Number (JSCallback Unit) Unit
  , chmod :: Fn3 FilePath Number (JSCallback Unit) Unit
  , stat :: Fn2 FilePath (JSCallback StatsObj) Unit
  , link :: Fn3 FilePath FilePath (JSCallback Unit) Unit
  , symlink :: Fn4 FilePath FilePath String (JSCallback Unit) Unit
  , readlink :: Fn2 FilePath (JSCallback FilePath) Unit
  , realpath :: forall cache. Fn3 FilePath { | cache } (JSCallback FilePath) Unit
  , unlink :: Fn2 FilePath (JSCallback Unit) Unit
  , rmdir :: Fn2 FilePath (JSCallback Unit) Unit
  , mkdir :: Fn3 FilePath Number (JSCallback Unit) Unit
  , readdir :: Fn2 FilePath (JSCallback [FilePath]) Unit
  , utimes :: Fn4 FilePath Number Number (JSCallback Unit) Unit
  , readFile :: forall a opts. Fn3 FilePath { | opts } (JSCallback a) Unit
  , writeFile :: forall a opts. Fn4 FilePath a { | opts } (JSCallback Unit) Unit
  , appendFile :: forall a opts. Fn4 FilePath a { | opts } (JSCallback Unit) Unit
  }

-- |
-- Type synonym for callback functions.
--
type Callback eff a = Either Error a -> Eff eff Unit

-- |
-- Renames a file.
--
rename :: forall eff. FilePath
                   -> FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

rename oldFile newFile cb = return $ runFn3
  fs.rename oldFile newFile (handleCallback cb)

-- |
-- Truncates a file to the specified length.
--
truncate :: forall eff. FilePath
                     -> Number
                     -> Callback eff Unit
                     -> Eff (fs :: FS | eff) Unit

truncate file len cb = return $ runFn3
  fs.truncate file len (handleCallback cb)

-- |
-- Changes the ownership of a file.
--
chown :: forall eff. FilePath
                  -> Number
                  -> Number
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

chown file uid gid cb = return $ runFn4
  fs.chown file uid gid (handleCallback cb)

-- |
-- Changes the permissions of a file.
--
chmod :: forall eff. FilePath
                  -> Number
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

chmod file mode cb = return $ runFn3
  fs.chmod file mode (handleCallback cb)

-- |
-- Gets file statistics.
--
stat :: forall eff. FilePath
                 -> Callback eff Stats
                 -> Eff (fs :: FS | eff) Unit

stat file cb = return $ runFn2
  fs.stat file (handleCallback $ cb <<< (<$>) Stats)

-- |
-- Creates a link to an existing file.
--
link :: forall eff. FilePath
                 -> FilePath
                 -> Callback eff Unit
                 -> Eff (fs :: FS | eff) Unit

link src dst cb = return $ runFn3
  fs.link src dst (handleCallback cb)

-- |
-- Creates a symlink.
--
symlink :: forall eff. FilePath
                    -> FilePath
                    -> SymlinkType
                    -> Callback eff Unit
                    -> Eff (fs :: FS | eff) Unit

symlink src dest ty cb = return $ runFn4
  fs.symlink src dest (show ty) (handleCallback cb)

-- |
-- Reads the value of a symlink.
--
readlink :: forall eff. FilePath
                     -> Callback eff FilePath
                     -> Eff (fs :: FS | eff) Unit

readlink path cb = return $ runFn2
  fs.readlink path (handleCallback cb)

-- |
-- Find the canonicalized absolute location for a path.
--
realpath :: forall eff. FilePath
                     -> Callback eff FilePath
                     -> Eff (fs :: FS | eff) Unit

realpath path cb = return $ runFn3
  fs.realpath path {} (handleCallback cb)

-- |
-- Find the canonicalized absolute location for a path using a cache object for
-- already resolved paths.
--
realpath' :: forall eff cache. FilePath
                            -> { | cache }
                            -> Callback eff FilePath
                            -> Eff (fs :: FS | eff) Unit

realpath' path cache cb = return $ runFn3
  fs.realpath path cache (handleCallback cb)

-- |
-- Deletes a file.
--
unlink :: forall eff. FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

unlink file cb = return $ runFn2
  fs.unlink file (handleCallback cb)

-- |
-- Deletes a directory.
--
rmdir :: forall eff. FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

rmdir file cb = return $ runFn2
  fs.rmdir file (handleCallback cb)

-- |
-- Makes a new directory.
--
mkdir :: forall eff. FilePath
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

mkdir = flip mkdir' 777

-- |
-- Makes a new directory with the specified permissions.
--
mkdir' :: forall eff. FilePath
                   -> Number
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

mkdir' file mode cb = return $ runFn3
  fs.mkdir file mode (handleCallback cb)

-- |
-- Reads the contents of a directory.
--
readdir :: forall eff. FilePath
                    -> Callback eff [FilePath]
                    -> Eff (fs :: FS | eff) Unit

readdir file cb = return $ runFn2
  fs.readdir file (handleCallback cb)

-- |
-- Sets the accessed and modified times for the specified file.
--
utimes :: forall eff. FilePath
                   -> Date
                   -> Date
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

utimes file atime mtime cb = return $ runFn4
  fs.utimes file
            ((toEpochMilliseconds atime) / 1000)
            ((toEpochMilliseconds mtime) / 1000)
            (handleCallback cb)

-- |
-- Reads the entire contents of a file returning the result as a raw buffer.
--
readFile :: forall eff. FilePath
                     -> Callback eff Buffer
                     -> Eff (fs :: FS | eff) Unit

readFile file cb = return $ runFn3
  fs.readFile file {} (handleCallback cb)

-- |
-- Reads the entire contents of a text file with the specified encoding.
--
readTextFile :: forall eff. Encoding
                         -> FilePath
                         -> Callback eff String
                         -> Eff (fs :: FS | eff) Unit

readTextFile encoding file cb = return $ runFn3
  fs.readFile file { encoding: show encoding } (handleCallback cb)

-- |
-- Writes a buffer to a file.
--
writeFile :: forall eff. FilePath
                      -> Buffer
                      -> Callback eff Unit
                      -> Eff (fs :: FS | eff) Unit

writeFile file buff cb = return $ runFn4
  fs.writeFile file buff {} (handleCallback cb)

-- |
-- Writes text to a file using the specified encoding.
--
writeTextFile :: forall eff. Encoding
                          -> FilePath
                          -> String
                          -> Callback eff Unit
                          -> Eff (fs :: FS | eff) Unit

writeTextFile encoding file buff cb = return $ runFn4
  fs.writeFile file buff { encoding: show encoding } (handleCallback cb)

-- |
-- Appends the contents of a buffer to a file.
--
appendFile :: forall eff. FilePath
                       -> Buffer
                       -> Callback eff Unit
                       -> Eff (fs :: FS | eff) Unit

appendFile file buff cb = return $ runFn4
  fs.appendFile file buff {} (handleCallback cb)

-- |
-- Appends text to a file using the specified encoding.
--
appendTextFile :: forall eff. Encoding
                           -> FilePath
                           -> String
                           -> Callback eff Unit
                           -> Eff (fs :: FS | eff) Unit

appendTextFile encoding file buff cb = return $ runFn4
  fs.appendFile file buff { encoding: show encoding } (handleCallback cb)


fadeWhen in cell render

fadeWhen in cell render

{-
Copyright 2015 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module Notebook.Cell.Component
  ( CellComponent()
  , makeEditorCellComponent
  , makeResultsCellComponent
  , module Notebook.Cell.Component.Def
  , module Notebook.Cell.Component.Query
  , module Notebook.Cell.Component.State
  ) where

import Prelude

import Control.Bind (join, (=<<))
import Control.Coroutine.Aff (produce)
import Control.Coroutine.Stalling (producerToStallingProducer)
import Control.Monad.Eff.Ref (newRef, readRef, writeRef)
import Control.Monad.Free (liftF)

import Data.Functor.Aff (liftAff)
import Data.Functor.Eff (liftEff)
import Data.Argonaut (jsonNull)
import Data.Date as Date
import Data.Either (Either(..))
import Data.Function (on)
import Data.Functor (($>))
import Data.Functor.Coproduct (left)
import Data.Lens (PrismP(), review, preview, clonePrism, (.~), (%~), (^.))
import Data.Maybe (Maybe(..), maybe, fromMaybe, isJust)
import Data.Path.Pathy as Path
import Data.Visibility (Visibility(..), toggleVisibility)

import Halogen
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Halogen.HTML.Events.Indexed as E
import Halogen.Query.EventSource (EventSource(..))
import Halogen.Query.HalogenF (HalogenFP(..))
import Halogen.Themes.Bootstrap3 as B

import DOM.Timer (interval, clearInterval)

import Render.Common (row, row', glyph, fadeWhen)
import Render.CssClasses as CSS

import Model.AccessType (AccessType(..))
import Notebook.Cell.CellType (CellType(..), AceMode(..), cellGlyph, cellName)
import Notebook.Cell.Port (Port(..), _Resource)
import Model.Resource (_filePath)

import Notebook.Cell.Common.EvalQuery (CellEvalQuery(..), prepareCellEvalInput)
import Notebook.Cell.Component.Def
import Notebook.Cell.Component.Query
import Notebook.Cell.Component.Render (CellHTML(), header, statusBar)
import Notebook.Cell.Component.State
import Notebook.Cell.RunState (RunState(..))
import Notebook.Common (Slam())

-- | Type synonym for the full type of a cell component.
type CellComponent = Component CellStateP CellQueryP Slam
type CellDSL = ParentDSL CellState AnyCellState CellQuery InnerCellQuery Slam Unit
-- | Constructs a cell component for an editor-style cell.
makeEditorCellComponent
  :: forall s f
   . EditorCellDef s f
  -> CellComponent
makeEditorCellComponent def = makeCellComponentPart def render
  where
  render :: Component AnyCellState InnerCellQuery Slam -> AnyCellState -> CellState -> CellHTML
  render component initialState cs =
    if cs.visibility == Invisible || cs.accessType == ReadOnly
    then H.text ""
    else
      H.div
        [ P.classes $ join [containerClasses, collapsedClass] ]
        [ header def cs
          -- Do we really need `row` here? Won't `H.div_` work?
        , row' (fadeWhen cs.isCollapsed)
          [ H.slot unit \_ -> { component: component, initialState: initialState } ]
        , statusBar cs.hasResults cs
        ]
    where
    collapsedClass = if cs.isCollapsed then [CSS.collapsed] else []

-- | Constructs a cell component for an results-style cell.
makeResultsCellComponent
  :: forall s f
   . ResultsCellDef s f
  -> CellComponent
makeResultsCellComponent def = makeCellComponentPart def render
  where
  render :: Component AnyCellState InnerCellQuery Slam -> AnyCellState -> CellState -> CellHTML
  render component initialState cs =
    if cs.visibility == Invisible
    then H.text ""
    else
      H.div
        [ P.classes containerClasses ]
        [ row' [CSS.cellOutput]
            [ H.div
                [ P.class_ CSS.cellOutputLabel ]
                [ H.text (resLabel cs.input)
                , H.ul [ P.class_ CSS.nextCellList ] (nextCellButtons cs.output)
                ]
            , H.div
                [ P.class_ CSS.cellOutputResult ]
                [ H.slot unit \_ -> { component: component, initialState: initialState } ]
            ]
        ]

  resLabel :: Maybe Port -> String
  resLabel p = maybe "" (\p -> Path.runFileName (Path.fileName p) ++ " :=") $ preview (_Resource <<< _filePath) =<< p

  nextCellButtons :: Maybe Port -> Array (CellHTML)
  nextCellButtons Nothing = []
  nextCellButtons (Just p) = case p of
    VarMap _ ->
      [ nextCellButton (Ace SQLMode) ]
    Resource _ ->
      [ nextCellButton (Ace SQLMode)
      , nextCellButton Search
      , nextCellButton Viz
      ]
    _ -> []

  nextCellButton :: CellType -> CellHTML
  nextCellButton cellType =
    H.li_
      [ H.button
          [ P.title (cellName cellType)
          , E.onClick $ E.input_ (CreateChildCell cellType)
          ]
          [ glyph (cellGlyph cellType) ]
      ]

containerClasses :: Array (H.ClassName)
containerClasses = [B.containerFluid, CSS.notebookCell, B.clearfix]

-- | Constructs a cell component from a record with the necessary properties and
-- | a render function.
makeCellComponentPart
  :: forall s f r
   . Object (CellDefProps s f r)
  -> (Component AnyCellState InnerCellQuery Slam -> AnyCellState -> CellState -> CellHTML)
  -> CellComponent
makeCellComponentPart def render =
  parentComponent (render component initialState) eval
  where

  _State :: PrismP AnyCellState s
  _State = clonePrism def._State

  _Query :: forall a. PrismP (InnerCellQuery a) (f a)
  _Query = clonePrism def._Query

  component :: Component AnyCellState InnerCellQuery Slam
  component = transform (review _State) (preview _State) (review _Query) (preview _Query) def.component

  initialState :: AnyCellState
  initialState = review _State def.initialState

  eval :: Natural CellQuery CellDSL
  eval (RunCell next) = pure next
  eval (UpdateCell input k) = do
    liftAff =<< gets (^. _tickStopper)
    tickStopper <- startInterval
    modify (_tickStopper .~ tickStopper)
    cachingEnabled <- gets _.cachingEnabled
    let input' = prepareCellEvalInput cachingEnabled input
    modify (_input .~ input'.inputPort)
    result <- query unit (left (request (EvalCell input')))
    maybe (pure unit) (\{ output } -> modify (_hasResults .~ isJust output)) result
    liftAff tickStopper
    modify
      $ (_runState %~ finishRun)
      <<< (_output .~ (_.output =<< result))
    maybe (liftF HaltHF) (pure <<< k <<< _.output) result
  eval (RefreshCell next) = pure next
  eval (TrashCell next) = pure next
  eval (CreateChildCell _ next) = pure next
  eval (ToggleCollapsed next) =
    modify (_isCollapsed %~ not) $> next
  eval (ToggleMessages next) =
    modify (_messageVisibility %~ toggleVisibility) $> next
  eval (ToggleCaching next) =
    modify (_cachingEnabled %~ not) $> next
  eval (ShareCell next) = pure next
  eval (Tick elapsed next) =
    modify (_runState .~ RunElapsed elapsed) $> next
  eval (GetOutput k) = k <$> gets (_.output)
  eval (SaveCell cellId cellType k) = do
    hasRun <- gets _.hasResults
    json <- query unit (left (request Save))
    pure (k { cellId, cellType, hasRun, state: fromMaybe jsonNull json })
  eval (LoadCell model next) =
    query unit (left (action (Load model.state))) $> next

-- | Starts a timer running on an interval that passes Tick queries back to the
-- | component, allowing the runState to be updated with a timer.
-- |
-- | The returned value is an action that will stop the timer running when
-- | processed.
startInterval :: CellDSL (Slam Unit)
startInterval = do
  ref <- liftEff (newRef Nothing)
  start <- liftEff Date.now
  modify (_runState .~ RunElapsed zero)

  subscribe' $ EventSource $ producerToStallingProducer $ produce \emit -> do
    i <- interval 1000 $ emit <<< Left <<< action <<< Tick =<< liftEff do
      now <- Date.now
      pure $ on (-) Date.toEpochMilliseconds now start
    writeRef ref (Just i)

  pure $ maybe (pure unit) (liftEff <<< clearInterval) =<< liftEff (readRef ref)

-- | Update the `RunState` from its current value to `RunFinished`.
finishRun :: RunState -> RunState
finishRun RunInitial = RunElapsed zero
finishRun (RunElapsed ms) = RunFinished ms
finishRun (RunFinished ms) = RunFinished ms

{-
Copyright 2015 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module Notebook.Cell.Component
  ( CellComponent()
  , makeEditorCellComponent
  , makeResultsCellComponent
  , module Notebook.Cell.Component.Def
  , module Notebook.Cell.Component.Query
  , module Notebook.Cell.Component.State
  ) where

import Prelude

import Control.Bind (join, (=<<))
import Control.Coroutine.Aff (produce)
import Control.Coroutine.Stalling (producerToStallingProducer)
import Control.Monad.Eff.Ref (newRef, readRef, writeRef)
import Control.Monad.Free (liftF)

import Data.Functor.Aff (liftAff)
import Data.Functor.Eff (liftEff)
import Data.Argonaut (jsonNull)
import Data.Date as Date
import Data.Either (Either(..))
import Data.Function (on)
import Data.Functor (($>))
import Data.Functor.Coproduct (left)
import Data.Lens (PrismP(), review, preview, clonePrism, (.~), (%~), (^.))
import Data.Maybe (Maybe(..), maybe, fromMaybe, isJust)
import Data.Path.Pathy as Path
import Data.Visibility (Visibility(..), toggleVisibility)

import Halogen
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Halogen.HTML.Events.Indexed as E
import Halogen.Query.EventSource (EventSource(..))
import Halogen.Query.HalogenF (HalogenFP(..))
import Halogen.Themes.Bootstrap3 as B

import DOM.Timer (interval, clearInterval)

import Render.Common (row, row', glyph)
import Render.CssClasses as CSS

import Model.AccessType (AccessType(..))
import Notebook.Cell.CellType (CellType(..), AceMode(..), cellGlyph, cellName)
import Notebook.Cell.Port (Port(..), _Resource)
import Model.Resource (_filePath)

import Notebook.Cell.Common.EvalQuery (CellEvalQuery(..), prepareCellEvalInput)
import Notebook.Cell.Component.Def
import Notebook.Cell.Component.Query
import Notebook.Cell.Component.Render (CellHTML(), header, statusBar)
import Notebook.Cell.Component.State
import Notebook.Cell.RunState (RunState(..))
import Notebook.Common (Slam())

-- | Type synonym for the full type of a cell component.
type CellComponent = Component CellStateP CellQueryP Slam
type CellDSL = ParentDSL CellState AnyCellState CellQuery InnerCellQuery Slam Unit
-- | Constructs a cell component for an editor-style cell.
makeEditorCellComponent
  :: forall s f
   . EditorCellDef s f
  -> CellComponent
makeEditorCellComponent def = makeCellComponentPart def render
  where
  render :: Component AnyCellState InnerCellQuery Slam -> AnyCellState -> CellState -> CellHTML
  render component initialState cs =
    if cs.visibility == Invisible || cs.accessType == ReadOnly
    then H.text ""
    else
      H.div
        [ P.classes $ join [containerClasses, collapsedClass] ]
        [ header def cs
          -- Do we really need `row` here? Won't `H.div_` work?
        , row [ H.slot unit \_ -> { component: component, initialState: initialState } ]
        , statusBar cs.hasResults cs
        ]
    where
    collapsedClass = if cs.isCollapsed then [CSS.collapsed] else []

-- | Constructs a cell component for an results-style cell.
makeResultsCellComponent
  :: forall s f
   . ResultsCellDef s f
  -> CellComponent
makeResultsCellComponent def = makeCellComponentPart def render
  where
  render :: Component AnyCellState InnerCellQuery Slam -> AnyCellState -> CellState -> CellHTML
  render component initialState cs =
    if cs.visibility == Invisible
    then H.text ""
    else
      H.div
        [ P.classes containerClasses ]
        [ row' [CSS.cellOutput]
            [ H.div
                [ P.class_ CSS.cellOutputLabel ]
                [ H.text (resLabel cs.input)
                , H.ul [ P.class_ CSS.nextCellList ] (nextCellButtons cs.output)
                ]
            , H.div
                [ P.class_ CSS.cellOutputResult ]
                [ H.slot unit \_ -> { component: component, initialState: initialState } ]
            ]
        ]

  resLabel :: Maybe Port -> String
  resLabel p = maybe "" (\p -> Path.runFileName (Path.fileName p) ++ " :=") $ preview (_Resource <<< _filePath) =<< p

  nextCellButtons :: Maybe Port -> Array (CellHTML)
  nextCellButtons Nothing = []
  nextCellButtons (Just p) = case p of
    VarMap _ ->
      [ nextCellButton (Ace SQLMode) ]
    Resource _ ->
      [ nextCellButton (Ace SQLMode)
      , nextCellButton Search
      , nextCellButton Viz
      ]
    _ -> []

  nextCellButton :: CellType -> CellHTML
  nextCellButton cellType =
    H.li_
      [ H.button
          [ P.title (cellName cellType)
          , E.onClick $ E.input_ (CreateChildCell cellType)
          ]
          [ glyph (cellGlyph cellType) ]
      ]

containerClasses :: Array (H.ClassName)
containerClasses = [B.containerFluid, CSS.notebookCell, B.clearfix]

-- | Constructs a cell component from a record with the necessary properties and
-- | a render function.
makeCellComponentPart
  :: forall s f r
   . Object (CellDefProps s f r)
  -> (Component AnyCellState InnerCellQuery Slam -> AnyCellState -> CellState -> CellHTML)
  -> CellComponent
makeCellComponentPart def render =
  parentComponent (render component initialState) eval
  where

  _State :: PrismP AnyCellState s
  _State = clonePrism def._State

  _Query :: forall a. PrismP (InnerCellQuery a) (f a)
  _Query = clonePrism def._Query

  component :: Component AnyCellState InnerCellQuery Slam
  component = transform (review _State) (preview _State) (review _Query) (preview _Query) def.component

  initialState :: AnyCellState
  initialState = review _State def.initialState

  eval :: Natural CellQuery CellDSL
  eval (RunCell next) = pure next
  eval (UpdateCell input k) = do
    liftAff =<< gets (^. _tickStopper)
    tickStopper <- startInterval
    modify (_tickStopper .~ tickStopper)
    cachingEnabled <- gets _.cachingEnabled
    let input' = prepareCellEvalInput cachingEnabled input
    modify (_input .~ input'.inputPort)
    result <- query unit (left (request (EvalCell input')))
    maybe (pure unit) (\{ output } -> modify (_hasResults .~ isJust output)) result
    liftAff tickStopper
    modify
      $ (_runState %~ finishRun)
      <<< (_output .~ (_.output =<< result))
    maybe (liftF HaltHF) (pure <<< k <<< _.output) result
  eval (RefreshCell next) = pure next
  eval (TrashCell next) = pure next
  eval (CreateChildCell _ next) = pure next
  eval (ToggleCollapsed next) =
    modify (_isCollapsed %~ not) $> next
  eval (ToggleMessages next) =
    modify (_messageVisibility %~ toggleVisibility) $> next
  eval (ToggleCaching next) =
    modify (_cachingEnabled %~ not) $> next
  eval (ShareCell next) = pure next
  eval (Tick elapsed next) =
    modify (_runState .~ RunElapsed elapsed) $> next
  eval (GetOutput k) = k <$> gets (_.output)
  eval (SaveCell cellId cellType k) = do
    hasRun <- gets _.hasResults
    json <- query unit (left (request Save))
    pure (k { cellId, cellType, hasRun, state: fromMaybe jsonNull json })
  eval (LoadCell model next) =
    query unit (left (action (Load model.state))) $> next

-- | Starts a timer running on an interval that passes Tick queries back to the
-- | component, allowing the runState to be updated with a timer.
-- |
-- | The returned value is an action that will stop the timer running when
-- | processed.
startInterval :: CellDSL (Slam Unit)
startInterval = do
  ref <- liftEff (newRef Nothing)
  start <- liftEff Date.now
  modify (_runState .~ RunElapsed zero)

  subscribe' $ EventSource $ producerToStallingProducer $ produce \emit -> do
    i <- interval 1000 $ emit <<< Left <<< action <<< Tick =<< liftEff do
      now <- Date.now
      pure $ on (-) Date.toEpochMilliseconds now start
    writeRef ref (Just i)

  pure $ maybe (pure unit) (liftEff <<< clearInterval) =<< liftEff (readRef ref)

-- | Update the `RunState` from its current value to `RunFinished`.
finishRun :: RunState -> RunState
finishRun RunInitial = RunElapsed zero
finishRun (RunElapsed ms) = RunFinished ms
finishRun (RunFinished ms) = RunFinished ms


Improve array tests

Improve array tests

module Test.Data.Array where

import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Data.Array
import Data.Maybe
import Data.Tuple
import Data.Foldable (sum)
import Debug.Trace
import Global (nan, infinity)
import Test.QuickCheck
import Test.Classes

double :: Number -> Number
double x = x * 2

one :: forall a. a -> Number
one _ = 1

doubleAndOrig :: Number -> [Number]
doubleAndOrig x = [x * 2, x]

nil :: [Number]
nil = []

odd :: Number -> Boolean
odd n = n % 2 /= 0

main = do

  trace "test equality"
  check1 $ \n -> [n] == [n]

  trace "test inequality"
  check1 $ \n -> [n] /= [n + 1]

  trace "(!!) should return Just x when the index is within the bounds of the array"
  assert $ [1, 2, 3] !! 0 == (Just 1)
  assert $ [1, 2, 3] !! 1 == (Just 2)
  assert $ [1, 2, 3] !! 2 == (Just 3)

  trace "(!!) should return Nothing when the index is outside of the bounds of the array"
  assert $ [1, 2, 3] !! 6 == Nothing
  assert $ [1, 2, 3] !! -1 == Nothing

  trace "(!!) should return Nothing when the index not an integer"
  assert $ [1, 2, 3] !! 0.2 == Nothing
  assert $ [1, 2, 3] !! nan == Nothing
  assert $ [1, 2, 3] !! infinity == Nothing
  assert $ [1, 2, 3] !! -infinity == Nothing

  trace "snoc should add an item to the end of an array"
  assert $ [1, 2, 3] `snoc` 4 == [1, 2, 3, 4]
  assert $ nil `snoc` 1 == [1]

  trace "singleton should construct an array with a single value"
  check1 $ \x -> singleton x == [x]

  trace "head should return a Just-wrapped first value of a non-empty array"
  quickCheck $ \xs n -> head (n : xs) == Just (n :: Number)

  trace "head should return Nothing for an empty array"
  assert $ head nil == Nothing

  trace "last should return a Just-wrapped first value of a non-empty array"
  quickCheck $ \xs n -> last (xs `snoc` n) == Just (n :: Number)

  trace "last should return Nothing for an empty array"
  assert $ last nil == Nothing

  trace "tail should return a Just-wrapped array containing all the items in an array apart from the first for a non-empty array"
  quickCheck $ \xs n -> tail (n : xs) == Just (xs :: [Number])

  trace "tail should return Nothing for an empty array"
  assert $ tail nil == Nothing

  trace "init should return a Just-wrapped array containing all the items in an array apart from the first for a non-empty array"
  quickCheck $ \xs n -> init (xs `snoc` n) == Just (xs :: [Number])

  trace "init should return Nothing for an empty array"
  assert $ init nil == Nothing

  trace "null should return false for non-empty arrays"
  checkA1 $ \xs -> case xs of
    [] -> true
    xs -> null xs == false

  trace "null should return true for an empty array"
  assert $ null nil == true

  trace "map should transform every item in an array"
  checkA1 $ \xs -> sum (map double xs) == double (sum xs)

  trace "length should return the number of items in an array"
  checkA1 $ \xs -> length xs == sum (map one xs)

  trace "elem should return true when the item is present in an array"
  assert $ elem 1 [1, 2, 3]
  assert $ elem 2 [1, 2, 3]
  assert $ elem 3 [1, 2, 3]

  trace "elem should return true when the item is not present in an array"
  assert $ elem 4 [1, 2, 3] == false
  assert $ elem 4 nil == false

  trace "elemIndex should return the index of an item in an array"
  assert $ (elemIndex 1 [1, 2, 1]) == 0
  assert $ (elemIndex 4 [1, 2, 1]) == -1

  trace "elemIndex should return the last index of an item in an array"
  assert $ (elemLastIndex 1 [1, 2, 1]) == 2
  assert $ (elemLastIndex 4 [1, 2, 1]) == -1

  trace "concat should join a list of lists"
  assert $ (concat [[1, 2], [3, 4]]) == [1, 2, 3, 4]
  assert $ (concat [[1], nil]) == [1]
  assert $ (concat [nil, nil]) == nil

  trace "reverse should reverse the order of items in an array"
  assert $ (reverse [1, 2, 3]) == [3, 2, 1]
  assert $ (reverse nil) == nil

  trace "reverse should remove the specified number of items from the front of an array"
  assert $ (drop 1 [1, 2, 3]) == [2, 3]
  assert $ (drop 2 [1, 2, 3]) == [3]
  assert $ (drop 1 nil) == nil

  trace "reverse should keep the specified number of items from the front of an array, discarding the rest"
  assert $ (take 1 [1, 2, 3]) == [1]
  assert $ (take 2 [1, 2, 3]) == [1, 2]
  assert $ (take 1 nil) == nil

  trace "insertAt should add an item at the specified index"
  assert $ (insertAt 0 1 [2, 3]) == [1, 2, 3]
  assert $ (insertAt 1 1 [2, 3]) == [2, 1, 3]

  trace "deleteAt should remove an item at the specified index"
  assert $ (deleteAt 0 1 [1, 2, 3]) == [2, 3]
  assert $ (deleteAt 1 1 [1, 2, 3]) == [1, 3]

  trace "updateAt should replace an item at the specified index"
  assert $ (updateAt 0 9 [1, 2, 3]) == [9, 2, 3]
  assert $ (updateAt 1 9 [1, 2, 3]) == [1, 9, 3]
  assert $ (updateAt 1 9 nil) == nil

  trace "concatMap should be equivalent to concat . map"
  checkA1 $ \xs -> concatMap doubleAndOrig xs == concat (map doubleAndOrig xs)

  trace "filter should remove items that don't match a predicate"
  assert $ filter odd (range 0 10) == [1, 3, 5, 7, 9]

  trace "range should create an inclusive array of integers for the specified start and end"
  assert $ range 0 5 == [0, 1, 2, 3, 4, 5]
  assert $ range 2 (-3) == [2, 1, 0, -1, -2, -3]

  trace "zipWith should use the specified function to zip two lists together"
  assert $ zipWith Tuple [1, 2, 3] ["a", "b", "c"] == [Tuple 1 "a", Tuple 2 "b", Tuple 3 "c"]

  trace "nub should remove duplicate items from the list"
  assert $ nub [1, 2, 2, 3, 4, 1] == [1, 2, 3, 4]

  trace "nubBy should remove duplicate items from the list using a supplied predicate"
  let nubPred = \x y -> if odd x then false else x == y
  assert $ nubBy nubPred [1, 2, 2, 3, 3, 4, 4, 1] == [1, 2, 3, 3, 4, 1]

  trace "sort should reorder a list into ascending order based on the result of compare"
  assert $ sort [1, 3, 2, 5, 6, 4] == [1, 2, 3, 4, 5, 6]

  let ty = [0]

  trace "test functor laws"
  checkFunctor ty

  trace "test applicative laws"
  checkApplicative ty ty ty

  trace "test monad laws"
  checkMonad ty

assert :: Boolean -> QC {}
assert = quickCheck' 1

check1 :: (Number -> Boolean) -> QC {}
check1 = quickCheck

checkA1 :: ([Number] -> Boolean) -> QC {}
checkA1 = quickCheck

module Test.Data.Array where

import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Data.Array
import Data.Maybe
import Data.Tuple
import Debug.Trace

assertEq :: forall a eff. (Show a, Eq a) => a -> a -> Eff (err :: Exception String, trace :: Trace | eff) {}
assertEq x y =
  if x /= y
    then throwException $ "Assertion failed: " ++ show x ++ " /= " ++ show y
    else trace $ "Assertion passed"

double :: Number -> Number
double x = x * 2

doubleAndOrig :: Number -> [Number]
doubleAndOrig x = [x * 2, x]

nil :: [Number]
nil = []

odd :: Number -> Boolean
odd n = n % 2 /= 0

main = do

  -- TODO: use quickcheck where appropriate

  assertEq (head [1, 2, 3]) (Just 1)
  assertEq (head nil) Nothing

  assertEq (tail [1, 2, 3]) (Just [2, 3])
  assertEq (tail nil) Nothing

  assertEq (map double [1, 2, 3]) [2, 4, 6]

  assertEq (length [1, 2, 3]) 3
  assertEq (length nil) 0

  assertEq (elemIndex [1, 2, 1] 1) 0
  assertEq (elemIndex [1, 2, 1] 4) (-1)

  assertEq (elemLastIndex [1, 2, 1] 1) 2
  assertEq (elemLastIndex [1, 2, 1] 4) (-1)

  assertEq (concat [[1, 2], [3, 4]]) [1, 2, 3, 4]
  assertEq (concat [[1], nil]) [1]
  assertEq (concat [nil, nil]) nil

  assertEq (reverse [1, 2, 3]) [3, 2, 1]
  assertEq (reverse nil) nil

  assertEq (drop 1 [1, 2, 3]) [2, 3]
  assertEq (drop 1 nil) nil

  assertEq (take 1 [1, 2, 3]) [1]
  assertEq (take 1 nil) nil

  assertEq (slice 1 3 [1, 2, 3, 4]) [2, 3]
  assertEq (slice 0 0 [1, 2, 3, 4]) nil
  assertEq (slice 0 1 nil) nil

  assertEq (insertAt 0 1 [2, 3]) [1, 2, 3]
  assertEq (insertAt 0 1 nil) [1]

  assertEq (deleteAt 0 1 [1, 2, 3]) [2, 3]
  assertEq (deleteAt 0 1 nil) nil

  assertEq (updateAt 1 999 [1, 2, 3]) [1, 999, 3]

  assertEq (concatMap doubleAndOrig [1, 2, 3]) [2, 1, 4, 2, 6, 3]

  assertEq (filter odd [1, 2, 3]) [1, 3]

  assertEq (null [1, 2, 3]) false
  assertEq (null nil) true

  assertEq (range 0 5) [0, 1, 2, 3, 4, 5]

  assertEq (zipWith Tuple [1, 2, 3] ["a", "b", "c"]) [Tuple 1 "a", Tuple 2 "b", Tuple 3 "c"]

  assertEq (nub [1, 2, 2, 3, 4, 1]) [1, 2, 3, 4]

  assertEq (sort [1, 3, 2, 5, 6, 4]) [1, 2, 3, 4, 5, 6]


Hide old results when a new request fails

module View.Notebook.Cell (cell) where

import Control.Functor (($>))
import Controller.Notebook.Cell (runCellEvent)
import Controller.Notebook.Cell.Viz (insertViz)
import Data.Array (length, null)
import Data.Date (Date(), toEpochMilliseconds)
import Data.Function (on)
import Data.Maybe (Maybe(), maybe)
import Data.Time (Milliseconds(..), Seconds(..), toSeconds)
import Input.Notebook (Input(..))
import Model.Notebook
import Model.Notebook.Cell
import Model.Notebook.Port (Port(..))
import Number.Format (toFixed)
import Optic.Core ((^.), (%~), (..), is)

import View.Common
import View.Notebook.Cell.Ace (aceEditor)
import View.Notebook.Cell.Explore (exploreEditor, exploreOutput)
import View.Notebook.Cell.Search (searchOutput, searchEditor)
import View.Notebook.Cell.Viz (vizChoices, vizOutput)
import View.Notebook.Cell.Markdown (markdownOutput)
import View.Notebook.Cell.Query (queryOutput)
import View.Notebook.Common

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as E
import qualified Halogen.HTML.Events.Forms as E
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import qualified Halogen.Themes.Bootstrap3 as B
import qualified View.Css as VC

cell :: forall e. State -> Cell -> [HTML e]
cell notebook state =
  [ H.div [ A.classes [B.containerFluid, VC.notebookCell] ]
    [ controls state
    , editor state
    , statusBar notebook.tickDate state
    , output state
    , insertNextCell notebook state
    ]
  ]

controls :: forall e. Cell -> HTML e
controls state =
  row [ H.div [ A.classes [B.btnGroup, B.pullRight, VC.cellControls] ]
        [ H.button [ A.classes [B.btn]
                   , E.onClick $ E.input_ $ UpdateCell (state ^. _cellId) (_hiddenEditor %~ not)
                   ]
          [ H.text (if state ^. _hiddenEditor then "Show" else "Hide") ]
        , H.button [ A.classes [B.btn]
                   , E.onClick $ E.input_ $ TrashCell $ state ^. _cellId
                   ]
          [ H.text "Trash" ]
        ]
      ]

output :: forall e. Cell -> HTML e
output state =
   H.div [ A.classes $ [B.row, VC.cellOutput, B.fade] ++
           if (_RunFinished `is` (state ^. _runState) || _Visualize `is` (state ^. _content)) && null (state ^. _failures)
           then [B.in_]
           else [] ]
   $ renderOutput state

statusBar :: forall e. Maybe Date -> Cell -> HTML e
statusBar d state =
  row' (fadeWhen (state ^. _hiddenEditor))
  [ H.div [ A.classes [VC.cellEvalLine, B.clearfix] ]
    [ H.button [ A.classes [ B.btn
                           , B.btnPrimary
                           , if isRunning (state ^. _runState)
                             then VC.stopButton
                             else VC.playButton ]
               , E.onClick \_ -> pure (runCellEvent state)
               ]
      [ if isRunning (state ^. _runState)
        then glyph B.glyphiconStop
        else glyph B.glyphiconPlay ]
    , H.div [ A.classes [ VC.statusText ] ]
      [ H.text $ statusText d (state ^. _runState) ]
    , H.div [ A.classes [ VC.cellFailures ] ]
      (failureText (state ^. _cellId) (state ^. _expandedStatus) (state ^. _failures))
    ]
  ]

insertNextCell :: forall e. State -> Cell -> HTML e
insertNextCell notebook state = row
  [ H.div [ A.classes [ VC.cellEvalLine, B.clearfix ] ]
    [ H.button
      [ A.classes [ B.btn
                  , B.btnPrimary
                  , VC.playButton
                  ]
      , E.onClick $ E.input_ $ UpdateCell (state ^. _cellId) (_addingNextCell %~ not)
      ]
      [ glyph if state ^. _addingNextCell
              then B.glyphiconMenuLeft
              else B.glyphiconMenuRight ]
    , H.ul [ A.classes ([ B.listInline, VC.nextCellList ] <>
                        (fadeWhen $ not $ (state ^. _addingNextCell))) ]
      (nextCellChoices notebook state)
    ]
  ]
nextCellChoices :: forall e. State -> Cell -> [HTML e]
nextCellChoices notebook state =
  [ li "Query cell" newQueryContent  B.glyphiconHdd
  , li "Explore cell" newExploreContent B.glyphiconEyeOpen
  , li "Markdown cell" newMarkdownContent B.glyphiconEdit
  , li "Search cell" newSearchContent B.glyphiconSearch] <>
  case state ^. _output of
    PortResource _ ->
      [ H.li_ [ H.a [ A.href "#"
                  , E.onClick (\_ -> E.preventDefault $> insertViz notebook state)
                  , A.title "Visualization cell"
                  , A.classes [ B.btn ]
                  ]
              [ glyph B.glyphiconPicture ]
              ]
      ]
    _ -> [ ]

  where
  li :: String -> CellContent -> A.ClassName -> HTML e
  li title content c =
    H.li_ [ H.a [ A.href "#"
                , E.onClick \_ -> E.preventDefault $> pure (InsertCell state content)
                , A.title title
                , A.classes [ B.btn ] ] [ glyph c ] ]

failureText :: forall e. CellId -> Boolean -> [FailureMessage] -> [HTML e]
failureText _ _ [ ] = [ ]
failureText cellId expanded fs =
  [ H.div_ [ H.text (show (length fs) <> " error(s) during evaluation. ")
  , H.a [ A.href "#", E.onClick (\_ -> E.preventDefault $> pure (UpdateCell cellId (_expandedStatus %~ not))) ] linkText ]
  ] <>
    if expanded
    then (\f -> H.div_ [ H.text f ]) <$> fs
    else [ ]
  where linkText =
          [ H.text (if expanded
                    then "Hide details"
                    else "Show details") ]

isRunning :: RunState -> Boolean
isRunning (RunningSince _) = true
isRunning _ = false

statusText :: Maybe Date -> RunState -> String
statusText _ RunInitial = ""
statusText d (RunningSince d') = maybe "" (\s -> "Running for " <> s <> "s") $ d >>= flip secondsText d'
statusText _ (RunFinished (Milliseconds ms)) = "Finished: took " <> show ms <> "ms."

secondsText :: Date -> Date -> Maybe String
secondsText a b = toFixed 0 <<< Math.max 0 <<< unSeconds $ on (-) (toSeconds <<< toEpochMilliseconds) a b
  where unSeconds (Seconds n) = n

editor :: forall e. Cell -> HTML e
editor state = case state ^. _content of
  (Explore rec) -> exploreEditor state
  (Search _) -> searchEditor state
  (Visualize _) -> vizChoices state
  _ -> aceEditor state

renderOutput :: forall e. Cell -> [HTML e]
renderOutput cell =
  if not (null $ cell ^. _failures)
  then []
  else case cell ^. _content of
    Explore _ -> exploreOutput cell
    Markdown s -> [markdownOutput s (cell ^. _cellId)]
    Search _ -> searchOutput cell
    Visualize _ -> vizOutput cell
    Query _ -> queryOutput cell
    _ -> []

module View.Notebook.Cell (cell) where

import Control.Functor (($>))
import Controller.Notebook.Cell (runCellEvent)
import Controller.Notebook.Cell.Viz (insertViz)
import Data.Array (length)
import Data.Date (Date(), toEpochMilliseconds)
import Data.Function (on)
import Data.Maybe (Maybe(), maybe)
import Data.Time (Milliseconds(..), Seconds(..), toSeconds)
import Input.Notebook (Input(..))
import Model.Notebook
import Model.Notebook.Cell
import Model.Notebook.Port (Port(..))
import Number.Format (toFixed)
import Optic.Core ((^.), (%~), (..), is)

import View.Common
import View.Notebook.Cell.Ace (aceEditor)
import View.Notebook.Cell.Explore (exploreEditor, exploreOutput)
import View.Notebook.Cell.Search (searchOutput, searchEditor)
import View.Notebook.Cell.Viz (vizChoices, vizOutput)
import View.Notebook.Cell.Markdown (markdownOutput)
import View.Notebook.Cell.Query (queryOutput)
import View.Notebook.Common

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as E
import qualified Halogen.HTML.Events.Forms as E
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import qualified Halogen.Themes.Bootstrap3 as B
import qualified View.Css as VC

cell :: forall e. State -> Cell -> [HTML e]
cell notebook state =
  [ H.div [ A.classes [B.containerFluid, VC.notebookCell] ]
    [ controls state
    , editor state
    , statusBar notebook.tickDate state
    , output state
    , insertNextCell notebook state
    ]
  ]

controls :: forall e. Cell -> HTML e
controls state =
  row [ H.div [ A.classes [B.btnGroup, B.pullRight, VC.cellControls] ]
        [ H.button [ A.classes [B.btn]
                   , E.onClick $ E.input_ $ UpdateCell (state ^. _cellId) (_hiddenEditor %~ not)
                   ]
          [ H.text (if state ^. _hiddenEditor then "Show" else "Hide") ]
        , H.button [ A.classes [B.btn]
                   , E.onClick $ E.input_ $ TrashCell $ state ^. _cellId
                   ]
          [ H.text "Trash" ]
        ]
      ]

output :: forall e. Cell -> HTML e
output state =
   H.div [ A.classes $ [B.row, VC.cellOutput, B.fade] ++
           if _RunFinished `is` (state ^. _runState) || _Visualize `is` (state ^. _content)
           then [B.in_]
           else [] ]
   $ renderOutput state

statusBar :: forall e. Maybe Date -> Cell -> HTML e
statusBar d state =
  row' (fadeWhen (state ^. _hiddenEditor))
  [ H.div [ A.classes [VC.cellEvalLine, B.clearfix] ]
    [ H.button [ A.classes [ B.btn
                           , B.btnPrimary
                           , if isRunning (state ^. _runState)
                             then VC.stopButton
                             else VC.playButton ]
               , E.onClick \_ -> pure (runCellEvent state)
               ]
      [ if isRunning (state ^. _runState)
        then glyph B.glyphiconStop
        else glyph B.glyphiconPlay ]
    , H.div [ A.classes [ VC.statusText ] ]
      [ H.text $ statusText d (state ^. _runState) ]
    , H.div [ A.classes [ VC.cellFailures ] ]
      (failureText (state ^. _cellId) (state ^. _expandedStatus) (state ^. _failures))

    ]
  ]

insertNextCell :: forall e. State -> Cell -> HTML e
insertNextCell notebook state = row
  [ H.div [ A.classes [ VC.cellEvalLine, B.clearfix ] ]
    [ H.button
      [ A.classes [ B.btn
                  , B.btnPrimary
                  , VC.playButton
                  ]
      , E.onClick $ E.input_ $ UpdateCell (state ^. _cellId) (_addingNextCell %~ not)
      ]
      [ glyph if state ^. _addingNextCell
              then B.glyphiconMenuLeft
              else B.glyphiconMenuRight ]
    , H.ul [ A.classes ([ B.listInline, VC.nextCellList ] <>
                        (fadeWhen $ not $ (state ^. _addingNextCell))) ]
      (nextCellChoices notebook state)
    ]
  ]
nextCellChoices :: forall e. State -> Cell -> [HTML e]
nextCellChoices notebook state =
  [ li "Query cell" newQueryContent  B.glyphiconHdd
  , li "Explore cell" newExploreContent B.glyphiconEyeOpen
  , li "Markdown cell" newMarkdownContent B.glyphiconEdit
  , li "Search cell" newSearchContent B.glyphiconSearch] <>
  case state ^. _output of
    PortResource _ ->
      [ H.li_ [ H.a [ A.href "#"
                  , E.onClick (\_ -> E.preventDefault $> insertViz notebook state)
                  , A.title "Visualization cell"
                  , A.classes [ B.btn ]
                  ]
              [ glyph B.glyphiconPicture ]
              ]
      ]
    _ -> [ ]

  where
  li :: String -> CellContent -> A.ClassName -> HTML e
  li title content c =
    H.li_ [ H.a [ A.href "#"
                , E.onClick \_ -> E.preventDefault $> pure (InsertCell state content)
                , A.title title
                , A.classes [ B.btn ] ] [ glyph c ] ]

failureText :: forall e. CellId -> Boolean -> [FailureMessage] -> [HTML e]
failureText _ _ [ ] = [ ]
failureText cellId expanded fs =
  [ H.div_ [ H.text (show (length fs) <> " error(s) during evaluation. ")
  , H.a [ A.href "#", E.onClick (\_ -> E.preventDefault $> pure (UpdateCell cellId (_expandedStatus %~ not))) ] linkText ]
  ] <>
    if expanded
    then (\f -> H.div_ [ H.text f ]) <$> fs
    else [ ]
  where linkText =
          [ H.text (if expanded
                    then "Hide details"
                    else "Show details") ]

isRunning :: RunState -> Boolean
isRunning (RunningSince _) = true
isRunning _ = false

statusText :: Maybe Date -> RunState -> String
statusText _ RunInitial = ""
statusText d (RunningSince d') = maybe "" (\s -> "Running for " <> s <> "s") $ d >>= flip secondsText d'
statusText _ (RunFinished (Milliseconds ms)) = "Finished: took " <> show ms <> "ms."

secondsText :: Date -> Date -> Maybe String
secondsText a b = toFixed 0 <<< Math.max 0 <<< unSeconds $ on (-) (toSeconds <<< toEpochMilliseconds) a b
  where unSeconds (Seconds n) = n

editor :: forall e. Cell -> HTML e
editor state = case state ^. _content of
  (Explore rec) -> exploreEditor state
  (Search _) -> searchEditor state
  (Visualize _) -> vizChoices state
  _ -> aceEditor state

renderOutput :: forall e. Cell -> [HTML e]
renderOutput cell = case cell ^. _content of
  Explore _ -> exploreOutput cell
  Markdown s -> [markdownOutput s (cell ^. _cellId)]
  Search s -> searchOutput cell
  Visualize s -> vizOutput cell
  Query s -> queryOutput cell
  _ -> []