add 'size' to Data.Map

add 'size' to Data.Map

--
-- Maps as balanced 2-3 trees
--
-- Based on http://www.cs.princeton.edu/~dpw/courses/cos326-12/ass/2-3-trees.pdf
--

module Data.Map
  ( Map(),
    showTree,
    empty,
    isEmpty,
    singleton,
    checkValid,
    insert,
    lookup,
    toList,
    fromList,
    delete,
    member,
    alter,
    update,
    keys,
    values,
    union,
    unions,
    map
  ) where

import qualified Prelude as P

import qualified Data.Array as A
import Data.Maybe
import Data.Tuple
import Data.Foldable (foldl, foldMap, foldr, Foldable)
import Data.Traversable (traverse, Traversable)

data Map k v
  = Leaf
  | Two (Map k v) k v (Map k v)
  | Three (Map k v) k v (Map k v) k v (Map k v)

instance eqMap :: (P.Eq k, P.Eq v) => P.Eq (Map k v) where
  (==) m1 m2 = toList m1 P.== toList m2
  (/=) m1 m2 = P.not (m1 P.== m2)

instance showMap :: (P.Show k, P.Show v) => P.Show (Map k v) where
  show m = "fromList " P.++ P.show (toList m)

instance functorMap :: P.Functor (Map k) where
  (<$>) _ Leaf = Leaf
  (<$>) f (Two left k v right) = Two (f P.<$> left) k (f v) (f P.<$> right)
  (<$>) f (Three left k1 v1 mid k2 v2 right) = Three (f P.<$> left) k1 (f v1) (f P.<$> mid) k2 (f v2) (f P.<$> right)

instance foldableMap :: Foldable (Map k) where
  foldl   f z m = foldl   f z (values m)
  foldr   f z m = foldr   f z (values m)
  foldMap f   m = foldMap f   (values m)

instance traversableMap :: (P.Ord k) => Traversable (Map k) where
  traverse f ms = foldr (\x acc -> union P.<$> x P.<*> acc) (P.pure empty) ((P.(<$>) (uncurry singleton)) P.<$> (traverse f P.<$> toList ms))
  sequence = traverse P.id

showTree :: forall k v. (P.Show k, P.Show v) => Map k v -> String
showTree Leaf = "Leaf"
showTree (Two left k v right) =
  "Two (" P.++ showTree left P.++
  ") (" P.++ P.show k P.++
  ") (" P.++ P.show v P.++
  ") (" P.++ showTree right P.++ ")"
showTree (Three left k1 v1 mid k2 v2 right) =
  "Three (" P.++ showTree left P.++
  ") (" P.++ P.show k1 P.++
  ") (" P.++ P.show v1 P.++
  ") (" P.++ showTree mid P.++
  ") (" P.++ P.show k2 P.++
  ") (" P.++ P.show v2 P.++
  ") (" P.++ showTree right P.++ ")"

empty :: forall k v. Map k v
empty = Leaf

isEmpty :: forall k v. Map k v -> Boolean
isEmpty Leaf = true
isEmpty _ = false

singleton :: forall k v. k -> v -> Map k v
singleton k v = Two Leaf k v Leaf

checkValid :: forall k v. Map k v -> Boolean
checkValid tree = A.length (A.nub (allHeights tree)) P.== 1
  where
  allHeights :: forall k v. Map k v -> [Number]
  allHeights Leaf = [0]
  allHeights (Two left _ _ right) = A.map (\n -> n P.+ 1) (allHeights left P.++ allHeights right)
  allHeights (Three left _ _ mid _ _ right) = A.map (\n -> n P.+ 1) (allHeights left P.++ allHeights mid P.++ allHeights right)

lookup :: forall k v. (P.Ord k) => k -> Map k v -> Maybe v
lookup _ Leaf = Nothing
lookup k (Two _ k1 v _) | k P.== k1 = Just v
lookup k (Two left k1 _ _) | k P.< k1 = lookup k left
lookup k (Two _ _ _ right) = lookup k right
lookup k (Three _ k1 v1 _ _ _ _) | k P.== k1 = Just v1
lookup k (Three _ _ _ _ k2 v2 _) | k P.== k2 = Just v2
lookup k (Three left k1 _ _ _ _ _) | k P.< k1 = lookup k left
lookup k (Three _ k1 _ mid k2 _ _) | k1 P.< k P.&& k P.<= k2 = lookup k mid
lookup k (Three _ _ _ _ _ _ right) = lookup k right

member :: forall k v. (P.Ord k) => k -> Map k v -> Boolean
member k m = isJust (k `lookup` m)

data TreeContext k v
  = TwoLeft k v (Map k v)
  | TwoRight (Map k v) k v
  | ThreeLeft k v (Map k v) k v (Map k v)
  | ThreeMiddle (Map k v) k v k v (Map k v)
  | ThreeRight (Map k v) k v (Map k v) k v

fromZipper :: forall k v. (P.Ord k) => [TreeContext k v] -> Map k v -> Map k v
fromZipper [] tree = tree
fromZipper (TwoLeft k1 v1 right : ctx) left = fromZipper ctx (Two left k1 v1 right)
fromZipper (TwoRight left k1 v1 : ctx) right = fromZipper ctx (Two left k1 v1 right)
fromZipper (ThreeLeft k1 v1 mid k2 v2 right : ctx) left = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
fromZipper (ThreeMiddle left k1 v1 k2 v2 right : ctx) mid = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
fromZipper (ThreeRight left k1 v1 mid k2 v2 : ctx) right = fromZipper ctx (Three left k1 v1 mid k2 v2 right)

data KickUp k v = KickUp (Map k v) k v (Map k v)

insert :: forall k v. (P.Ord k) => k -> v -> Map k v -> Map k v
insert = down []
  where
  down :: forall k v. (P.Ord k) => [TreeContext k v] -> k -> v -> Map k v -> Map k v
  down ctx k v Leaf = up ctx (KickUp Leaf k v Leaf)
  down ctx k v (Two left k1 _ right) | k P.== k1 = fromZipper ctx (Two left k v right)
  down ctx k v (Two left k1 v1 right) | k P.< k1 = down (TwoLeft k1 v1 right P.: ctx) k v left
  down ctx k v (Two left k1 v1 right) = down (TwoRight left k1 v1 P.: ctx) k v right
  down ctx k v (Three left k1 _ mid k2 v2 right) | k P.== k1 = fromZipper ctx (Three left k v mid k2 v2 right)
  down ctx k v (Three left k1 v1 mid k2 _ right) | k P.== k2 = fromZipper ctx (Three left k1 v1 mid k v right)
  down ctx k v (Three left k1 v1 mid k2 v2 right) | k P.< k1 = down (ThreeLeft k1 v1 mid k2 v2 right P.: ctx) k v left
  down ctx k v (Three left k1 v1 mid k2 v2 right) | k1 P.< k P.&& k P.<= k2 = down (ThreeMiddle left k1 v1 k2 v2 right P.: ctx) k v mid
  down ctx k v (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 P.: ctx) k v right

  up :: forall k v. (P.Ord k) => [TreeContext k v] -> KickUp k v -> Map k v
  up [] (KickUp left k v right) = Two left k v right
  up (TwoLeft k1 v1 right : ctx) (KickUp left k v mid) = fromZipper ctx (Three left k v mid k1 v1 right)
  up (TwoRight left k1 v1 : ctx) (KickUp mid k v right) = fromZipper ctx (Three left k1 v1 mid k v right)
  up (ThreeLeft k1 v1 c k2 v2 d : ctx) (KickUp a k v b) = up ctx (KickUp (Two a k v b) k1 v1 (Two c k2 v2 d))
  up (ThreeMiddle a k1 v1 k2 v2 d : ctx) (KickUp b k v c) = up ctx (KickUp (Two a k1 v1 b) k v (Two c k2 v2 d))
  up (ThreeRight a k1 v1 b k2 v2 : ctx) (KickUp c k v d) = up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k v d))

delete :: forall k v. (P.Ord k) => k -> Map k v -> Map k v
delete = down []
  where
  down :: forall k v. (P.Ord k) => [TreeContext k v] -> k -> Map k v -> Map k v
  down ctx _ Leaf = fromZipper ctx Leaf
  down ctx k (Two Leaf k1 _ Leaf)
    | k P.== k1 = up ctx Leaf
  down ctx k (Two left k1 v1 right)
    | k P.== k1   = let max = maxNode left
                    in removeMaxNode (TwoLeft max.key max.value right P.: ctx) left
    | k P.< k1    = down (TwoLeft k1 v1 right P.: ctx) k left
    | P.otherwise = down (TwoRight left k1 v1 P.: ctx) k right
  down ctx k (Three Leaf k1 v1 Leaf k2 v2 Leaf)
    | k P.== k1 = fromZipper ctx (Two Leaf k2 v2 Leaf)
    | k P.== k2 = fromZipper ctx (Two Leaf k1 v1 Leaf)
  down ctx k (Three left k1 v1 mid k2 v2 right)
    | k P.== k1 = let max = maxNode left
                  in removeMaxNode (ThreeLeft max.key max.value mid k2 v2 right P.: ctx) left
    | k P.== k2 = let max = maxNode mid
                  in removeMaxNode (ThreeMiddle left k1 v1 max.key max.value right P.: ctx) mid
    | k P.< k1               = down (ThreeLeft k1 v1 mid k2 v2 right P.: ctx) k left
    | k1 P.< k P.&& k P.< k2 = down (ThreeMiddle left k1 v1 k2 v2 right P.: ctx) k mid
    | P.otherwise            = down (ThreeRight left k1 v1 mid k2 v2 P.: ctx) k right

  up :: forall k v. (P.Ord k) => [TreeContext k v] -> Map k v -> Map k v
  up [] tree = tree
  up (TwoLeft k1 v1 Leaf : ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
  up (TwoRight Leaf k1 v1 : ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
  up (TwoLeft k1 v1 (Two m k2 v2 r) : ctx) l = up ctx (Three l k1 v1 m k2 v2 r)
  up (TwoRight (Two l k1 v1 m) k2 v2 : ctx) r = up ctx (Three l k1 v1 m k2 v2 r)
  up (TwoLeft k1 v1 (Three b k2 v2 c k3 v3 d) : ctx) a = fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
  up (TwoRight (Three a k1 v1 b k2 v2 c) k3 v3 : ctx) d = fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
  up (ThreeLeft k1 v1 Leaf k2 v2 Leaf : ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (ThreeMiddle Leaf k1 v1 k2 v2 Leaf : ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (ThreeRight Leaf k1 v1 Leaf k2 v2 : ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (ThreeLeft k1 v1 (Two b k2 v2 c) k3 v3 d : ctx) a = fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
  up (ThreeMiddle (Two a k1 v1 b) k2 v2 k3 v3 d : ctx) c = fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
  up (ThreeMiddle a k1 v1 k2 v2 (Two c k3 v3 d) : ctx) b = fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
  up (ThreeRight a k1 v1 (Two b k2 v2 c) k3 v3 : ctx) d = fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
  up (ThreeLeft k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 e : ctx) a = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
  up (ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e : ctx) d = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
  up (ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e) : ctx) b = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
  up (ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 : ctx) e = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))

  maxNode :: forall k v. (P.Ord k) => Map k v -> { key :: k, value :: v }
  maxNode (Two _ k v Leaf) = { key: k, value: v }
  maxNode (Two _ _ _ right) = maxNode right
  maxNode (Three _ _ _ _ k v Leaf) = { key: k, value: v }
  maxNode (Three _ _ _ _ _ _ right) = maxNode right

  removeMaxNode :: forall k v. (P.Ord k) => [TreeContext k v] -> Map k v -> Map k v
  removeMaxNode ctx (Two Leaf _ _ Leaf) = up ctx Leaf
  removeMaxNode ctx (Two left k v right) = removeMaxNode (TwoRight left k v P.: ctx) right
  removeMaxNode ctx (Three Leaf k1 v1 Leaf _ _ Leaf) = up (TwoRight Leaf k1 v1 P.: ctx) Leaf
  removeMaxNode ctx (Three left k1 v1 mid k2 v2 right) = removeMaxNode (ThreeRight left k1 v1 mid k2 v2 P.: ctx) right

alter :: forall k v. (P.Ord k) => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

update :: forall k v. (P.Ord k) => (v -> Maybe v) -> k -> Map k v -> Map k v
update f k m = alter (maybe Nothing f) k m

toList :: forall k v. Map k v -> [Tuple k v]
toList Leaf = []
toList (Two left k v right) = toList left P.++ [Tuple k v] P.++ toList right
toList (Three left k1 v1 mid k2 v2 right) = toList left P.++ [Tuple k1 v1] P.++ toList mid P.++ [Tuple k2 v2] P.++ toList right

fromList :: forall k v. (P.Ord k) => [Tuple k v] -> Map k v
fromList = foldl (\m (Tuple k v) -> insert k v m) empty

keys :: forall k v. Map k v -> [k]
keys Leaf = []
keys (Two left k _ right) = keys left P.++ [k] P.++ keys right
keys (Three left k1 _ mid k2 _ right) = keys left P.++ [k1] P.++ keys mid P.++ [k2] P.++ keys right

values :: forall k v. Map k v -> [v]
values Leaf = []
values (Two left _ v right) = values left P.++ [v] P.++ values right
values (Three left _ v1 mid _ v2 right) = values left P.++ [v1] P.++ values mid P.++ [v2] P.++ values right

union :: forall k v. (P.Ord k) => Map k v -> Map k v -> Map k v
union m1 m2 = foldl (\m (Tuple k v) -> insert k v m) m2 (toList m1)

unions :: forall k v. (P.Ord k) => [Map k v] -> Map k v
unions = foldl union empty

map :: forall k a b. (a -> b) -> Map k a -> Map k b
map = P.(<$>)

size :: forall k v. Map k v -> Number
size = A.length P.<<< values


Have modify return the updated value

Have modify return the updated value

-- | This module defines an effect and actions for working with
-- | global mutable variables.
-- |
-- | _Note_: `Control.Monad.ST` provides a _safe_ alternative
-- | to global mutable variables when mutation is restricted to a
-- | local scope.
module Effect.Ref where

import Prelude

import Effect (Effect)

-- | A value of type `Ref a` represents a mutable reference
-- | which holds a value of type `a`.
foreign import data Ref :: Type -> Type

-- | Create a new mutable reference containing the specified value.
foreign import new :: forall s. s -> Effect (Ref s)

-- | Read the current value of a mutable reference
foreign import read :: forall s. Ref s -> Effect s

-- | Update the value of a mutable reference by applying a function
-- | to the current value.
foreign import modify' :: forall s b. (s -> { state :: s, value :: b }) -> Ref s -> Effect b

-- | Update the value of a mutable reference by applying a function
-- | to the current value. The updated value is returned.
modify :: forall s. (s -> s) -> Ref s -> Effect s
modify f = modify' \s -> let s' = f s in { state: s', value: s' }

-- | Update the value of a mutable reference to the specified value.
foreign import write :: forall s. s -> Ref s -> Effect Unit

-- | This module defines an effect and actions for working with
-- | global mutable variables.
-- |
-- | _Note_: `Control.Monad.ST` provides a _safe_ alternative
-- | to global mutable variables when mutation is restricted to a
-- | local scope.
module Effect.Ref where

import Prelude

import Effect (Effect)

-- | A value of type `Ref a` represents a mutable reference
-- | which holds a value of type `a`.
foreign import data Ref :: Type -> Type

-- | Create a new mutable reference containing the specified value.
foreign import new :: forall s. s -> Effect (Ref s)

-- | Read the current value of a mutable reference
foreign import read :: forall s. Ref s -> Effect s

-- | Update the value of a mutable reference by applying a function
-- | to the current value.
foreign import modify' :: forall s b. (s -> { state :: s, value :: b }) -> Ref s -> Effect b

-- | Update the value of a mutable reference by applying a function
-- | to the current value.
modify :: forall s. (s -> s) -> Ref s -> Effect Unit
modify f = modify' (\s -> { state: f s, value: unit })

-- | Update the value of a mutable reference to the specified value.
foreign import write :: forall s. s -> Ref s -> Effect Unit


WIP Double check writing ADTs with generics

as ADTs do not get written with toForeign


Create 'tmp' if it does not exist

Create 'tmp' if it does not exist

module Benchotron.UI.Console where

import Data.Tuple
import Data.Maybe
import Data.Foldable (traverse_)
import Data.Profunctor.Strong (second, (&&&))
import qualified Data.Array as A
import Data.String (joinWith)
import Data.Date (now, Now())
import Data.Date.Locale (toLocaleTimeString, Locale())
import Control.Monad (when)
import Control.Monad.Eff
import Node.FS.Sync (writeTextFile, mkdir', stat, exists)
import Node.FS.Stats (isDirectory)
import Node.Encoding (Encoding(..))
import Global (readInt, isNaN)

import Benchotron.Core
import Benchotron.StdIO
import Benchotron.Utils

data Answer = All | One Number

parseAnswer :: String -> Maybe Answer
parseAnswer "*" = Just All
parseAnswer x = let y = readInt 10 x
                in  if isNaN y then Nothing else Just (One y)

runSuite :: forall e. Array (Benchmark e) -> BenchM e Unit
runSuite bs = do
  case bs of
    []  -> stdoutWrite "Empty suite; nothing to do.\n"
    [b] -> go b
    _   -> do
      stdoutWrite "Choose a benchmark to run:\n\n"
      stdoutWrite (joinWith "\n" (showOptions bs))
      stdoutWrite "\n\n"
      questionLoop

  where
  go b = do
    stdoutWrite "\n"
    exists <- doesDirectoryExist "tmp"
    when (not exists) (mkdir' "tmp" 511) -- 511 is 777 in octal
    benchmarkToFile b ("tmp/" <> slug b <> ".json")

  doesDirectoryExist dir = do
    ex <- exists dir
    if ex
       then isDirectory <$> stat dir
       else return false

  slug = unpackBenchmark _.slug

  questionLoop =
    question "Enter a number, or enter '*' to run all benchmarks: " \answer ->
      case parseAnswer answer of
        Nothing -> stdoutWrite "Unrecognised input.\n" >> questionLoop
        Just All -> traverse_ go bs
        Just (One i) ->
          case bs A.!! (i - 1) of
            Just b  -> go b
            Nothing -> stdoutWrite "No such benchmark.\n" >> questionLoop

showOptions :: forall e. Array (Benchmark e) -> Array String
showOptions = A.map (showOption <<< second getSlugAndTitle) <<< withIndices
  where
  getSlugAndTitle =
    unpackBenchmark _.slug &&& unpackBenchmark _.title
  showOption (Tuple index (Tuple slug title)) =
    "  " <> show index <> ") " <> slug <> " - " <> title
  withIndices arr =
    zip (A.range 1 (A.length arr)) arr

runBenchmarkConsole :: forall e. Benchmark e -> BenchM e BenchmarkResult
runBenchmarkConsole = unpackBenchmark runBenchmarkFConsole

runBenchmarkFConsole :: forall e a. BenchmarkF e a -> BenchM e BenchmarkResult
runBenchmarkFConsole benchmark = do
  stderrWrite $ "### Benchmark: " <> benchmark.title <> " ###\n"
  noteTime \t -> "Started at: " <> t <> "\n"
  r <- runBenchmarkF benchmark progress
  stderrWrite "\n"
  noteTime \t -> "Finished at: " <> t <> "\n"
  return r
  where
  noteTime f = now >>= toLocaleTimeString >>= (stderrWrite <<< f)
  countSizes = A.length benchmark.sizes
  clearLine = "\r\ESC[K"
  progress idx size =
    stderrWrite $ joinWith ""
      [ clearLine
      , "Running... n="
      , show size
      , " ("
      , show idx
      , "/"
      , show countSizes
      , ")"
      ]

-- | Run a benchmark and print the results to a file. This will only work on
-- | node.js.
benchmarkToFile :: forall e. Benchmark e -> String -> Eff (BenchEffects e) Unit
benchmarkToFile = unpackBenchmark benchmarkFToFile

benchmarkFToFile :: forall e a. BenchmarkF e a -> String -> Eff (BenchEffects e) Unit
benchmarkFToFile bench path = do
  results <- runBenchmarkFConsole bench
  writeTextFile UTF8 path $ stringifyResult results
  stderrWrite $ "Results written to " <> path <> "\n"

-- | Run a benchmark and print the results to standard output. This will only
-- | work on node.js.
benchmarkToStdout :: forall e. Benchmark e -> Eff (BenchEffects e) Unit
benchmarkToStdout = unpackBenchmark benchmarkFToStdout

benchmarkFToStdout :: forall e a. BenchmarkF e a -> Eff (BenchEffects e) Unit
benchmarkFToStdout bench = do
  results <- runBenchmarkFConsole bench
  stdoutWrite $ stringifyResult results

stringifyResult :: BenchmarkResult -> String
stringifyResult = jsonStringify

module Benchotron.UI.Console where

import Data.Tuple
import Data.Maybe
import Data.Foldable (traverse_)
import Data.Profunctor.Strong (second, (&&&))
import qualified Data.Array as A
import Data.String (joinWith)
import Data.Date (now, Now())
import Data.Date.Locale (toLocaleTimeString, Locale())
import Control.Monad.Eff
import Node.FS.Sync (writeTextFile)
import Node.Encoding (Encoding(..))
import Global (readInt, isNaN)

import Benchotron.Core
import Benchotron.StdIO
import Benchotron.Utils

data Answer = All | One Number

parseAnswer :: String -> Maybe Answer
parseAnswer "*" = Just All
parseAnswer x = let y = readInt 10 x
                in  if isNaN y then Nothing else Just (One y)

runSuite :: forall e. Array (Benchmark e) -> BenchM e Unit
runSuite bs = do
  case bs of
    []  -> stdoutWrite "Empty suite; nothing to do.\n"
    [b] -> go b
    _   -> do
      stdoutWrite "Choose a benchmark to run:\n\n"
      stdoutWrite (joinWith "\n" (showOptions bs))
      stdoutWrite "\n\n"
      questionLoop

  where
  go b = stdoutWrite "\n" >> benchmarkToFile b ("tmp/" <> slug b <> ".json")
  slug = unpackBenchmark _.slug

  questionLoop =
    question "Enter a number, or enter '*' to run all benchmarks: " \answer ->
      case parseAnswer answer of
        Nothing -> stdoutWrite "Unrecognised input.\n" >> questionLoop
        Just All -> traverse_ go bs
        Just (One i) ->
          case bs A.!! (i - 1) of
            Just b  -> go b
            Nothing -> stdoutWrite "No such benchmark.\n" >> questionLoop

showOptions :: forall e. Array (Benchmark e) -> Array String
showOptions = A.map (showOption <<< second getSlugAndTitle) <<< withIndices
  where
  getSlugAndTitle =
    unpackBenchmark _.slug &&& unpackBenchmark _.title
  showOption (Tuple index (Tuple slug title)) =
    "  " <> show index <> ") " <> slug <> " - " <> title
  withIndices arr =
    zip (A.range 1 (A.length arr)) arr

runBenchmarkConsole :: forall e. Benchmark e -> BenchM e BenchmarkResult
runBenchmarkConsole = unpackBenchmark runBenchmarkFConsole

runBenchmarkFConsole :: forall e a. BenchmarkF e a -> BenchM e BenchmarkResult
runBenchmarkFConsole benchmark = do
  stderrWrite $ "### Benchmark: " <> benchmark.title <> " ###\n"
  noteTime \t -> "Started at: " <> t <> "\n"
  r <- runBenchmarkF benchmark progress
  stderrWrite "\n"
  noteTime \t -> "Finished at: " <> t <> "\n"
  return r
  where
  noteTime f = now >>= toLocaleTimeString >>= (stderrWrite <<< f)
  countSizes = A.length benchmark.sizes
  clearLine = "\r\ESC[K"
  progress idx size =
    stderrWrite $ joinWith ""
      [ clearLine
      , "Running... n="
      , show size
      , " ("
      , show idx
      , "/"
      , show countSizes
      , ")"
      ]

-- | Run a benchmark and print the results to a file. This will only work on
-- | node.js.
benchmarkToFile :: forall e. Benchmark e -> String -> Eff (BenchEffects e) Unit
benchmarkToFile = unpackBenchmark benchmarkFToFile

benchmarkFToFile :: forall e a. BenchmarkF e a -> String -> Eff (BenchEffects e) Unit
benchmarkFToFile bench path = do
  results <- runBenchmarkFConsole bench
  writeTextFile UTF8 path $ stringifyResult results
  stderrWrite $ "Results written to " <> path <> "\n"

-- | Run a benchmark and print the results to standard output. This will only
-- | work on node.js.
benchmarkToStdout :: forall e. Benchmark e -> Eff (BenchEffects e) Unit
benchmarkToStdout = unpackBenchmark benchmarkFToStdout

benchmarkFToStdout :: forall e a. BenchmarkF e a -> Eff (BenchEffects e) Unit
benchmarkFToStdout bench = do
  results <- runBenchmarkFConsole bench
  stdoutWrite $ stringifyResult results

stringifyResult :: BenchmarkResult -> String
stringifyResult = jsonStringify


Add main variants

Add main variants

Signed-off-by: Joern Bernhardt <7b85a41a628204b76aba4326273a3ccc74bd009a@campudus.com>

module Main where

import Prelude (Unit, bind, map, (<>), (<$>), (>>=))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Array (head, tail)
import Data.Maybe (Maybe(..))
import Node.Process (PROCESS, argv)

greeting :: String -> String
greeting who = "Hello " <> who <> "!"

getArgsBind :: Array String -> Maybe (String)
getArgsBind args = tail args >>= tail >>= head

getArgsDo :: Array String -> Maybe (String)
getArgsDo args = do
  a <- tail args
  b <- tail a
  head b

get :: Maybe String -> String
get (Just str) = str
get Nothing    = ""

mainDo :: forall eff. Eff (console :: CONSOLE, process :: PROCESS | eff) Unit
mainDo = do
  arr <- argv
  log (greeting (get (getArgsBind arr)))

mainMapBind2 :: forall eff. Eff (console :: CONSOLE, process :: PROCESS | eff) Unit
mainMapBind2 = bind (map greeting (map get (map getArgsBind argv))) log

--| Same as above, >>= is bind, <$> is map.
mainMapBind :: forall eff. Eff (console :: CONSOLE, process :: PROCESS | eff) Unit
mainMapBind = greeting <$> get <$> getArgsBind <$> argv >>= log

main :: forall eff. Eff (console :: CONSOLE, process :: PROCESS | eff) Unit
main = mainMapBind

module Main where

import Prelude (Unit, bind, map, (<>), (>>=))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Array (head, tail)
import Data.Maybe (Maybe(..))
import Node.Process (PROCESS, argv)

greeting :: String -> String
greeting who = "Hello " <> who <> "!"

getArgsBind :: Array String -> Maybe (String)
getArgsBind args = tail args >>= tail >>= head

getArgsDo :: Array String -> Maybe (String)
getArgsDo args = do
  a <- tail args
  b <- tail a
  head b

get :: Maybe String -> String
get (Just str) = str
get Nothing    = ""

-- main :: forall eff. Eff (console :: CONSOLE, process :: PROCESS | eff) Unit
-- main = do
--   arr <- argv
--   log (greeting (get (getArgsBind arr)))

main :: forall eff. Eff (console :: CONSOLE, process :: PROCESS | eff) Unit
main = bind (map greeting (map get (map getArgsBind argv))) log


Add a void machine

Add a void machine

module Halogen.VDom.Machine
  ( Machine
  , Step(..)
  , extract
  , step
  , halt
  , fold
  , loop
  , stepper
  , constantly
  , never
  ) where

import Prelude
import Data.Tuple (Tuple(..))

type Machine m a b = a → m (Step m a b)

data Step m a b = Step b (Machine m a b) (m Unit)

instance functorStep ∷ Functor m ⇒ Functor (Step m a) where
  map f (Step x m d) = Step (f x) (m >>> map (map f)) d

extract ∷ ∀ m a b. Step m a b → b
extract (Step x _ _) = x

step ∷ ∀ m a b. Step m a b → a → m (Step m a b)
step (Step _ m _) = m

halt ∷ ∀ m a b. Step m a b → m Unit
halt (Step _ _ h) = h

fold ∷ ∀ m a b s. Applicative m ⇒ (s → a → m (Tuple s b)) → (s → m Unit) → s → Machine m a b
fold f g s a = next <$> f s a
  where
  next (Tuple s' b) = Step b (fold f g s') (g s')

loop ∷ ∀ m a s. Applicative m ⇒ (s → a → m s) → (s → m Unit) → s → Machine m a Unit
loop f g s a = next <$> f s a
  where
  next s' = Step unit (loop f g s') (g s')

stepper ∷ ∀ m a b. Functor m ⇒ (a → m b) → m Unit → Machine m a b
stepper f h a = next <$> f a
  where
  next b = Step b (stepper f h) h

constantly ∷ ∀ m a b. Applicative m ⇒ b → Machine m a b
constantly x _ = pure (Step x (constantly x) (pure unit))

never ∷ ∀ m b. Applicative m ⇒ Machine m Void b
never a = pure (Step (absurd a) never (pure unit))

module Halogen.VDom.Machine
  ( Machine
  , Step(..)
  , extract
  , step
  , halt
  , fold
  , loop
  , stepper
  , constantly
  ) where

import Prelude
import Data.Tuple (Tuple(..))

type Machine m a b = a → m (Step m a b)

data Step m a b = Step b (Machine m a b) (m Unit)

instance functorStep ∷ Functor m ⇒ Functor (Step m a) where
  map f (Step x m d) = Step (f x) (m >>> map (map f)) d

extract ∷ ∀ m a b. Step m a b → b
extract (Step x _ _) = x

step ∷ ∀ m a b. Step m a b → a → m (Step m a b)
step (Step _ m _) = m

halt ∷ ∀ m a b. Step m a b → m Unit
halt (Step _ _ h) = h

fold ∷ ∀ m a b s. Applicative m ⇒ (s → a → m (Tuple s b)) → (s → m Unit) → s → Machine m a b
fold f g s a = next <$> f s a
  where
  next (Tuple s' b) = Step b (fold f g s') (g s')

loop ∷ ∀ m a s. Applicative m ⇒ (s → a → m s) → (s → m Unit) → s → Machine m a Unit
loop f g s a = next <$> f s a
  where
  next s' = Step unit (loop f g s') (g s')

stepper ∷ ∀ m a b. Functor m ⇒ (a → m b) → m Unit → Machine m a b
stepper f h a = next <$> f a
  where
  next b = Step b (stepper f h) h

constantly ∷ ∀ m a b. Applicative m ⇒ b → Machine m a b
constantly x _ = pure (Step x (constantly x) (pure unit))


Fix `Apply` instance

Fix `Apply` instance

module Node.Express.Handler
    ( HandlerM(..)
    , Handler()
    , runHandlerM, next, nextThrow
    ) where

import Prelude

import Effect.Aff (Aff, runAff_)
import Effect.Aff.Class (class MonadAff)
import Effect (Effect)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Exception (Error)
import Data.Either (either)
import Data.Function.Uncurried (Fn2, runFn2)
import Node.Express.Types (Response, Request)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError)

-- | Monad responsible for handling single request.
newtype HandlerM a = HandlerM (Request -> Response -> Effect Unit -> Aff a)

type Handler = HandlerM Unit

instance functorHandlerM :: Functor HandlerM where
    map f (HandlerM h) = HandlerM \req resp nxt ->
        (h req resp nxt >>= \r -> pure $ f r)

instance applyHandlerM :: Apply HandlerM where
    apply (HandlerM f) (HandlerM h) = HandlerM \req resp nxt -> do
        trans <- f req resp nxt
        res   <- h req resp nxt
        pure $ trans res

instance applicativeHandlerM :: Applicative HandlerM where
    pure x = HandlerM \_ _ _ -> pure x

instance bindHandlerM :: Bind HandlerM where
    bind (HandlerM h) f = HandlerM \req resp nxt -> do
        (HandlerM g) <- liftM1 f $ h req resp nxt
        g req resp nxt

instance monadHandlerM :: Monad HandlerM

instance monadEffHandlerM :: MonadEffect HandlerM where
    liftEffect act = HandlerM \_ _ _ -> liftEffect act

instance monadAffHandlerM :: MonadAff HandlerM where
    liftAff act = HandlerM \_ _ _ -> act

runHandlerM :: Handler -> Request -> Response -> Effect Unit -> Effect Unit
runHandlerM (HandlerM h) req res nxt = void $ runAff_ (either (runFn2 _nextWithError nxt) pure) (h req res nxt)

-- | Call next handler/middleware in a chain.
next :: Handler
next = HandlerM \_ _ nxt -> liftEffect nxt

-- | Call next handler/middleware and pass error to it.
nextThrow :: forall a. Error -> HandlerM a
nextThrow err = HandlerM \_ _ nxt ->
    liftEffect $ runFn2 _nextWithError nxt err

instance monadThrowHandlerM :: MonadThrow Error HandlerM where
    throwError err = HandlerM \_ _ nxt -> throwError err

instance monadErrorHandlerM ∷ MonadError Error HandlerM where
    catchError (HandlerM m) h = HandlerM $ \req res nxt ->
        catchError (m req res nxt) $ \e -> case h e of HandlerM m0 -> m0 req res nxt

foreign import _nextWithError :: forall a. Fn2 (Effect Unit) Error (Effect a)

module Node.Express.Handler
    ( HandlerM(..)
    , Handler()
    , runHandlerM, next, nextThrow
    ) where

import Prelude

import Effect.Aff (Aff, runAff_)
import Effect.Aff.Class (class MonadAff)
import Effect (Effect)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Exception (Error)
import Data.Either (either)
import Data.Function.Uncurried (Fn2, runFn2)
import Node.Express.Types (Response, Request)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError)

-- | Monad responsible for handling single request.
newtype HandlerM a = HandlerM (Request -> Response -> Effect Unit -> Aff a)

type Handler = HandlerM Unit

instance functorHandlerM :: Functor HandlerM where
    map f (HandlerM h) = HandlerM \req resp nxt ->
        (h req resp nxt >>= \r -> pure $ f r)

instance applyHandlerM :: Apply HandlerM where
    apply (HandlerM f) (HandlerM h) = HandlerM \req resp nxt -> do
        res   <- h req resp nxt
        trans <- f req resp nxt
        pure $ trans res

instance applicativeHandlerM :: Applicative HandlerM where
    pure x = HandlerM \_ _ _ -> pure x

instance bindHandlerM :: Bind HandlerM where
    bind (HandlerM h) f = HandlerM \req resp nxt -> do
        (HandlerM g) <- liftM1 f $ h req resp nxt
        g req resp nxt

instance monadHandlerM :: Monad HandlerM

instance monadEffHandlerM :: MonadEffect HandlerM where
    liftEffect act = HandlerM \_ _ _ -> liftEffect act

instance monadAffHandlerM :: MonadAff HandlerM where
    liftAff act = HandlerM \_ _ _ -> act

runHandlerM :: Handler -> Request -> Response -> Effect Unit -> Effect Unit
runHandlerM (HandlerM h) req res nxt = void $ runAff_ (either (runFn2 _nextWithError nxt) pure) (h req res nxt)

-- | Call next handler/middleware in a chain.
next :: Handler
next = HandlerM \_ _ nxt -> liftEffect nxt

-- | Call next handler/middleware and pass error to it.
nextThrow :: forall a. Error -> HandlerM a
nextThrow err = HandlerM \_ _ nxt ->
    liftEffect $ runFn2 _nextWithError nxt err

instance monadThrowHandlerM :: MonadThrow Error HandlerM where
    throwError err = HandlerM \_ _ nxt -> throwError err

instance monadErrorHandlerM ∷ MonadError Error HandlerM where
    catchError (HandlerM m) h = HandlerM $ \req res nxt ->
        catchError (m req res nxt) $ \e -> case h e of HandlerM m0 -> m0 req res nxt

foreign import _nextWithError :: forall a. Fn2 (Effect Unit) Error (Effect a)


add a second script using same transition

module Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import D3.Base (D3)
import D3.Transition (D3Transition(TransitionName), TimeSpec(..), tStyle)
import Data.Int (toNumber)
import Data.List (List)
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty)
import Prelude (Unit, bind, discard, show, ($), (*), (/))
import TaglessD3.API (D3Data(ArrayDI, ArrayD), append, applyTransition, attrs, d3Select, dataBind, enter, makeTransition, selectAll, tAttrs, tDelay, tDuration)
import TaglessD3.AttrNew (Attr(..), AttrSetter, CssUnit(..), attrFunction, attrValue, attributes)
import TaglessD3.Base (D3ElementType(..))
import TaglessD3.D3Impl (runD3Monad, D3Script)
import TaglessD3.StringImpl (runStructure) as S

circles_script :: D3Script
circles_script = do
    d3Select "#chart"
    append SvgGroup
    selectAll "circle" -- this select, the databind, the enter and the append could surely all be one function?
    dataBind myData'
    enter
    append SvgCircle
    attrs circleAttrs
    applyTransition $ myTransition
    tDelay $ DelayFn (\d i -> i * 100.0)
    tDuration $ DelayFn (\d i -> i * 1000.0)
    tAttrs circleTransitionAttrs

rects_script :: D3Script
rects_script = do
    d3Select "#chart"
    append SvgGroup
    selectAll "rect" -- this select, the databind, the enter and the append could surely all be one function?
    dataBind myData'
    enter
    append SvgRect
    attrs rectAttrs
    applyTransition $ myTransition
    tDelay $ DelayFn (\d i -> i * 100.0)
    tDuration $ DelayFn (\d i -> i * 1000.0)
    tAttrs rectTransitionAttrs

-- idempotency of d3.transtion() this next relies on D3 to return us the same
-- transition as "name" (ie if named transition exists) allowing us to call this
-- function multiple times from different scripts that are under interpretation

-- now, if we want to add (common) attributes to this transition definition
-- we'll have to check if it already exists and not apply those attributes for
-- existing transitions
myTransition :: D3Script
myTransition = do
    makeTransition $ TransitionName "foo"
    tDelay $ MilliSec 2000.0

circleTransitionAttrs :: List Attr
circleTransitionAttrs = attributes $ [ Style "fill" $ attrValue "red" NoUnit
                                  , CY $ attrFunction (\d _ _ _ -> d * 80) Px
                                  ]

rectTransitionAttrs :: List Attr
rectTransitionAttrs = attributes $ [ Style "fill" $ attrValue "blue" NoUnit
                                  , X $ attrFunction (\d _ _ _ -> d * 80) Px
                                  ]

myData :: forall t8. D3Data Int t8
myData       = ArrayD [1,2,3,4,5]

myData' :: D3Data Int Number
myData'      = ArrayDI [1,2,3,4,5,6,7,8] (\i -> (toNumber i) / 2.0) -- array data with lambda index fn

rectAttrs :: List Attr
rectAttrs = attributes $ [ Y $ attrValue 100 Px
                         , X $ attrFunction (\d _ _ _ -> d * 30) Px
                         , Width  $ attrFunction calcRadius Px
                         , Height  $ attrFunction calcRadius Px]

circleAttrs :: List Attr
circleAttrs = attributes $ [ CX $ attrValue 200 Px
                        , CY $ attrFunction (\d _ _ _ -> d * 3) Px
                        , R  $ attrFunction calcRadius Px
                        , Style "width" $ attrValue 48 Percent
                        , Style "height" $ attrFunction lp Px ] -- shows callback but also demos lack of typecheck on selection...

calcRadius :: AttrSetter Int Int
calcRadius d i n e = d * 5

-- an example of a typed callback function
type ExData = { name :: String, age :: Int }

-- lp :: ExData -> Number -> Array D3Element -> D3Element -> Int
lp :: AttrSetter ExData Int
lp { name, age } _ _ _ =
    case name, age of -- silly little function just shows one way you might use an index function (NB in many cases D3 has better solutions for grouping)
    "awn", _ -> 20
    _, 0     -> 50
    _, _     -> 100

main :: forall e. Eff (console :: CONSOLE, d3 :: D3 | e) Unit
main = do
    _ <- runD3Monad circles_script Nothing
    _ <- runD3Monad rects_script Nothing
    log "\n\n\n====== cool beans =======\n\n\n"
    let ss = show $ S.runStructure circles_script mempty
    log ss

module Main where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import D3.Base (D3)
import D3.Transition (D3Transition(TransitionName), TimeSpec(..), tStyle)
import Data.Int (toNumber)
import Data.List (List)
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty)
import Prelude (Unit, bind, discard, show, ($), (*), (/))
import TaglessD3.API (D3Data(ArrayDI, ArrayD), append, applyTransition, attrs, d3Select, dataBind, enter, makeTransition, selectAll, tAttrs, tDelay, tDuration)
import TaglessD3.AttrNew (Attr(..), AttrSetter, CssUnit(..), attrFunction, attrValue, attributes)
import TaglessD3.Base (D3ElementType(SvgCircle, SvgGroup))
import TaglessD3.D3Impl (runD3Monad, D3Script)
import TaglessD3.StringImpl (runStructure) as S

circles_script :: D3Script
circles_script = do
    d3Select "#chart"
    append SvgGroup
    selectAll "circle" -- this select, the databind, the enter and the append could surely all be one function?
    dataBind myData'
    enter
    append SvgCircle
    attrs attrList
    applyTransition $ myTransition
    tDelay $ DelayFn (\d i -> i * 100.0)
    tDuration $ DelayFn (\d i -> i * 1000.0)
    tAttrs transitionAttrList

-- idempotency of d3.transtion() this next relies on D3 to return us the same
-- transition as "name" (ie if named transition exists) allowing us to call this
-- function multiple times from different scripts that are under interpretation

-- now, if we want to add (common) attributes to this transition definition
-- we'll have to check if it already exists and not apply those attributes for
-- existing transitions
myTransition :: D3Script
myTransition = do
    makeTransition $ TransitionName "foo"
    tDelay $ MilliSec 2000.0

transitionAttrList :: List Attr
transitionAttrList = attributes $ [ Style "fill" $ attrValue "red" NoUnit
                                  , CY $ attrFunction (\d _ _ _ -> d * 80) Px
                                  ]

myData :: forall t8. D3Data Int t8
myData       = ArrayD [1,2,3,4,5]

myData' :: D3Data Int Number
myData'      = ArrayDI [1,2,3,4,5,6,7,8] (\i -> (toNumber i) / 2.0) -- array data with lambda index fn

attrList :: List Attr
attrList = attributes $ [ CX $ attrValue 200 Px
                        , CY $ attrFunction (\d _ _ _ -> d * 3) Px
                        , R  $ attrFunction calcRadius Px
                        , Style "width" $ attrValue 48 Percent
                        , Style "height" $ attrFunction lp Px ] -- shows callback but also demos lack of typecheck on selection...

calcRadius :: AttrSetter Int Int
calcRadius d i n e = d * 5

-- an example of a typed callback function
type ExData = { name :: String, age :: Int }

-- lp :: ExData -> Number -> Array D3Element -> D3Element -> Int
lp :: AttrSetter ExData Int
lp { name, age } _ _ _ =
    case name, age of -- silly little function just shows one way you might use an index function (NB in many cases D3 has better solutions for grouping)
    "awn", _ -> 20
    _, 0     -> 50
    _, _     -> 100

main :: forall e. Eff (console :: CONSOLE, d3 :: D3 | e) Unit
main = do
    _ <- runD3Monad circles_script Nothing
    log "\n\n\n====== cool beans =======\n\n\n"
    let ss = show $ S.runStructure circles_script mempty
    log ss


Generalize coroutine producers to work with any array

module Genetics.Browser.Track.Bed where

import Prelude

import Control.Coroutine (Producer, Transformer, producer, transform)
import Control.Coroutine.Aff as Aff
import Control.Monad.Aff (Aff, Fiber, delay, error, forkAff, runAff, throwError)
import Control.Monad.Aff.AVar (AVAR, AVar, makeEmptyVar, makeVar, putVar, takeVar)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (throw)
import Control.Monad.Except (runExcept)
import Control.Monad.Free.Trans (hoistFreeT)
import Control.Monad.Trans.Class (lift)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Either (Either)
import Data.Foldable (foldMap)
import Data.Foreign (Foreign, MultipleErrors, readArray, renderForeignError)
import Data.Int as Int
import Data.List.NonEmpty (NonEmptyList)
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty)
import Data.Newtype (wrap)
import Data.String as String
import Data.Traversable (traverse)
import Data.Validation.Semigroup (V, invalid, unV)
import Debug.Trace as Debug
import Genetics.Browser.Types (ChrId)
import Network.HTTP.Affjax as Affjax
import Simple.JSON (read)
import Unsafe.Coerce (unsafeCoerce)

{- NB this deals with JSON that's currently specified to work with a
bespoke conversion of the gencode.bb genes file from biodalliance.org.
in other words, it is garbage

example converted line:

{"chrom":"chr1"
,"chromStart":"5083172"
,"chromEnd":"5162549"
,"name":"ENSMUST00000044369.7"
,"score":"1000"
,"strand":"+"
,"thickStart":"5084450"
,"thickEnd":"5162162"
,"itemRgb":"0,0,0"
,"blockCount":"14"
,"blockSizes":"106,147,103,90,114,105,54,98,193,179,126,102,114,445"
,"blockStarts":"0,1244,5836,10190,12442,14856,17897,34217,41104,49911,52639,60577,66775,78932"
,"geneId":"ENSMUSG00000033793.7"
,"geneName":"Atp6v1h"
,"type":"protein_coding"
,"tags":"basic,appris_principal,CCDS"}

-}

type BedLine count method attrs ident coord many =
  ( chrom :: ident
  , chromStart :: coord
  , chromEnd :: coord
  , name :: String
  , score :: count
  , strand :: String
  , thickStart :: coord
  , thickEnd :: coord
  , itemRgb :: String
  , blockCount :: count
  , blockSizes :: many
  , blockStarts :: many
  , geneId :: String
  , geneName :: String
  , "type" :: method
  , tags :: attrs
  )

type RawBedLine = Record (BedLine String String String String String String)

type ParsedLine = Record (BedLine Int String String ChrId BigInt (Array BigInt))

type Validated = V (NonEmptyList String)

-- TODO this should compare to browser coord sys used
validChrId :: String -> Validated ChrId
              -- TODO super duper cool hardcoded string transformation to go from "chr1" to "1" which everything else uses atm
validChrId = pure <<< wrap <<< String.drop 3

validInt :: String -> Validated Int
validInt s = case Int.fromString s of
  Nothing -> invalid $ pure $ "Error parsing int " <> s
  Just i  -> pure i

validBigInt :: String -> Validated BigInt
validBigInt s = case BigInt.fromString s of
  Nothing -> invalid $ pure $ "Error parsing int " <> s
  Just i  -> pure i

validList :: String -> V (NonEmptyList String) (Array BigInt)
validList x = traverse validBigInt (String.split (wrap ",") x)

-- TODO validate `*Start` and `*End` by providing a coord sys and comparing thick* to chrom* etc.
-- -- TODO more validation & parsing (e.g. of `itemRgb` and `strand` could be done, but not necessary ATM)
validLine :: RawBedLine -> Validated ParsedLine
validLine l = (l { chrom = _
                 , chromStart = _, chromEnd = _
                 , score = _
                 , thickStart = _, thickEnd = _
                 , blockCount = _
                 , blockSizes = _, blockStarts = _})
           <$> validChrId l.chrom
           <*> validBigInt l.chromStart <*> validBigInt l.chromEnd
           <*> validInt l.score
           <*> validBigInt l.thickStart <*> validBigInt l.thickEnd
           <*> validInt l.blockCount
           <*> validList l.blockSizes
           <*> validList l.blockStarts

validateBedChunk :: Array Foreign -> Validated (Array ParsedLine)
validateBedChunk d =
  case (runExcept $ traverse read d) :: Either MultipleErrors (Array RawBedLine) of

    Left err -> invalid $ map renderForeignError err
    Right ls -> traverse validLine ls

    -- Right ls -> pure ls

-- fetchBed :: String -> Aff _ (Array (BedLine ChrId BigInt))
fetchBed :: String -> Aff _ (Array ParsedLine)
fetchBed url = do
  resp <- _.response <$> Affjax.get url

  case runExcept $ readArray resp of
    Left err -> Debug.trace "shit's fucked" \_ -> pure $ unsafeCoerce unit
    -- Left err -> throw $ (error <<< foldMap (_ <> ", ") <<< renderForeignError <$> err)
    Right ls -> do
        unV (throwError <<< error <<< foldMap (_ <> ", "))
            pure
            $ validateBedChunk ls

chunkProducer :: forall a.
                 Int
              -> Array a
              -> Producer (Array a) (Aff _) Unit
chunkProducer n input = Aff.produceAff \emit -> do
  remaining <- makeVar input

  let prodLoop = do

        unparsed <- takeVar remaining

        case Array.length unparsed of
          0 -> emit $ Right unit
          _ -> do
            let chunk = Array.take n unparsed
                rest  = Array.drop n unparsed

            putVar rest remaining
            emit $ Left chunk
            prodLoop

  prodLoop

fetchForeignChunks :: String
                   -> Aff _ (Producer (Array Foreign) (Aff _) Unit)
fetchForeignChunks url = do
  resp <- _.response <$> Affjax.get url

  case runExcept $ readArray resp of
      -- TODO actually handle this failing : )
    Left err -> Debug.trace "shit's fucked" \_ -> pure $ unsafeCoerce unit
    Right ls ->
      pure $ chunkProducer 512 ls

parsedLineTransformer :: Transformer
                         (Array Foreign)
                         (Array ParsedLine)
                         (Aff _) Unit
parsedLineTransformer =
  transform
  -- TODO holy hell handle failure
     $ unV (const mempty) id <<< validateBedChunk

module Genetics.Browser.Track.Bed where

import Prelude

import Control.Coroutine (Producer, producer)
import Control.Coroutine.Aff as Aff
import Control.Monad.Aff (Aff, Fiber, delay, error, forkAff, runAff, throwError)
import Control.Monad.Aff.AVar (AVAR, AVar, makeEmptyVar, makeVar, putVar, takeVar)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (throw)
import Control.Monad.Except (runExcept)
import Control.Monad.Free.Trans (hoistFreeT)
import Control.Monad.Trans.Class (lift)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Either (Either)
import Data.Foldable (foldMap)
import Data.Foreign (Foreign, MultipleErrors, readArray, renderForeignError)
import Data.Int as Int
import Data.List.NonEmpty (NonEmptyList)
import Data.Maybe (Maybe(..))
import Data.Newtype (wrap)
import Data.String as String
import Data.Traversable (traverse)
import Data.Validation.Semigroup (V, invalid, unV)
import Debug.Trace as Debug
import Genetics.Browser.Types (ChrId)
import Network.HTTP.Affjax as Affjax
import Simple.JSON (read)
import Unsafe.Coerce (unsafeCoerce)

{- NB this deals with JSON that's currently specified to work with a
bespoke conversion of the gencode.bb genes file from biodalliance.org.
in other words, it is garbage

example converted line:

{"chrom":"chr1"
,"chromStart":"5083172"
,"chromEnd":"5162549"
,"name":"ENSMUST00000044369.7"
,"score":"1000"
,"strand":"+"
,"thickStart":"5084450"
,"thickEnd":"5162162"
,"itemRgb":"0,0,0"
,"blockCount":"14"
,"blockSizes":"106,147,103,90,114,105,54,98,193,179,126,102,114,445"
,"blockStarts":"0,1244,5836,10190,12442,14856,17897,34217,41104,49911,52639,60577,66775,78932"
,"geneId":"ENSMUSG00000033793.7"
,"geneName":"Atp6v1h"
,"type":"protein_coding"
,"tags":"basic,appris_principal,CCDS"}

-}

type BedLine count method attrs ident coord many =
  ( chrom :: ident
  , chromStart :: coord
  , chromEnd :: coord
  , name :: String
  , score :: count
  , strand :: String
  , thickStart :: coord
  , thickEnd :: coord
  , itemRgb :: String
  , blockCount :: count
  , blockSizes :: many
  , blockStarts :: many
  , geneId :: String
  , geneName :: String
  , "type" :: method
  , tags :: attrs
  )

type RawBedLine = Record (BedLine String String String String String String)

type ParsedLine = Record (BedLine Int String String ChrId BigInt (Array BigInt))

type Validated = V (NonEmptyList String)

-- TODO this should compare to browser coord sys used
validChrId :: String -> Validated ChrId
              -- TODO super duper cool hardcoded string transformation to go from "chr1" to "1" which everything else uses atm
validChrId = pure <<< wrap <<< String.drop 3

validInt :: String -> Validated Int
validInt s = case Int.fromString s of
  Nothing -> invalid $ pure $ "Error parsing int " <> s
  Just i  -> pure i

validBigInt :: String -> Validated BigInt
validBigInt s = case BigInt.fromString s of
  Nothing -> invalid $ pure $ "Error parsing int " <> s
  Just i  -> pure i

validList :: String -> V (NonEmptyList String) (Array BigInt)
validList x = traverse validBigInt (String.split (wrap ",") x)

-- TODO validate `*Start` and `*End` by providing a coord sys and comparing thick* to chrom* etc.
-- -- TODO more validation & parsing (e.g. of `itemRgb` and `strand` could be done, but not necessary ATM)
validLine :: RawBedLine -> Validated ParsedLine
validLine l = (l { chrom = _
                 , chromStart = _, chromEnd = _
                 , score = _
                 , thickStart = _, thickEnd = _
                 , blockCount = _
                 , blockSizes = _, blockStarts = _})
           <$> validChrId l.chrom
           <*> validBigInt l.chromStart <*> validBigInt l.chromEnd
           <*> validInt l.score
           <*> validBigInt l.thickStart <*> validBigInt l.thickEnd
           <*> validInt l.blockCount
           <*> validList l.blockSizes
           <*> validList l.blockStarts

validateBedChunk :: Array Foreign -> Validated (Array ParsedLine)
validateBedChunk d =
  case (runExcept $ traverse read d) :: Either MultipleErrors (Array RawBedLine) of

    Left err -> invalid $ map renderForeignError err
    Right ls -> traverse validLine ls

    -- Right ls -> pure ls

-- fetchBed :: String -> Aff _ (Array (BedLine ChrId BigInt))
fetchBed :: String -> Aff _ (Array ParsedLine)
fetchBed url = do
  resp <- _.response <$> Affjax.get url

  case runExcept $ readArray resp of
    Left err -> Debug.trace "shit's fucked" \_ -> pure $ unsafeCoerce unit
    -- Left err -> throw $ (error <<< foldMap (_ <> ", ") <<< renderForeignError <$> err)
    Right ls -> do
        unV (throwError <<< error <<< foldMap (_ <> ", "))
            pure
            $ validateBedChunk ls

produceBed :: String
           -> Aff _ (Producer (Array ParsedLine) (Aff _) Unit)
produceBed url = do
    -- if necessary, producer should fetch the stuff too -- no reason to block here, if that's a thing
  resp <- _.response <$> Affjax.get url

  -- make sure it's an array
  case runExcept $ readArray resp of
    Left err -> Debug.trace "shit's fucked" \_ -> pure $ unsafeCoerce unit
    -- Left err -> throw $ (error <<< foldMap (_ <> ", ") <<< renderForeignError <$> err)
    Right ls -> do
      -- AVar to store unparsed lines
      remaining <- makeVar ls

      let produceLoop emit = do
        -- extract remaining from Avar
            unparsed <- takeVar remaining

            -- if there are no unparsed lines, emit 'unit' to signal producer done, and kill the avar
            case Array.length unparsed of
              0 -> emit $ Right unit
              n -> do
                -- if there are unparsed lines left, take a chunk of them,
                let chunkSize = 500
                    chunk = Array.take 500 unparsed
                    rest  = Array.drop 500 unparsed

                -- updating the stored unparsed lines
                putVar rest remaining

                -- parse & emit the chunk

                -- TODO what to do on failure? should it even be handled here?
                unV (\_ -> pure unit)
                    (emit <<< Left)
                    $ validateBedChunk chunk

                -- chill for a bit & repeat
                delay (wrap 10.0) *> produceLoop emit

        -- return producer
      pure $ Aff.produceAff produceLoop


Updated types

Updated types

module Page where

import Prelude
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Data.Maybe (Maybe(..))

data Query a = LoadSeries a
             | SeriesLoaded a

type State = { series :: Maybe String }

page :: forall m. H.Component HH.HTML Query Unit Void m
page =
  H.component
    { initialState: const initialState  -- query -> state const will creatre function which ignore query param
    , render                            --  state -> HTML
    , eval                              -- Query ->ComponentDSL state query output monad
    , receiver: const Nothing           --
    }

initialState :: State
initialState = { series: Nothing }

render :: State -> H.ComponentHTML Query
render state =
  HH.div_
    [ renderNavibar
    , renderChart state
    , renderUploadSection
    ]

renderNavibar :: forall p. HH.HTML p (Query Unit)
renderNavibar =
  HH.nav
    [ HP.class_ (H.ClassName "navbar navbar-default") ]
    [ HH.div
      [ HP.class_ (H.ClassName "container-fluid") ]
      [ HH.div
          [ HP.class_ (H.ClassName "navbar-header") ]
          [ HH.a
            [ HP.class_ (H.ClassName "navbar-brand")
            , HP.href "#"]
            [ HH.text "Time Series Lab" ]
          ]
      ]
    ]

-- Render Chart based on provided Time Series.
-- If there is no Series then render empty space
renderChart :: forall p. State -> HH.HTML p (Query Unit)
renderChart state =
  HH.div
    [ HP.class_ (H.ClassName "panel panel-default") ]
    [ HH.div
      [ HP.class_ (H.ClassName "panel-body") ]
      [ HH.text (show state.series) ]
    ]

-- Render upload button
renderUploadSection :: forall p. HH.HTML p (Query Unit)
renderUploadSection =
  HH.div
    [ HP.class_ (H.ClassName "panel panel-default") ]
    [ HH.div
      [ HP.class_ (H.ClassName "panel-body") ]
      [ HH.text "Select CSV file"
      , HH.div_
        [ HH.input
          [ HP.type_ HP.InputFile
          , HP.id_ "fileInput"
          , HE.onChange (HE.input_ LoadSeries)
          ]
        ]
      ]
    ]

-- Query evaluation
    -- var file = fileInput.files[0];
    -- var reader = new FileReader();
    -- reader.onload = function(e) {
    --     csvUploaded(reader.result);
    -- }
    -- reader.readAsText(file);
eval :: forall m. Query ~> H.ComponentDSL State Query Void m
eval = case _ of

  LoadSeries next -> do
    --  d <- document =<< window
    H.modify (\state -> { series: Just "loaded" })
    pure next

  SeriesLoaded next -> do
    pure next

module Page where

import Prelude
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Data.Maybe (Maybe(..))

data Query a = LoadSeries a

type State = { series :: Maybe String }

page :: forall m. H.Component HH.HTML Query Unit Void m
page =
  H.component
    { initialState: const initialState  -- query -> state const will creatre function which ignore query param
    , render                            --  state -> HTML
    , eval                              -- Query ->ComponentDSL state query output monad
    , receiver: const Nothing           --
    }

initialState :: State
initialState = { series: Nothing }

render :: State -> H.ComponentHTML Query
render state =
  HH.div_
    [ renderNavibar
    , renderChart state
    , renderUploadSection
    ]

renderNavibar :: forall p i. HH.HTML p i
renderNavibar =
  HH.nav
    [ HP.class_ (H.ClassName "navbar navbar-default") ]
    [ HH.div
      [ HP.class_ (H.ClassName "container-fluid") ]
      [ HH.div
          [ HP.class_ (H.ClassName "navbar-header") ]
          [ HH.a
            [ HP.class_ (H.ClassName "navbar-brand")
            , HP.href "#"]
            [ HH.text "Time Series Lab" ]
          ]
      ]
    ]

-- Render Chart based on provided Time Series.
-- If there is no Series then render empty space
renderChart :: forall p i. State -> HH.HTML p i
renderChart state =
  HH.div
    [ HP.class_ (H.ClassName "panel panel-default") ]
    [ HH.div
      [ HP.class_ (H.ClassName "panel-body") ]
      [ HH.text (show state.series) ]
    ]

-- Render upload button
renderUploadSection :: forall p. HH.HTML p (Query Unit)
renderUploadSection =
  HH.div
    [ HP.class_ (H.ClassName "panel panel-default") ]
    [ HH.div
      [ HP.class_ (H.ClassName "panel-body") ]
      [ HH.text "Select CSV file"
      , HH.div_
        [ HH.input
          [ HP.type_ HP.InputFile
          , HE.onChange (HE.input_ LoadSeries)
          ]
        ]
      ]
    ]

-- Query evaluation
eval :: forall m. Query ~> H.ComponentDSL State Query Void m
eval = case _ of
  LoadSeries next -> do
    H.modify (\state -> { series: Just "loaded" })
    pure next


Fix dismissal of FS dialogs

Fix dismissal of FS dialogs

{-
Copyright 2016 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 SlamData.FileSystem.Dialog.Component where

import SlamData.Prelude

import Data.Array (singleton)

import Halogen as H
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA

import Network.HTTP.RequestHeader (RequestHeader)

import SlamData.Dialog.Error.Component as Error
import SlamData.FileSystem.Dialog.Download.Component as Download
import SlamData.FileSystem.Dialog.Explore.Component as Explore
import SlamData.FileSystem.Dialog.Mount.Component (MountSettings)
import SlamData.FileSystem.Dialog.Mount.Component as Mount
import SlamData.FileSystem.Dialog.Rename.Component as Rename
import SlamData.FileSystem.Dialog.Share.Component as Share
import SlamData.FileSystem.Dialog.Component.Message (Message(..))
import SlamData.FileSystem.Resource (Resource, Mount)
import SlamData.Monad (Slam)
import SlamData.Workspace.Deck.Component.CSS as CSS

import Utils.Path (DirPath, FilePath)

data Dialog
  = Error String
  | Share String
  | Rename Resource
  | Mount DirPath String (Maybe MountSettings)
  | Download Resource (Array RequestHeader)
  | Explore FilePath

type State = Maybe Dialog

data Query a
  = Show Dialog a
  | RaiseDismiss a
  | QueryRename (Rename.Query Unit) a
  | SaveMount (Maybe Mount → a)
  | HandleChild Message a
  | AddDirsToRename (Array Resource) a

type ChildQuery
  = Error.Query
  ⨁ Share.Query
  ⨁ Rename.Query
  ⨁ Download.Query
  ⨁ Mount.Query
  ⨁ Explore.Query
  ⨁ Const Void

type ChildSlot = Unit ⊹ Unit ⊹ Unit ⊹ Unit ⊹ Unit ⊹ Unit ⊹ Void

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.parentComponent
    { initialState: const Nothing
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ State → H.ParentHTML Query ChildQuery ChildSlot Slam
render state =
  HH.div_
    [ HH.div
        [ HP.classes $ [ CSS.dialogBackdrop ] ⊕ (guard (isNothing state) $> CSS.invisible)
        , HE.onMouseDown (HE.input_ RaiseDismiss)
        , ARIA.hidden $ show $ isNothing state
        ]
        []
    , HH.div
        [ HP.classes $ [] ⊕ (guard (isNothing state) $> CSS.invisible)
        , ARIA.hidden $ show $ isNothing state
        ]
        $ maybe [] (singleton <<< dialog) state
    ]
  where
  dialog = case _ of
    Error str →
      HH.slot' CP.cp1 unit Error.component str (HE.input_ RaiseDismiss)
    Share str →
      HH.slot' CP.cp2 unit Share.component str (HE.input_ RaiseDismiss)
    Rename res →
      HH.slot' CP.cp3 unit Rename.component res (HE.input HandleChild)
    Download resource headers →
      HH.slot' CP.cp4 unit Download.component { resource, headers } (HE.input_ RaiseDismiss)
    Mount parent name settings →
      HH.slot' CP.cp5 unit Mount.component { parent, name, settings } (HE.input HandleChild)
    Explore fp →
      HH.slot' CP.cp6 unit Explore.component fp (HE.input_ RaiseDismiss)

eval ∷ Query ~> H.ParentDSL State Query ChildQuery ChildSlot Message Slam
eval = case _ of
  QueryRename q next → do
    H.query' CP.cp3 unit q
    pure next
  SaveMount reply → do
    map (reply ∘ join) $ H.query' CP.cp5 unit $ H.request Mount.Save
  Show d next → do
    H.put (Just d)
    pure next
  RaiseDismiss next → do
    H.put Nothing
    pure next
  HandleChild m next → do
    case m of
      Dismiss → H.put Nothing
      _ → H.raise m
    pure next
  AddDirsToRename dirs next → do
    H.query' CP.cp3 unit $ H.action $ Rename.AddDirs dirs
    pure next

{-
Copyright 2016 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 SlamData.FileSystem.Dialog.Component where

import SlamData.Prelude

import Data.Array (singleton)

import Halogen as H
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA

import Network.HTTP.RequestHeader (RequestHeader)

import SlamData.Dialog.Error.Component as Error
import SlamData.FileSystem.Dialog.Download.Component as Download
import SlamData.FileSystem.Dialog.Explore.Component as Explore
import SlamData.FileSystem.Dialog.Mount.Component (MountSettings)
import SlamData.FileSystem.Dialog.Mount.Component as Mount
import SlamData.FileSystem.Dialog.Rename.Component as Rename
import SlamData.FileSystem.Dialog.Share.Component as Share
import SlamData.FileSystem.Dialog.Component.Message (Message(..))
import SlamData.FileSystem.Resource (Resource, Mount)
import SlamData.Monad (Slam)
import SlamData.Workspace.Deck.Component.CSS as CSS

import Utils.Path (DirPath, FilePath)

data Dialog
  = Error String
  | Share String
  | Rename Resource
  | Mount DirPath String (Maybe MountSettings)
  | Download Resource (Array RequestHeader)
  | Explore FilePath

type State = Maybe Dialog

data Query a
  = Show Dialog a
  | RaiseDismiss a
  | QueryRename (Rename.Query Unit) a
  | SaveMount (Maybe Mount → a)
  | HandleChild Message a
  | AddDirsToRename (Array Resource) a

type ChildQuery
  = Error.Query
  ⨁ Share.Query
  ⨁ Rename.Query
  ⨁ Download.Query
  ⨁ Mount.Query
  ⨁ Explore.Query
  ⨁ Const Void

type ChildSlot = Unit ⊹ Unit ⊹ Unit ⊹ Unit ⊹ Unit ⊹ Unit ⊹ Void

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.parentComponent
    { initialState: const Nothing
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ State → H.ParentHTML Query ChildQuery ChildSlot Slam
render state =
  HH.div_
    [ HH.div
        [ HP.classes $ [ CSS.dialogBackdrop ] ⊕ (guard (isNothing state) $> CSS.invisible)
        , HE.onMouseDown (HE.input_ RaiseDismiss)
        , ARIA.hidden $ show $ isNothing state
        ]
        []
    , HH.div
        [ HP.classes $ [] ⊕ (guard (isNothing state) $> CSS.invisible)
        , ARIA.hidden $ show $ isNothing state
        ]
        $ maybe [] (singleton <<< dialog) state
    ]
  where
  dialog = case _ of
    Error str →
      HH.slot' CP.cp1 unit Error.component str (HE.input_ RaiseDismiss)
    Share str →
      HH.slot' CP.cp2 unit Share.component str (HE.input_ RaiseDismiss)
    Rename res →
      HH.slot' CP.cp3 unit Rename.component res (HE.input HandleChild)
    Download resource headers →
      HH.slot' CP.cp4 unit Download.component { resource, headers } (HE.input_ RaiseDismiss)
    Mount parent name settings →
      HH.slot' CP.cp5 unit Mount.component { parent, name, settings } (HE.input HandleChild)
    Explore fp →
      HH.slot' CP.cp6 unit Explore.component fp (HE.input_ RaiseDismiss)

eval ∷ Query ~> H.ParentDSL State Query ChildQuery ChildSlot Message Slam
eval = case _ of
  QueryRename q next → do
    H.query' CP.cp3 unit q
    pure next
  SaveMount reply → do
    map (reply ∘ join) $ H.query' CP.cp5 unit $ H.request Mount.Save
  Show d next → do
    H.put (Just d)
    pure next
  RaiseDismiss next → do
    H.put Nothing
    H.raise Dismiss
    pure next
  HandleChild m next → do
    H.raise m
    pure next
  AddDirsToRename dirs next → do
    H.query' CP.cp3 unit $ H.action $ Rename.AddDirs dirs
    pure next


Don't duplicate filename in explore paths

{-
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 Dashboard.Routing
  ( routing
  , routeSignal
  , Routes(..)
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Monad (when)
import Control.Monad.Aff (Aff())
import Control.Monad.Eff.Class (liftEff)

import Data.Either (Either(..))
import Data.Foldable (foldl, foldr)
import Data.List (List(), init, last)
import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe as U
import Data.Path.Pathy ((</>), rootDir, dir, file)
import Data.String.Regex (noFlags, regex, test, Regex())
import Data.Tuple (Tuple(..))

import Halogen (Driver())

import DOM.BrowserFeatures.Detectors (detectBrowserFeatures)

import Model.AccessType (AccessType(..), parseAccessType)
import Model.CellId (CellId(), stringToCellId)
import Model.Resource (Resource(..), resourceName, resourceDir)

import Routing (matchesAff')
import Routing.Match (Match(), list, eitherMatch)
import Routing.Match.Class (lit, str)

import Dashboard.Component (QueryP(), Query(..), toNotebook, fromNotebook, fromDashboard, toDashboard)

import Notebook.Component as Notebook
import Notebook.Effects (NotebookRawEffects(), NotebookEffects())

import Utils.Path (decodeURIPath, dropNotebookExt)

data Routes
  = CellRoute Resource CellId AccessType
  | ExploreRoute Resource
  | NotebookRoute Resource AccessType

routing :: Match Routes
routing
  =   ExploreRoute <$> (oneSlash *> lit "explore" *> explored)
  <|> CellRoute <$> notebook <*> (lit "cells" *> cellId) <*> action
  <|> NotebookRoute <$> notebook <*> action

  where
  oneSlash :: Match Unit
  oneSlash = lit ""

  explored :: Match Resource
  explored = eitherMatch $ mkResource <$> list str

  mkResource :: List String -> Either String Resource
  mkResource parts =
    case last parts of
      Just filename | filename /= "" ->
        let dirParts = U.fromJust (init parts)
            filePart = file filename
            path = foldr (\part acc -> dir part </> acc) filePart dirParts
        in Right $ File $ rootDir </> path
      _ -> Left "Expected non-empty explore path"

  notebook :: Match Resource
  notebook = notebookFromParts <$> partsAndName

  notebookFromParts :: Tuple (List String) String -> Resource
  notebookFromParts (Tuple ps nm) =
    Notebook $ foldl (</>) rootDir (map dir ps) </> dir nm

  partsAndName :: Match (Tuple (List String) String)
  partsAndName = Tuple <$> (oneSlash *> (list notName)) <*> name

  name :: Match String
  name = eitherMatch $ map notebookName str

  notName :: Match String
  notName = eitherMatch $ map pathPart str

  notebookName :: String -> Either String String
  notebookName input | checkExtension input = Right input
                     | otherwise = Left input

  pathPart :: String -> Either String String
  pathPart input | input == "" || checkExtension input = Left "incorrect path part"
                 | otherwise = Right input

  extensionRegex :: Regex
  extensionRegex = regex ("\\." <> Config.notebookExtension <> "$") noFlags

  checkExtension :: String -> Boolean
  checkExtension = test extensionRegex

  action :: Match AccessType
  action = (eitherMatch $ map parseAccessType str) <|> pure ReadOnly

  cellId :: Match CellId
  cellId = eitherMatch $ map stringToCellId str

routeSignal :: Driver QueryP NotebookRawEffects -> Aff NotebookEffects Unit
routeSignal driver = do
  Tuple oldRoute newRoute <- matchesAff' decodeURIPath routing
  case newRoute of
    CellRoute res cellId editable -> notebook res editable $ Just cellId
    NotebookRoute res editable -> notebook res editable Nothing
    ExploreRoute res -> explore res
  where
  explore :: Resource -> Aff NotebookEffects Unit
  explore res = do
    fs <- liftEff detectBrowserFeatures
    driver $ toNotebook $ Notebook.ExploreFile fs res

  notebook :: Resource -> AccessType -> Maybe CellId -> Aff NotebookEffects Unit
  notebook res accessType viewing = do
    let name = dropNotebookExt (resourceName res)
        path = resourceDir res
    currentPath <- driver $ fromDashboard GetPath
    currentName <- driver $ fromNotebook Notebook.GetNameToSave
    let pathChanged = currentPath == path
        nameChanged = currentName == pure name
    when (pathChanged || nameChanged) do
      fs <- liftEff detectBrowserFeatures
      driver $ toNotebook $ Notebook.LoadResource fs res
      driver $ toDashboard $ SetAccessType accessType
      driver $ toNotebook $ Notebook.SetName name
      driver $ toDashboard $ SetViewingCell viewing
    pure unit

{-
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 Dashboard.Routing
  ( routing
  , routeSignal
  , Routes(..)
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Monad (when)
import Control.Monad.Aff (Aff())
import Control.Monad.Eff.Class (liftEff)

import Data.Either (Either(..))
import Data.Foldable (foldl)
import Data.List (List())
import Data.Maybe (Maybe(..))
import Data.Path.Pathy ((</>), rootDir, dir, file)
import Data.String.Regex (noFlags, regex, test, Regex())
import Data.Tuple (Tuple(..))

import Halogen (Driver())

import DOM.BrowserFeatures.Detectors (detectBrowserFeatures)

import Config (notebookExtension)
import Dashboard.Component (QueryP(), Query(..), toNotebook, fromNotebook, fromDashboard, toDashboard)
import Model.AccessType (AccessType(..), parseAccessType)
import Model.Resource (Resource(..), resourceName, resourceDir)
import Notebook.Component as Notebook
import Model.CellId (CellId(), stringToCellId)
import Notebook.Effects (NotebookRawEffects(), NotebookEffects())
import Routing (matchesAff')
import Routing.Match (Match(), list, eitherMatch)
import Routing.Match.Class (lit, str)
import Utils.Path (decodeURIPath, dropNotebookExt, DirPath())

data Routes
  = CellRoute Resource CellId AccessType
  | ExploreRoute Resource
  | NotebookRoute Resource AccessType

routing :: Match Routes
routing
  =   ExploreRoute <$> (oneSlash *> lit "explore" *> explored)
  <|> CellRoute <$> notebook <*> (lit "cells" *> cellId) <*> action
  <|> NotebookRoute <$> notebook <*> action

  where
  oneSlash :: Match Unit
  oneSlash = lit ""

  explored :: Match Resource
  explored = map fileFromParts fileParts

  fileFromParts :: List String -> Resource
  fileFromParts parts = File $ dirAndFile.directory </> file dirAndFile.file
    where
    dirAndFile :: { directory :: DirPath, file :: String }
    dirAndFile = foldl foldFn { directory: rootDir, file: "" } parts

    foldFn
      :: { directory :: DirPath, file :: String } -> String
      -> { directory :: DirPath, file :: String }
    foldFn acc str = { directory: acc.directory </> dir str
                     , file: str
                     }
  fileParts :: Match (List String)
  fileParts = list str

  notebook :: Match Resource
  notebook = notebookFromParts <$> partsAndName

  notebookFromParts :: Tuple (List String) String -> Resource
  notebookFromParts (Tuple ps nm) =
    Notebook $ foldl (</>) rootDir (map dir ps) </> dir nm

  partsAndName :: Match (Tuple (List String) String)
  partsAndName = Tuple <$> (oneSlash *> (list notName)) <*> name

  name :: Match String
  name = eitherMatch $ map notebookName str

  notName :: Match String
  notName = eitherMatch $ map pathPart str

  notebookName :: String -> Either String String
  notebookName input | checkExtension input = Right input
                     | otherwise = Left input

  pathPart :: String -> Either String String
  pathPart input | input == "" || checkExtension input = Left "incorrect path part"
                 | otherwise = Right input

  extensionRegex :: Regex
  extensionRegex = regex ("\\." <> notebookExtension <> "$") noFlags

  checkExtension :: String -> Boolean
  checkExtension = test extensionRegex

  action :: Match AccessType
  action = (eitherMatch $ map parseAccessType str) <|> pure ReadOnly

  cellId :: Match CellId
  cellId = eitherMatch $ map stringToCellId str

routeSignal :: Driver QueryP NotebookRawEffects -> Aff NotebookEffects Unit
routeSignal driver = do
  Tuple oldRoute newRoute <- matchesAff' decodeURIPath routing
  case newRoute of
    CellRoute res cellId editable -> notebook res editable $ Just cellId
    NotebookRoute res editable -> notebook res editable Nothing
    ExploreRoute res -> explore res
  where
  explore :: Resource -> Aff NotebookEffects Unit
  explore res = do
    fs <- liftEff detectBrowserFeatures
    driver $ toNotebook $ Notebook.ExploreFile fs res

  notebook :: Resource -> AccessType -> Maybe CellId -> Aff NotebookEffects Unit
  notebook res accessType viewing = do
    let name = dropNotebookExt (resourceName res)
        path = resourceDir res
    currentPath <- driver $ fromDashboard GetPath
    currentName <- driver $ fromNotebook Notebook.GetNameToSave
    let pathChanged = currentPath == path
        nameChanged = currentName == pure name
    when (pathChanged || nameChanged) do
      fs <- liftEff detectBrowserFeatures
      driver $ toNotebook $ Notebook.LoadResource fs res
      driver $ toDashboard $ SetAccessType accessType
      driver $ toNotebook $ Notebook.SetName name
      driver $ toDashboard $ SetViewingCell viewing
    pure unit


Use either instead of pattern matching

Use either instead of pattern matching

module Api
    ( loadSnippet
    , loadSnippets
    , voteSnippetSucks
    , voteSnippetRocks
    ) where

import Control.Monad.Eff
import Control.Monad.Cont.Trans
import Control.Monad.Maybe.Trans
import Control.Monad.Trans
import Control.Plus
import Control.MonadPlus
import Data.Either
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Network
import Types

loadSnippet :: forall eff. Number -> MaybeT (ContT Unit (Eff eff)) Snippet
loadSnippet id = do
    response <- lift <<< get' $ "/snippet/" ++ (show id)
    guard $ response.status == 200
    either (const empty) return $ readJSON response.text :: F Snippet

loadSnippets :: forall eff. ContT Unit (Eff eff) [Snippet]
loadSnippets = do
    response <- get' "/snippets"
    return $ either (const []) id $ readJSON response.text :: F [Snippet]

mkVoteUrl :: String -> Number -> String
mkVoteUrl v i = "/snippet/" ++ (show i) ++ "/" ++ v

voteSnippet :: forall eff. String -> Number -> ContT Unit (Eff eff) Unit
voteSnippet vote id = do
    put' $ mkVoteUrl vote id
    return unit

voteSnippetSucks :: forall eff. Number -> ContT Unit (Eff eff) Unit
voteSnippetSucks = voteSnippet "sucks"

voteSnippetRocks :: forall eff. Number -> ContT Unit (Eff eff) Unit
voteSnippetRocks = voteSnippet "rocks"

module Api
    ( loadSnippet
    , loadSnippets
    , voteSnippetSucks
    , voteSnippetRocks
    ) where

import Control.Monad.Eff
import Control.Monad.Cont.Trans
import Control.Monad.Maybe.Trans
import Control.Monad.Trans
import Control.Plus
import Control.MonadPlus
import Data.Either
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Network
import Types

loadSnippet :: forall eff. Number -> MaybeT (ContT Unit (Eff eff)) Snippet
loadSnippet id = do
    response <- lift <<< get' $ "/snippet/" ++ (show id)
    guard $ response.status == 200

    let deserializedSnippet = readJSON response.text :: F Snippet
    case deserializedSnippet of
         (Right snippet) -> return snippet
         otherwise       -> empty

loadSnippets :: forall eff. ContT Unit (Eff eff) [Snippet]
loadSnippets = do
    response <- get' "/snippets"
    let deserializedSnippets = readJSON response.text :: F [Snippet]
    case deserializedSnippets of
         (Right snippets) -> return snippets
         (Left _)         -> return []

mkVoteUrl :: String -> Number -> String
mkVoteUrl v i = "/snippet/" ++ (show i) ++ "/" ++ v

voteSnippet :: forall eff. String -> Number -> ContT Unit (Eff eff) Unit
voteSnippet vote id = do
    put' $ mkVoteUrl vote id
    return unit

voteSnippetSucks :: forall eff. Number -> ContT Unit (Eff eff) Unit
voteSnippetSucks = voteSnippet "sucks"

voteSnippetRocks :: forall eff. Number -> ContT Unit (Eff eff) Unit
voteSnippetRocks = voteSnippet "rocks"