fixes SD-1297

fixes SD-1297

{-
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 Data.Either (Either(..))
import Data.Foldable (foldl, foldr)
import Data.Functor.Eff (liftEff)
import Data.List (List(), init, last)
import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe as U
import Data.Path.Pathy ((</>), rootDir, dir, file, DirName(..))
import Data.String.Regex (noFlags, regex, test, Regex())
import Data.Tuple (Tuple(..), snd)

import Halogen (Driver())

import DOM.BrowserFeatures.Detectors (detectBrowserFeatures)

import Model.AccessType (AccessType(..), parseAccessType)
import Model.Notebook.Action (Action(..), parseAction, toAccessType)

import Notebook.Cell.CellId (CellId(), stringToCellId)
import Notebook.Component as Notebook
import Notebook.Effects (NotebookRawEffects(), NotebookEffects())

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

import Dashboard.Component
  (QueryP(), Query(..), toNotebook, fromNotebook, toDashboard, toRename)
import Dashboard.Rename.Component as Rename
import Utils.Path
  (DirPath(), FilePath(), decodeURIPath, dropNotebookExt, getNameStr, getDir)

data Routes
  = CellRoute DirPath CellId AccessType
  | ExploreRoute FilePath
  | NotebookRoute DirPath Action

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

  where
  oneSlash :: Match Unit
  oneSlash = lit ""

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

  mkResource :: List String -> Either String FilePath
  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 $ rootDir </> path
      _ -> Left "Expected non-empty explore path"

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

  notebookFromParts :: Tuple (List String) String -> DirPath
  notebookFromParts (Tuple ps nm) =
    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 Action
  action = (eitherMatch $ map parseAction str) <|> pure (Load ReadOnly)

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

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

routeSignal :: Driver QueryP NotebookRawEffects -> Aff NotebookEffects Unit
routeSignal driver = do
  route <- snd <$> matchesAff' decodeURIPath routing
  case route of
    CellRoute res cellId accessType -> notebook res (Load accessType) $ Just cellId
    NotebookRoute res action -> notebook res action Nothing
    ExploreRoute res -> explore res

  where

  explore :: FilePath -> Aff NotebookEffects Unit
  explore path = do
    fs <- liftEff detectBrowserFeatures
    driver $ toNotebook $ Notebook.ExploreFile fs path

  notebook :: DirPath -> Action -> Maybe CellId -> Aff NotebookEffects Unit
  notebook path action viewing = do
    let name = getNameStr $ Right path
        directory = getDir $ Right path
    currentPath <- driver $ fromNotebook Notebook.GetPath
    currentName <- driver $ fromNotebook Notebook.GetNameToSave
    let pathChanged = currentPath /= pure directory
        nameChanged = currentName /= (pure $ DirName name)
    when (pathChanged || nameChanged) do
      features <- liftEff detectBrowserFeatures
      driver $ toRename $ Rename.SetText $ dropNotebookExt name
      if (action == New)
        then driver $ toNotebook $ Notebook.Reset features path
        else driver $ toNotebook $ Notebook.LoadNotebook features path
      driver $ toDashboard $ SetAccessType $ toAccessType action
      driver $ toDashboard $ SetViewingCell viewing

{-
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 Data.Either (Either(..))
import Data.Foldable (foldl, foldr)
import Data.Functor.Eff (liftEff)
import Data.List (List(), init, last)
import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe as U
import Data.Path.Pathy ((</>), rootDir, dir, file, DirName(..))
import Data.String.Regex (noFlags, regex, test, Regex())
import Data.Tuple (Tuple(..), snd)

import Halogen (Driver())

import DOM.BrowserFeatures.Detectors (detectBrowserFeatures)

import Model.AccessType (AccessType(..), parseAccessType)
import Model.Notebook.Action (Action(..), parseAction, toAccessType)

import Notebook.Cell.CellId (CellId(), stringToCellId)
import Notebook.Component as Notebook
import Notebook.Effects (NotebookRawEffects(), NotebookEffects())

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

import Dashboard.Component
  (QueryP(), Query(..), toNotebook, fromNotebook, toDashboard, toRename)
import Dashboard.Rename.Component as Rename
import Utils.Path
  (DirPath(), FilePath(), decodeURIPath, dropNotebookExt, getNameStr, getDir)

data Routes
  = CellRoute DirPath CellId AccessType
  | ExploreRoute FilePath
  | NotebookRoute DirPath Action

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

  where
  oneSlash :: Match Unit
  oneSlash = lit ""

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

  mkResource :: List String -> Either String FilePath
  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 $ rootDir </> path
      _ -> Left "Expected non-empty explore path"

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

  notebookFromParts :: Tuple (List String) String -> DirPath
  notebookFromParts (Tuple ps nm) =
    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 Action
  action = (eitherMatch $ map parseAction str) <|> pure (Load ReadOnly)

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

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

routeSignal :: Driver QueryP NotebookRawEffects -> Aff NotebookEffects Unit
routeSignal driver = do
  route <- snd <$> matchesAff' decodeURIPath routing
  case route of
    CellRoute res cellId accessType -> notebook res (Load accessType) $ Just cellId
    NotebookRoute res action -> notebook res action Nothing
    ExploreRoute res -> explore res

  where

  explore :: FilePath -> Aff NotebookEffects Unit
  explore path = do
    fs <- liftEff detectBrowserFeatures
    driver $ toNotebook $ Notebook.ExploreFile fs path

  notebook :: DirPath -> Action -> Maybe CellId -> Aff NotebookEffects Unit
  notebook path action viewing = do
    let name = getNameStr $ Right path
        directory = getDir $ Right path
    currentPath <- driver $ fromNotebook Notebook.GetPath
    currentName <- driver $ fromNotebook Notebook.GetNameToSave
    let pathChanged = currentPath /= pure directory
        nameChanged = currentName /= (pure $ DirName name)
    when (pathChanged || nameChanged) do
      features <- liftEff detectBrowserFeatures
      driver $ toRename $ Rename.SetText $ dropNotebookExt name
      driver $ toDashboard $ SetAccessType $ toAccessType action
      driver $ toDashboard $ SetViewingCell viewing
      if (action == New)
        then driver $ toNotebook $ Notebook.Reset features path
        else driver $ toNotebook $ Notebook.LoadNotebook features path


Fix compile error introduced by updated quickcheck

module Benchotron.Core
  ( Benchmark()
  , BenchmarkF()
  , BenchmarkFunction()
  , mkBenchmark
  , unpackBenchmark
  , benchFn
  , benchFn'
  , runBenchmark
  , runBenchmarkF
  , BenchM()
  , runBenchM
  , BenchEffects()
  , BenchmarkResult()
  , ResultSeries()
  , DataPoint()
  ) where

import Prelude
import Data.Exists
import Data.Identity
import Data.Tuple
import Data.Array (filter, (..), length, replicateM, zip)
import Data.Array.Unsafe (head)
import Data.String (joinWith)
import Data.Traversable (for)
import Data.Date (Now())
import Data.Date.Locale (Locale())
import Control.Apply ((<*))
import Control.Monad.State.Trans (StateT(), evalStateT)
import Control.Monad.State.Class (get, put)
import Control.Monad.Trans (lift)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION(), Error(), catchException,
                                    throwException, message, error)
import Node.FS (FS())
import Control.Monad.Eff.Console (CONSOLE())
import Control.Monad.Eff.Random  (RANDOM())
import Test.QuickCheck.Gen (Gen(), GenState(), runGen)

import Benchotron.StdIO
import Benchotron.BenchmarkJS
import Benchotron.Utils

-- | A value representing a benchmark to be performed. The type parameter 'e'
-- | is provided to allow you to supply a random value generator with arbitrary
-- | effects, if you need to. The type parameter 'a' is the type of the input
-- | to each of the competing functions in the benchmark.
-- |
-- | **Attributes**
-- |
-- | * `slug`: An identifier for the benchmark. Used for filenames.
-- | * `title`: The title of the benchmark.
-- | * `sizes`: An array of numbers representing each input size you would like
-- |   your benchmark to be run with. The interpretation of 'size' depends on
-- |   the specific case; if the input is an array, for example, the size would
-- |   usually be the number of elements in the array.
-- | * `sizeInterpretation`: A `String` with a human-readable description of
-- |   how the size is meant to be interpreted in this specific case.
-- | * `inputsPerSize`: The number of inputs to be generated for each each
-- |   input size. Often it's acceptable to set this to 1. By using higher
-- |   values, you can have more confidence in your results; however, your
-- |   benchmarks will also take much longer to run.
-- | * `gen`: An Eff action which should produce a random input of the given
-- |   argument size when executed.
-- | * `functions`: An array of competing functions to be benchmarked.
type BenchmarkF a =
  { slug               :: String
  , title              :: String
  , sizes              :: Array Int
  , sizeInterpretation :: String
  , inputsPerSize      :: Int
  , gen                :: Int -> Gen a
  , functions          :: Array (BenchmarkFunction a)
  }

-- This is only necessary because psc doesn't support partially applied type
-- synonyms.
newtype BenchmarkFF a = BenchmarkFF (BenchmarkF a)

newtype Benchmark = Benchmark (Exists (BenchmarkFF))

mkBenchmark :: forall a. BenchmarkF a -> Benchmark
mkBenchmark = Benchmark <<< mkExists <<< BenchmarkFF

unpackBenchmark :: forall r. (forall a. BenchmarkF a -> r) -> Benchmark -> r
unpackBenchmark f (Benchmark b) = runExists f' b
  where
  f' :: forall a. BenchmarkFF a -> r
  f' (BenchmarkFF b') = f b'

newtype BenchmarkFunction a = BenchmarkFunction (Exists (BenchmarkFunctionF a))

newtype BenchmarkFunctionF a b = BenchmarkFunctionF
  { name :: String
  , fn :: b -> Any
  , before :: a -> b
  }

-- | Create a `BenchmarkFunction`, given a name and a function to be
-- | benchmarked.
benchFn :: forall a r. String -> (a -> r) -> BenchmarkFunction a
benchFn name fn = benchFn' name fn id

-- | Create a `BenchmarkFunction`. Like `benchFn`, except that it accepts a
-- | third argument which will be used to preprocess the input, before starting
-- | the benchmark. This is useful if you want to compare two functions which
-- | have different argument types.
benchFn' :: forall a b r. String -> (b -> r) -> (a -> b) -> BenchmarkFunction a
benchFn' name fn before =
  BenchmarkFunction $ mkExists $ BenchmarkFunctionF
    { name: name, fn: toAny <<< fn, before: before }

getName :: forall a. BenchmarkFunction a -> String
getName (BenchmarkFunction f) = runExists go f
  where
  go :: forall b. BenchmarkFunctionF a b -> String
  go (BenchmarkFunctionF o) = o.name

type BenchM e a = StateT GenState (Eff (BenchEffects e)) a

runBenchM :: forall e a. BenchM e a -> GenState -> Eff (BenchEffects e) a
runBenchM = evalStateT

-- | Use the given generator to generate a random value, using (and modifying)
-- | the state of the BenchM computation.
stepGen :: forall e a. Gen a -> BenchM e a
stepGen gen = do
  st <- get
  let out = runGen gen st
  put $ snd out
  return $ fst out

runBenchmark :: forall e.
  Benchmark ->
  -- ^ The Benchmark to be run.
  (Int -> Int -> BenchM e Unit) ->
  -- ^ Callback for when the size changes; the arguments are current size index
  --   (1-based) , and the current size.
  BenchM e BenchmarkResult
runBenchmark = unpackBenchmark runBenchmarkF

runBenchmarkF :: forall e a.
  BenchmarkF a ->
  -- ^ The Benchmark to be run.
  (Int -> Int -> BenchM e Unit) ->
  -- ^ Callback for when the size changes; the arguments are current size index
  --   (1-based) , and the current size.
  BenchM e BenchmarkResult
runBenchmarkF benchmark onChange = do
  results <- for (withIndices benchmark.sizes) $ \(Tuple idx size) -> do
    onChange idx size
    let getAnInput = stepGen $ benchmark.gen size
    inputs   <- replicateM benchmark.inputsPerSize getAnInput
    allStats <- for benchmark.functions $ \function -> do
                  let name = getName function
                  lift $
                    handleBenchmarkException name size $ do
                      stats <- runBenchmarkFunction inputs function
                      return { name: name, stats: stats }

    return { size: size, allStats: allStats }

  let series = rejig results
  return
    { slug: benchmark.slug
    , title: benchmark.title
    , sizeInterpretation: benchmark.sizeInterpretation
    , series: series
    }

  where
  withIndices arr = zip (1..(length arr)) arr

-- TODO: use purescript-exceptions instead. This appears to be blocked on:
--    https://github.com/purescript/purescript-exceptions/issues/5
foreign import handleBenchmarkException ::
  forall e a. String -> Int -> Eff (BenchEffects e) a -> Eff (BenchEffects e) a

runBenchmarkFunction :: forall e a. Array a -> BenchmarkFunction a -> Eff (BenchEffects e) Stats
runBenchmarkFunction inputs (BenchmarkFunction function') =
  runExists go function'
  where
  go :: forall b. BenchmarkFunctionF a b -> Eff (BenchEffects e) Stats
  go (BenchmarkFunctionF function) =
    let inputs' = map function.before inputs
        f = \_ -> toAny $ map function.fn inputs'
    in do
      monkeyPatchBenchmark benchmarkJS
      runBenchmarkImpl benchmarkJS f

type BenchEffects e
  = ( err       :: EXCEPTION
    , fs        :: FS
    , now       :: Now
    , locale    :: Locale
    , console   :: CONSOLE
    , random    :: RANDOM
    , benchmark :: BENCHMARK
    | e
    )

type BenchmarkResult =
  { slug               :: String
  , title              :: String
  , sizeInterpretation :: String
  , series             :: Array ResultSeries
  }

type ResultSeries =
  { name    :: String
  , results :: Array DataPoint
  }

type DataPoint =
  { size  :: Int
  , stats :: Stats
  }

type IntermediateResult =
  Array { size :: Int, allStats :: Array { name :: String, stats :: Stats } }

rejig :: IntermediateResult -> Array ResultSeries
rejig [] = []
rejig results = map toSeries names
  where
  r = head results
  names = map _.name r.allStats
  toSeries name =
    { name: name
    , results: map (\o -> { size: o.size
                          , stats: _.stats $ the $ filter ((==) name <<< _.name) o.allStats
                          }) results
    }
  the [x] = x

module Benchotron.Core
  ( Benchmark()
  , BenchmarkF()
  , BenchmarkFunction()
  , mkBenchmark
  , unpackBenchmark
  , benchFn
  , benchFn'
  , runBenchmark
  , runBenchmarkF
  , BenchM()
  , runBenchM
  , BenchEffects()
  , BenchmarkResult()
  , ResultSeries()
  , DataPoint()
  ) where

import Prelude
import Data.Exists
import Data.Identity
import Data.Tuple
import Data.Array (filter, (..), length, replicateM, zip)
import Data.Array.Unsafe (head)
import Data.String (joinWith)
import Data.Traversable (for)
import Data.Date (Now())
import Data.Date.Locale (Locale())
import Control.Apply ((<*))
import Control.Monad.State.Trans (StateT(), evalStateT)
import Control.Monad.State.Class (get, put)
import Control.Monad.Trans (lift)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION(), Error(), catchException,
                                    throwException, message, error)
import Node.FS (FS())
import Control.Monad.Eff.Console (CONSOLE())
import Control.Monad.Eff.Random  (RANDOM())
import Test.QuickCheck.Gen (Gen(), GenState(), runGen)

import Benchotron.StdIO
import Benchotron.BenchmarkJS
import Benchotron.Utils

-- | A value representing a benchmark to be performed. The type parameter 'e'
-- | is provided to allow you to supply a random value generator with arbitrary
-- | effects, if you need to. The type parameter 'a' is the type of the input
-- | to each of the competing functions in the benchmark.
-- |
-- | **Attributes**
-- |
-- | * `slug`: An identifier for the benchmark. Used for filenames.
-- | * `title`: The title of the benchmark.
-- | * `sizes`: An array of numbers representing each input size you would like
-- |   your benchmark to be run with. The interpretation of 'size' depends on
-- |   the specific case; if the input is an array, for example, the size would
-- |   usually be the number of elements in the array.
-- | * `sizeInterpretation`: A `String` with a human-readable description of
-- |   how the size is meant to be interpreted in this specific case.
-- | * `inputsPerSize`: The number of inputs to be generated for each each
-- |   input size. Often it's acceptable to set this to 1. By using higher
-- |   values, you can have more confidence in your results; however, your
-- |   benchmarks will also take much longer to run.
-- | * `gen`: An Eff action which should produce a random input of the given
-- |   argument size when executed.
-- | * `functions`: An array of competing functions to be benchmarked.
type BenchmarkF a =
  { slug               :: String
  , title              :: String
  , sizes              :: Array Int
  , sizeInterpretation :: String
  , inputsPerSize      :: Int
  , gen                :: Int -> Gen a
  , functions          :: Array (BenchmarkFunction a)
  }

-- This is only necessary because psc doesn't support partially applied type
-- synonyms.
newtype BenchmarkFF a = BenchmarkFF (BenchmarkF a)

newtype Benchmark = Benchmark (Exists (BenchmarkFF))

mkBenchmark :: forall a. BenchmarkF a -> Benchmark
mkBenchmark = Benchmark <<< mkExists <<< BenchmarkFF

unpackBenchmark :: forall r. (forall a. BenchmarkF a -> r) -> Benchmark -> r
unpackBenchmark f (Benchmark b) = runExists f' b
  where
  f' :: forall a. BenchmarkFF a -> r
  f' (BenchmarkFF b') = f b'

newtype BenchmarkFunction a = BenchmarkFunction (Exists (BenchmarkFunctionF a))

newtype BenchmarkFunctionF a b = BenchmarkFunctionF
  { name :: String
  , fn :: b -> Any
  , before :: a -> b
  }

-- | Create a `BenchmarkFunction`, given a name and a function to be
-- | benchmarked.
benchFn :: forall a r. String -> (a -> r) -> BenchmarkFunction a
benchFn name fn = benchFn' name fn id

-- | Create a `BenchmarkFunction`. Like `benchFn`, except that it accepts a
-- | third argument which will be used to preprocess the input, before starting
-- | the benchmark. This is useful if you want to compare two functions which
-- | have different argument types.
benchFn' :: forall a b r. String -> (b -> r) -> (a -> b) -> BenchmarkFunction a
benchFn' name fn before =
  BenchmarkFunction $ mkExists $ BenchmarkFunctionF
    { name: name, fn: toAny <<< fn, before: before }

getName :: forall a. BenchmarkFunction a -> String
getName (BenchmarkFunction f) = runExists go f
  where
  go :: forall b. BenchmarkFunctionF a b -> String
  go (BenchmarkFunctionF o) = o.name

type BenchM e a = StateT GenState (Eff (BenchEffects e)) a

runBenchM :: forall e a. BenchM e a -> GenState -> Eff (BenchEffects e) a
runBenchM = evalStateT

-- | Use the given generator to generate a random value, using (and modifying)
-- | the state of the BenchM computation.
stepGen :: forall e a. Gen a -> BenchM e a
stepGen gen = do
  st <- get
  let out = runGen gen st
  put out.state
  return out.value

runBenchmark :: forall e.
  Benchmark ->
  -- ^ The Benchmark to be run.
  (Int -> Int -> BenchM e Unit) ->
  -- ^ Callback for when the size changes; the arguments are current size index
  --   (1-based) , and the current size.
  BenchM e BenchmarkResult
runBenchmark = unpackBenchmark runBenchmarkF

runBenchmarkF :: forall e a.
  BenchmarkF a ->
  -- ^ The Benchmark to be run.
  (Int -> Int -> BenchM e Unit) ->
  -- ^ Callback for when the size changes; the arguments are current size index
  --   (1-based) , and the current size.
  BenchM e BenchmarkResult
runBenchmarkF benchmark onChange = do
  results <- for (withIndices benchmark.sizes) $ \(Tuple idx size) -> do
    onChange idx size
    let getAnInput = stepGen $ benchmark.gen size
    inputs   <- replicateM benchmark.inputsPerSize getAnInput
    allStats <- for benchmark.functions $ \function -> do
                  let name = getName function
                  lift $
                    handleBenchmarkException name size $ do
                      stats <- runBenchmarkFunction inputs function
                      return { name: name, stats: stats }

    return { size: size, allStats: allStats }

  let series = rejig results
  return
    { slug: benchmark.slug
    , title: benchmark.title
    , sizeInterpretation: benchmark.sizeInterpretation
    , series: series
    }

  where
  withIndices arr = zip (1..(length arr)) arr

-- TODO: use purescript-exceptions instead. This appears to be blocked on:
--    https://github.com/purescript/purescript-exceptions/issues/5
foreign import handleBenchmarkException ::
  forall e a. String -> Int -> Eff (BenchEffects e) a -> Eff (BenchEffects e) a

runBenchmarkFunction :: forall e a. Array a -> BenchmarkFunction a -> Eff (BenchEffects e) Stats
runBenchmarkFunction inputs (BenchmarkFunction function') =
  runExists go function'
  where
  go :: forall b. BenchmarkFunctionF a b -> Eff (BenchEffects e) Stats
  go (BenchmarkFunctionF function) =
    let inputs' = map function.before inputs
        f = \_ -> toAny $ map function.fn inputs'
    in do
      monkeyPatchBenchmark benchmarkJS
      runBenchmarkImpl benchmarkJS f

type BenchEffects e
  = ( err       :: EXCEPTION
    , fs        :: FS
    , now       :: Now
    , locale    :: Locale
    , console   :: CONSOLE
    , random    :: RANDOM
    , benchmark :: BENCHMARK
    | e
    )

type BenchmarkResult =
  { slug               :: String
  , title              :: String
  , sizeInterpretation :: String
  , series             :: Array ResultSeries
  }

type ResultSeries =
  { name    :: String
  , results :: Array DataPoint
  }

type DataPoint =
  { size  :: Int
  , stats :: Stats
  }

type IntermediateResult =
  Array { size :: Int, allStats :: Array { name :: String, stats :: Stats } }

rejig :: IntermediateResult -> Array ResultSeries
rejig [] = []
rejig results = map toSeries names
  where
  r = head results
  names = map _.name r.allStats
  toSeries name =
    { name: name
    , results: map (\o -> { size: o.size
                          , stats: _.stats $ the $ filter ((==) name <<< _.name) o.allStats
                          }) results
    }
  the [x] = x


Add method call function.

Add method call function.

This is only for FFI, user don't need to use it.

module Main where

import Control.Monad.Eff

foreign import data Vue :: *
foreign import data Self :: *

foreign import data Filter :: *
foreign import data Method :: !

foreign import vue
    "function vue(opt) {\
    \    return function() {\
    \        if (opt.dat !== undefined) {\
    \            opt.data = opt.dat;\
    \            delete opt.dat;\
    \        }\
    \        return new Vue(opt);\
    \    }\
    \}" :: forall e r. { el :: String | r } -> Eff e Vue

foreign import truncate
    "function truncate(v) {\
    \    var newline = v.indexOf('\\n');\
    \    return newline > -1 ? v.slice(0, newline) : v;\
    \}" :: Filter

foreign import formatDate
    "function formatDate(v) {\
    \    return v.replace(/T|Z/g, ' ');\
    \}" :: Filter

foreign import fetchData
    "function fetchData(self) {\
    \    return function() {\
    \        var apiUrl = 'https://api.github.com/repos/yyx990803/vue/commits?per_page=3&sha=';\
    \        var xhr = new XMLHttpRequest();\
    \        xhr.open('GET', apiUrl + self.branch);\
    \        xhr.onload = function() {\
    \            self.commits = JSON.parse(xhr.responseText);\
    \        };\
    \        xhr.send();\
    \    };\
    \}" :: forall e. Self -> Eff e {}

-- `method` takes a Method effect, and makes a method by feeding the effect with the special value `this`
foreign import method
    "function method(f) {\
    \    return function() {\
    \        var self = this;\
    \        return f(self)();\
    \    };\
    \}" :: forall r a. (Self -> Eff (method :: Method | r) a) -> Eff r a

-- method call; 3rd arg should be { arg1 :: a, arg2 :: b, ... }
foreign import call
    "function call(obj) {\
    \    return function(methodName) {\
    \        return function(args) {\
    \            return function() {\
    \                return obj[methodName].apply(obj, rec2arr(args));\
    \            };\
    \        };\
    \    };\
    \    function rec2arr(rec) {\
    \        var arr = [];\
    \        for (var i = 1; i < 100; ++i) {\
    \            var key = 'arg' + i;\
    \            if (rec[key] === undefined) {\
    \                break;\
    \            } else {\
    \                arr.push(rec[key]);\
    \            }\
    \        }\
    \        return arr;\
    \    }\
    \}" :: forall object arg r e a. object -> String -> r ->  Eff e a

(|>) = call
infixr 1 |>

watch :: forall e a. String -> (Self -> Eff e {}) -> (Self -> Eff (method :: Method | e) {})
watch key eff = \self -> self |> "$watch" $ { arg1: key, arg2: (eff self) }

main = do
    vue
        {
            el: "#demo",
            dat: {
                branch: "master"
            },
            created: method (watch "branch" fetchData),
            filters: {
                truncate: truncate,
                formatDate: formatDate
            },
            methods: {
                fetchData: method fetchData
            }
        }

module Main where

import Control.Monad.Eff

foreign import data Vue :: *
foreign import data Self :: *

foreign import data Filter :: *
foreign import data Method :: !

foreign import vue
    "function vue(opt) {\
    \    return function() {\
    \        if (opt.dat !== undefined) {\
    \            opt.data = opt.dat;\
    \            delete opt.dat;\
    \        }\
    \        return new Vue(opt);\
    \    }\
    \}" :: forall e r. { el :: String | r } -> Eff e Vue

foreign import truncate
    "function truncate(v) {\
    \    var newline = v.indexOf('\\n');\
    \    return newline > -1 ? v.slice(0, newline) : v;\
    \}" :: Filter

foreign import formatDate
    "function formatDate(v) {\
    \    return v.replace(/T|Z/g, ' ');\
    \}" :: Filter

foreign import fetchData
    "function fetchData(self) {\
    \    return function() {\
    \        var apiUrl = 'https://api.github.com/repos/yyx990803/vue/commits?per_page=3&sha=';\
    \        var xhr = new XMLHttpRequest();\
    \        xhr.open('GET', apiUrl + self.branch);\
    \        xhr.onload = function() {\
    \            self.commits = JSON.parse(xhr.responseText);\
    \        };\
    \        xhr.send();\
    \    };\
    \}" :: forall e. Self -> Eff e {}

-- `method` takes a Method effect, and makes a method by feeding the effect with the special value `this`
foreign import method
    "function method(f) {\
    \    return function() {\
    \        var self = this;\
    \        return f(self)();\
    \    };\
    \}" :: forall r a. (Self -> Eff (method :: Method | r) a) -> Eff r a

-- TODO: need to factor out
foreign import callM
    "function callM(method) {\
    \    return function(key) {\
    \        return function(eff) {\
    \           return function(self) {\
    \               return function() {\
    \                   return self[method](key, eff(self));\
    \               };\
    \           };\
    \       };\
    \    };\
    \}" :: forall e a. String -> String -> (Self -> Eff e {}) -> (Self -> Eff (method :: Method | e) {})

watch = callM "$watch"

main = do
    vue
        {
            el: "#demo",
            dat: {
                branch: "master"
            },
            created: method (watch "branch" fetchData),
            filters: {
                truncate: truncate,
                formatDate: formatDate
            },
            methods: {
                fetchData: method fetchData
            }
        }


reduce FOV

reduce FOV

module Main (main,run) where

import Debug.Trace

import Control.Bind
import Control.Timer (timeout,clearTimeout)
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Data.Date
import Data.Time
import Data.Foldable (for_, foldl)

import Ace
import Ace.Types
import qualified Ace.Editor as Editor
import qualified Ace.EditSession as Session
import qualified Ace.Range as Range

import qualified Graphics.WebGL as GL
import qualified Control.Monad.JQuery as J

import WebSocket
import DefaultText
import Data.Either
import Sample

import Data.Function
import Data.Maybe
import Data.StrMap
import Data.Tuple
import Data.Array(filter,head)

import Backend
import IR
import Mesh
import Type
import Input

import MeshJsonDecode
import PipelineJsonDecode
import qualified Data.Argonaut as A
import qualified Data.Argonaut.Core as AC

import Data.Matrix (Mat(..))
import Data.Matrix4
import Data.Vector3

import qualified DOM as DOM

main = return unit

foreign import getMousePos """
  function getMousePos(e) {
      return function() {
        var mouseX, mouseY;

        if(e.offsetX) {
            mouseX = e.offsetX;
            mouseY = e.offsetY;
        }
        else if(e.layerX) {
            mouseX = e.layerX;
            mouseY = e.layerY;
        }
        return [mouseX,mouseY];
      };
  }
""" :: forall eff a. J.JQueryEvent -> Eff (dom :: DOM.DOM | eff) [Number]

foreign import getJSON """
  function getJSON(uri) {
    return function(act) {
      return function() {
        $.getJSON(uri, function(data) {
          act(data)();
        });
      };
    };
  }
""" :: forall eff a. String -> (AC.Json -> Eff (dom :: DOM.DOM | eff) a) -> Eff (dom :: DOM.DOM | eff) Unit

{-
  control-b - compile/build
  control-n - new
-}
foreign import addCommand """
  function addCommand(editor) {
    return function(cmdName) {
      return function(winKey) {
        return function(macKey) {
          return function(cmd) {
            return function() {
              editor.commands.addCommand({
                name: cmdName,
                bindKey: {win: winKey,  mac: macKey},
                exec: function(editor) {
                  cmd(editor)();
                }
              });
            };
          };
        };
      };
    };
  }
""" :: forall eff . Editor -> String -> String -> String -> (Editor -> Eff (ace :: EAce | eff) Unit) -> Eff (ace :: EAce | eff) Unit

foreign import tokenTooltip """
  function tokenTooltip(editor) {
    return function(getTy) {
      return function() {
          editor.tokenTooltip = new myTokenTooltip(editor,getTy);
      };
    };
  }
""" :: forall eff . Editor -> (Int -> Int -> Eff (ace :: EAce | eff) TypeInfoRecord) -> Eff (ace :: EAce | eff) Unit

foreign import add
  """
  function add(ob1) {
    return function(ob) {
      return function () {
        return ob.add(ob1);
      };
    };
  }
  """ :: forall eff. J.JQuery -> J.JQuery -> Eff (dom :: DOM.DOM | eff) J.JQuery

foreign import addMarkerImpl
  "function addMarkerImpl(range, clazz, type, inFront, self) {\
  \  return function() {\
  \    return self.addMarker(range, clazz, type, inFront);\
  \  };\
  \}" :: forall eff. Fn5 Range String String Boolean EditSession (Eff (ace :: EAce | eff) Int)

addMarker :: forall eff. Range -> String -> String -> Boolean -> EditSession -> Eff (ace :: EAce | eff) Int
addMarker range clazz _type inFront self = runFn5 addMarkerImpl range clazz _type inFront self

run = GL.runWebGL "glcanvas" (\s -> trace s) $ \context -> do
  Milliseconds baseTime <- nowEpochMilliseconds
  -- setup pipeline input
  let inputSchema =
        { slots : fromList [ Tuple "stream"  {primitive: Triangles, attributes: fromList [Tuple "position"  TV3F, Tuple "normal" TV3F]}
                           , Tuple "stream4" {primitive: Triangles, attributes: fromList [Tuple "position4" TV4F, Tuple "vertexUV" TV2F]}
                           , Tuple "line"    {primitive: Triangles, attributes: fromList [Tuple "position" TV3F]}
                           , Tuple "grid"    {primitive: Triangles, attributes: fromList [Tuple "position" TV3F]}
                           , Tuple "grid3d"  {primitive: Points,    attributes: fromList [Tuple "position" TV3F]}
                           , Tuple "quad"    {primitive: Triangles, attributes: fromList [Tuple "position" TV2F]}
                           , Tuple "cube"    {primitive: Triangles, attributes: fromList [Tuple "position"  TV3F, Tuple "normal" TV3F]}
                           ]
        , uniforms : fromList [Tuple "MVP" M44F, Tuple "MVP2" M44F, Tuple "Time" Float, Tuple "Mouse" V2F]
        }
  pplInput <- mkWebGLPipelineInput inputSchema
  let toLCMat4 :: Mat4 -> M44F
      toLCMat4 (Mat [x11, x21, x31, x41, x12, x22, x32, x42, x13, x23, x33, x43, x14, x24, x34, x44]) = let
          v1 = V4 x11 x21 x31 x41
          v2 = V4 x12 x22 x32 x42
          v3 = V4 x13 x23 x33 x43
          v4 = V4 x14 x24 x34 x44
        in V4 v1 v2 v3 v4

      updateInput t = do
        w <- GL.getCanvasWidth context
        h <- GL.getCanvasHeight context
        setScreenSize pplInput (V2 w h)
        let pi = 3.141592653589793
            angle = pi / 24 * t
            cm = makeLookAt (vec3 3 1.3 0.3) (vec3 0 0 0) (vec3 0 1 0)
            mm = makeRotate angle (vec3 0 1 0)
            pm = makePerspective 30 (w/h) 0.1 100
            mvp = pm `mul` cm `mul` mm
            cm' = makeLookAt (vec3 4 0.5 (-0.6)) (vec3 0 0 0) (vec3 0 1 0)
            mvp2 = pm `mul` cm' `mul` mm

        uniformFloat "Time" pplInput.uniformSetter t
        uniformM44F "MVP" pplInput.uniformSetter $ toLCMat4 mvp
        uniformM44F "MVP2" pplInput.uniformSetter $ toLCMat4 mvp2

  gpuCube <- compileMesh myCube
  addMesh pplInput "stream4" gpuCube []

  gpuQuad <- compileMesh myQuad
  addMesh pplInput "quad" gpuQuad []

  let addRemoteModel sname uri = getJSON uri $ \m -> do
        case A.decodeJson m of
          Left e -> trace $ "decode error: " ++ e
          Right (MeshData mesh) -> do
            gpuMesh <- compileMesh mesh
            addMesh pplInput sname gpuMesh []
            sortSlotObjects pplInput
            return unit

  --addRemoteModel "grid3d" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/grid3d.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/logo2.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/logo3.mesh.json"
{-
  addRemoteModel "quad"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/quad.mesh.json"
  addRemoteModel "grid"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/grid.mesh.json"
  addRemoteModel "line"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/line.mesh.json"
  addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/ico.mesh.json"
-}
  -- setup ace editor
  editor <- Ace.edit "editor" ace
  session <- Editor.getSession editor
  Editor.setTheme "ace/theme/terminal" editor
  Session.setMode "ace/mode/haskell" session
  Session.setValue defaultSrc session
  typeInfoRef <- newRef []
  markerRef <- newRef []
  let lessEqPos l c l' c' = l < l' || l == l' && c <= c'
  let lessPos l c l' c' = l < l' || l == l' && c < c'
  let getTypeInfo l c = do
        x <- readRef typeInfoRef
        let ps = flip filter x $ \(TypeInfo i) -> lessEqPos i.startLine i.startColumn l c && lessPos l c i.endLine i.endColumn
        let f Nothing (TypeInfo i) = Just i
            f (Just d) (TypeInfo i)
                | lessPos d.startLine d.startColumn i.startLine i.startColumn = Just i
                | otherwise = Just d
        return $ case foldl f Nothing ps of
          Nothing ->
              { startLine   : 0
              , startColumn : 0
              , endLine     : 0
              , endColumn   : 0
              , text        : ""
              }
          Just a -> a
  tokenTooltip editor getTypeInfo

  b <- J.body
  messagepanel <- J.find "#messagepanel" b
  statuspanel <- J.find "#statuspanel" b
  btnCompile <- J.find "#compilebutton" b
  exerciseselect <- J.find "#exerciseselect" b
  glcanvas <- J.find "#glcanvas" b
  flip (J.on "mousemove") glcanvas $ \e _ -> do
    w <- GL.getCanvasWidth context
    h <- GL.getCanvasHeight context
    [x,y] <- getMousePos e
    uniformV2F "Mouse" pplInput.uniformSetter $ V2 (x/w) (y/h)

  pipelineRef <- newRef Nothing
  let compile s = do
        trace "compile"
        J.setText "Compiling..." statuspanel
        src <- Session.getValue session
        send s src

      render ir = do
        old <- readRef pipelineRef
        writeRef pipelineRef Nothing
        case old of
          Nothing -> return unit
          Just p -> do
            trace "dispose old pipeline"
            disposePipeline p
        trace "allocate new pipeline"
        ppl <- allocPipeline ir
        trace "attach pipeline input"
        setPipelineInput ppl (Just pplInput)
        trace "generate object commands"
        sortSlotObjects pplInput
        writeRef pipelineRef $ Just ppl

  socket1 <- webSocket "ws://localhost:8000/exerciselist" $
    { onOpen    : \s -> do
        send s "query"
        trace "socket1 is ready"
        return unit
    , onMessage : \s m -> case A.jsonParser m >>= A.decodeJson of
          Left e -> trace $ "decode error: " ++ e
          Right es -> do
            for_ (es :: [String]) $ \e -> do
                op <- J.create "<option></option>"
                J.setText e op
                J.append op exerciseselect
            return unit
    , onError   : \s m -> trace m
    , onClose   : trace "socket1 is closed"
    }

  socket <- webSocket "ws://localhost:8000/compile" $
    { onOpen    : \s -> do
        trace "socket is ready"
        compile s
        timerRef <- newRef Nothing
        Session.onChange session $ do
          t <- readRef timerRef
          case t of
            Nothing -> return unit
            Just a -> clearTimeout a
          writeRef timerRef =<< Just <$> timeout 1000 (compile s)

    , onClose   : trace "socket is closed"
    , onMessage : \s m -> do
        trace "got response"
        case A.jsonParser m >>= A.decodeJson of
          Left e -> trace $ "decode error: " ++ e
          Right (MyLeft (TypeInfo e) infos) -> do
            J.setText "Error" statuspanel
            J.setText e.text messagepanel
            range <- Range.create (e.startLine - 1) (e.startColumn - 1) (e.endLine - 1) (e.endColumn - 1)
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            mkr <- addMarker range "lc_error" "text" false session
            writeRef markerRef [mkr]
            writeRef typeInfoRef infos
            return unit
          Right (MyRight p infos) -> do
            J.setText "Compiled" statuspanel
            J.setText "No errors." messagepanel
            writeRef typeInfoRef infos
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            writeRef markerRef []
            render p
    , onError   : \s m -> trace $ "error: " ++ m
    }
  case socket of
    Left m -> trace $ "error: " ++ m
    Right ws -> do

      socket2 <- webSocket "ws://localhost:8000/getexercise" $
        { onOpen    : \s -> do
            trace "socket2 is ready"
            flip (J.on "change") exerciseselect $ \_ _ -> do
                sel <- J.find ":selected" exerciseselect
                txt <- J.getText sel
                send s txt
            return unit
        , onMessage : \s m -> case A.jsonParser m >>= A.decodeJson of
              Left e -> trace $ "decode error: " ++ e
              Right src -> do
                Session.setValue src session
                compile ws
                return unit
        , onError   : \s m -> trace m
        , onClose   : trace "socket2 is closed"
        }

      flip (J.on "click") btnCompile $ \_ _ -> do
        compile ws
        trace "clicked compile"
      addCommand editor "Compile" "Ctrl-B" "Command-B" (\_ -> compile ws)
      let renderLoop = do
            Milliseconds t <- nowEpochMilliseconds
            updateInput ((t - baseTime) / 1000)
            mppl <- readRef pipelineRef
            case mppl of
              Nothing -> return unit
              Just ppl -> renderPipeline ppl
            timeout (1000/25) renderLoop
      -- render loop
      renderLoop
      return unit

module Main (main,run) where

import Debug.Trace

import Control.Bind
import Control.Timer (timeout,clearTimeout)
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Data.Date
import Data.Time
import Data.Foldable (for_, foldl)

import Ace
import Ace.Types
import qualified Ace.Editor as Editor
import qualified Ace.EditSession as Session
import qualified Ace.Range as Range

import qualified Graphics.WebGL as GL
import qualified Control.Monad.JQuery as J

import WebSocket
import DefaultText
import Data.Either
import Sample

import Data.Function
import Data.Maybe
import Data.StrMap
import Data.Tuple
import Data.Array(filter,head)

import Backend
import IR
import Mesh
import Type
import Input

import MeshJsonDecode
import PipelineJsonDecode
import qualified Data.Argonaut as A
import qualified Data.Argonaut.Core as AC

import Data.Matrix (Mat(..))
import Data.Matrix4
import Data.Vector3

import qualified DOM as DOM

main = return unit

foreign import getMousePos """
  function getMousePos(e) {
      return function() {
        var mouseX, mouseY;

        if(e.offsetX) {
            mouseX = e.offsetX;
            mouseY = e.offsetY;
        }
        else if(e.layerX) {
            mouseX = e.layerX;
            mouseY = e.layerY;
        }
        return [mouseX,mouseY];
      };
  }
""" :: forall eff a. J.JQueryEvent -> Eff (dom :: DOM.DOM | eff) [Number]

foreign import getJSON """
  function getJSON(uri) {
    return function(act) {
      return function() {
        $.getJSON(uri, function(data) {
          act(data)();
        });
      };
    };
  }
""" :: forall eff a. String -> (AC.Json -> Eff (dom :: DOM.DOM | eff) a) -> Eff (dom :: DOM.DOM | eff) Unit

{-
  control-b - compile/build
  control-n - new
-}
foreign import addCommand """
  function addCommand(editor) {
    return function(cmdName) {
      return function(winKey) {
        return function(macKey) {
          return function(cmd) {
            return function() {
              editor.commands.addCommand({
                name: cmdName,
                bindKey: {win: winKey,  mac: macKey},
                exec: function(editor) {
                  cmd(editor)();
                }
              });
            };
          };
        };
      };
    };
  }
""" :: forall eff . Editor -> String -> String -> String -> (Editor -> Eff (ace :: EAce | eff) Unit) -> Eff (ace :: EAce | eff) Unit

foreign import tokenTooltip """
  function tokenTooltip(editor) {
    return function(getTy) {
      return function() {
          editor.tokenTooltip = new myTokenTooltip(editor,getTy);
      };
    };
  }
""" :: forall eff . Editor -> (Int -> Int -> Eff (ace :: EAce | eff) TypeInfoRecord) -> Eff (ace :: EAce | eff) Unit

foreign import add
  """
  function add(ob1) {
    return function(ob) {
      return function () {
        return ob.add(ob1);
      };
    };
  }
  """ :: forall eff. J.JQuery -> J.JQuery -> Eff (dom :: DOM.DOM | eff) J.JQuery

foreign import addMarkerImpl
  "function addMarkerImpl(range, clazz, type, inFront, self) {\
  \  return function() {\
  \    return self.addMarker(range, clazz, type, inFront);\
  \  };\
  \}" :: forall eff. Fn5 Range String String Boolean EditSession (Eff (ace :: EAce | eff) Int)

addMarker :: forall eff. Range -> String -> String -> Boolean -> EditSession -> Eff (ace :: EAce | eff) Int
addMarker range clazz _type inFront self = runFn5 addMarkerImpl range clazz _type inFront self

run = GL.runWebGL "glcanvas" (\s -> trace s) $ \context -> do
  Milliseconds baseTime <- nowEpochMilliseconds
  -- setup pipeline input
  let inputSchema =
        { slots : fromList [ Tuple "stream"  {primitive: Triangles, attributes: fromList [Tuple "position"  TV3F, Tuple "normal" TV3F]}
                           , Tuple "stream4" {primitive: Triangles, attributes: fromList [Tuple "position4" TV4F, Tuple "vertexUV" TV2F]}
                           , Tuple "line"    {primitive: Triangles, attributes: fromList [Tuple "position" TV3F]}
                           , Tuple "grid"    {primitive: Triangles, attributes: fromList [Tuple "position" TV3F]}
                           , Tuple "grid3d"  {primitive: Points,    attributes: fromList [Tuple "position" TV3F]}
                           , Tuple "quad"    {primitive: Triangles, attributes: fromList [Tuple "position" TV2F]}
                           , Tuple "cube"    {primitive: Triangles, attributes: fromList [Tuple "position"  TV3F, Tuple "normal" TV3F]}
                           ]
        , uniforms : fromList [Tuple "MVP" M44F, Tuple "MVP2" M44F, Tuple "Time" Float, Tuple "Mouse" V2F]
        }
  pplInput <- mkWebGLPipelineInput inputSchema
  let toLCMat4 :: Mat4 -> M44F
      toLCMat4 (Mat [x11, x21, x31, x41, x12, x22, x32, x42, x13, x23, x33, x43, x14, x24, x34, x44]) = let
          v1 = V4 x11 x21 x31 x41
          v2 = V4 x12 x22 x32 x42
          v3 = V4 x13 x23 x33 x43
          v4 = V4 x14 x24 x34 x44
        in V4 v1 v2 v3 v4

      updateInput t = do
        w <- GL.getCanvasWidth context
        h <- GL.getCanvasHeight context
        setScreenSize pplInput (V2 w h)
        let pi = 3.141592653589793
            angle = pi / 24 * t
            cm = makeLookAt (vec3 3 1.3 0.3) (vec3 0 0 0) (vec3 0 1 0)
            mm = makeRotate angle (vec3 0 1 0)
            pm = makePerspective 45 (w/h) 0.1 100
            mvp = pm `mul` cm `mul` mm
            cm' = makeLookAt (vec3 4 0.5 (-0.6)) (vec3 0 0 0) (vec3 0 1 0)
            mvp2 = pm `mul` cm' `mul` mm

        uniformFloat "Time" pplInput.uniformSetter t
        uniformM44F "MVP" pplInput.uniformSetter $ toLCMat4 mvp
        uniformM44F "MVP2" pplInput.uniformSetter $ toLCMat4 mvp2

  gpuCube <- compileMesh myCube
  addMesh pplInput "stream4" gpuCube []

  gpuQuad <- compileMesh myQuad
  addMesh pplInput "quad" gpuQuad []

  let addRemoteModel sname uri = getJSON uri $ \m -> do
        case A.decodeJson m of
          Left e -> trace $ "decode error: " ++ e
          Right (MeshData mesh) -> do
            gpuMesh <- compileMesh mesh
            addMesh pplInput sname gpuMesh []
            sortSlotObjects pplInput
            return unit

  --addRemoteModel "grid3d" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/grid3d.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/logo2.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/logo3.mesh.json"
{-
  addRemoteModel "quad"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/quad.mesh.json"
  addRemoteModel "grid"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/grid.mesh.json"
  addRemoteModel "line"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/line.mesh.json"
  addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/ico.mesh.json"
-}
  -- setup ace editor
  editor <- Ace.edit "editor" ace
  session <- Editor.getSession editor
  Editor.setTheme "ace/theme/terminal" editor
  Session.setMode "ace/mode/haskell" session
  Session.setValue defaultSrc session
  typeInfoRef <- newRef []
  markerRef <- newRef []
  let lessEqPos l c l' c' = l < l' || l == l' && c <= c'
  let lessPos l c l' c' = l < l' || l == l' && c < c'
  let getTypeInfo l c = do
        x <- readRef typeInfoRef
        let ps = flip filter x $ \(TypeInfo i) -> lessEqPos i.startLine i.startColumn l c && lessPos l c i.endLine i.endColumn
        let f Nothing (TypeInfo i) = Just i
            f (Just d) (TypeInfo i)
                | lessPos d.startLine d.startColumn i.startLine i.startColumn = Just i
                | otherwise = Just d
        return $ case foldl f Nothing ps of
          Nothing ->
              { startLine   : 0
              , startColumn : 0
              , endLine     : 0
              , endColumn   : 0
              , text        : ""
              }
          Just a -> a
  tokenTooltip editor getTypeInfo

  b <- J.body
  messagepanel <- J.find "#messagepanel" b
  statuspanel <- J.find "#statuspanel" b
  btnCompile <- J.find "#compilebutton" b
  exerciseselect <- J.find "#exerciseselect" b
  glcanvas <- J.find "#glcanvas" b
  flip (J.on "mousemove") glcanvas $ \e _ -> do
    w <- GL.getCanvasWidth context
    h <- GL.getCanvasHeight context
    [x,y] <- getMousePos e
    uniformV2F "Mouse" pplInput.uniformSetter $ V2 (x/w) (y/h)

  pipelineRef <- newRef Nothing
  let compile s = do
        trace "compile"
        J.setText "Compiling..." statuspanel
        src <- Session.getValue session
        send s src

      render ir = do
        old <- readRef pipelineRef
        writeRef pipelineRef Nothing
        case old of
          Nothing -> return unit
          Just p -> do
            trace "dispose old pipeline"
            disposePipeline p
        trace "allocate new pipeline"
        ppl <- allocPipeline ir
        trace "attach pipeline input"
        setPipelineInput ppl (Just pplInput)
        trace "generate object commands"
        sortSlotObjects pplInput
        writeRef pipelineRef $ Just ppl

  socket1 <- webSocket "ws://localhost:8000/exerciselist" $
    { onOpen    : \s -> do
        send s "query"
        trace "socket1 is ready"
        return unit
    , onMessage : \s m -> case A.jsonParser m >>= A.decodeJson of
          Left e -> trace $ "decode error: " ++ e
          Right es -> do
            for_ (es :: [String]) $ \e -> do
                op <- J.create "<option></option>"
                J.setText e op
                J.append op exerciseselect
            return unit
    , onError   : \s m -> trace m
    , onClose   : trace "socket1 is closed"
    }

  socket <- webSocket "ws://localhost:8000/compile" $
    { onOpen    : \s -> do
        trace "socket is ready"
        compile s
        timerRef <- newRef Nothing
        Session.onChange session $ do
          t <- readRef timerRef
          case t of
            Nothing -> return unit
            Just a -> clearTimeout a
          writeRef timerRef =<< Just <$> timeout 1000 (compile s)

    , onClose   : trace "socket is closed"
    , onMessage : \s m -> do
        trace "got response"
        case A.jsonParser m >>= A.decodeJson of
          Left e -> trace $ "decode error: " ++ e
          Right (MyLeft (TypeInfo e) infos) -> do
            J.setText "Error" statuspanel
            J.setText e.text messagepanel
            range <- Range.create (e.startLine - 1) (e.startColumn - 1) (e.endLine - 1) (e.endColumn - 1)
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            mkr <- addMarker range "lc_error" "text" false session
            writeRef markerRef [mkr]
            writeRef typeInfoRef infos
            return unit
          Right (MyRight p infos) -> do
            J.setText "Compiled" statuspanel
            J.setText "No errors." messagepanel
            writeRef typeInfoRef infos
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            writeRef markerRef []
            render p
    , onError   : \s m -> trace $ "error: " ++ m
    }
  case socket of
    Left m -> trace $ "error: " ++ m
    Right ws -> do

      socket2 <- webSocket "ws://localhost:8000/getexercise" $
        { onOpen    : \s -> do
            trace "socket2 is ready"
            flip (J.on "change") exerciseselect $ \_ _ -> do
                sel <- J.find ":selected" exerciseselect
                txt <- J.getText sel
                send s txt
            return unit
        , onMessage : \s m -> case A.jsonParser m >>= A.decodeJson of
              Left e -> trace $ "decode error: " ++ e
              Right src -> do
                Session.setValue src session
                compile ws
                return unit
        , onError   : \s m -> trace m
        , onClose   : trace "socket2 is closed"
        }

      flip (J.on "click") btnCompile $ \_ _ -> do
        compile ws
        trace "clicked compile"
      addCommand editor "Compile" "Ctrl-B" "Command-B" (\_ -> compile ws)
      let renderLoop = do
            Milliseconds t <- nowEpochMilliseconds
            updateInput ((t - baseTime) / 1000)
            mppl <- readRef pipelineRef
            case mppl of
              Nothing -> return unit
              Just ppl -> renderPipeline ppl
            timeout (1000/25) renderLoop
      -- render loop
      renderLoop
      return unit


Clarify what causes nesting in Array's Bind instance explanation

module Control.Bind
  ( class Bind, bind, (>>=)
  , bindFlipped, (=<<)
  , class Discard, discard
  , join
  , composeKleisli, (>=>)
  , composeKleisliFlipped, (<=<)
  , ifM
  , module Data.Functor
  , module Control.Apply
  , module Control.Applicative
  ) where

import Control.Applicative (class Applicative, liftA1, pure, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Category (identity)

import Data.Function (flip)
import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit)

-- | The `Bind` type class extends the [`Apply`](#apply) type class with a
-- | "bind" operation `(>>=)` which composes computations in sequence, using
-- | the return value of one computation to determine the next computation.
-- |
-- | The `>>=` operator can also be expressed using `do` notation, as follows:
-- |
-- | ```purescript
-- | x >>= f = do y <- x
-- |              f y
-- | ```
-- |
-- | where the function argument of `f` is given the name `y`.
-- |
-- | Instances must satisfy the following law in addition to the `Apply`
-- | laws:
-- |
-- | - Associativity: `(x >>= f) >>= g = x >>= (\k -> f k >>= g)`
-- |
-- | Associativity tells us that we can regroup operations which use `do`
-- | notation so that we can unambiguously write, for example:
-- |
-- | ```purescript
-- | do x <- m1
-- |    y <- m2 x
-- |    m3 x y
-- | ```
class Apply m <= Bind m where
  bind :: forall a b. m a -> (a -> m b) -> m b

infixl 1 bind as >>=

-- | `bindFlipped` is `bind` with its arguments reversed. For example:
-- |
-- | ```purescript
-- | print =<< random
-- | ```
bindFlipped :: forall m a b. Bind m => (a -> m b) -> m a -> m b
bindFlipped = flip bind

infixr 1 bindFlipped as =<<

instance bindFn :: Bind ((->) r) where
  bind m f x = f (m x) x

-- | The `Array` monad's "do notation" works like a nested for loop. Each
-- | `bind`/`elem <- array` adds another level of nesting in the loop:
-- | ```
-- | foo :: Array Int
-- | foo = do
-- |   eachElementInArray1 <- [0, 1]
-- |   eachElementInArray2 <- [1, 2]
-- |   pure (eachElementInArray1 + eachElementInArray2)
-- |
-- | foo == [(0 + 1), (0 + 2), (1 + 1), (1 + 2)] == [1, 2, 2, 3]
-- | ```
instance bindArray :: Bind Array where
  bind = arrayBind

foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b

-- | A class for types whose values can safely be discarded
-- | in a `do` notation block.
-- |
-- | An example is the `Unit` type, since there is only one
-- | possible value which can be returned.
class Discard a where
  discard :: forall f b. Bind f => f a -> (a -> f b) -> f b

instance discardUnit :: Discard Unit where
  discard = bind

-- | Collapse two applications of a monadic type constructor into one.
join :: forall a m. Bind m => m (m a) -> m a
join m = m >>= identity

-- | Forwards Kleisli composition.
-- |
-- | For example:
-- |
-- | ```purescript
-- | import Data.Array (head, tail)
-- |
-- | third = tail >=> tail >=> head
-- | ```
composeKleisli :: forall a b c m. Bind m => (a -> m b) -> (b -> m c) -> a -> m c
composeKleisli f g a = f a >>= g

infixr 1 composeKleisli as >=>

-- | Backwards Kleisli composition.
composeKleisliFlipped :: forall a b c m. Bind m => (b -> m c) -> (a -> m b) -> a -> m c
composeKleisliFlipped f g a = f =<< g a

infixr 1 composeKleisliFlipped as <=<

-- | Execute a monadic action if a condition holds.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = ifM ((< 0.5) <$> random)
-- |          (trace "Heads")
-- |          (trace "Tails")
-- | ```
ifM :: forall a m. Bind m => m Boolean -> m a -> m a -> m a
ifM cond t f = cond >>= \cond' -> if cond' then t else f

module Control.Bind
  ( class Bind, bind, (>>=)
  , bindFlipped, (=<<)
  , class Discard, discard
  , join
  , composeKleisli, (>=>)
  , composeKleisliFlipped, (<=<)
  , ifM
  , module Data.Functor
  , module Control.Apply
  , module Control.Applicative
  ) where

import Control.Applicative (class Applicative, liftA1, pure, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Category (identity)

import Data.Function (flip)
import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit)

-- | The `Bind` type class extends the [`Apply`](#apply) type class with a
-- | "bind" operation `(>>=)` which composes computations in sequence, using
-- | the return value of one computation to determine the next computation.
-- |
-- | The `>>=` operator can also be expressed using `do` notation, as follows:
-- |
-- | ```purescript
-- | x >>= f = do y <- x
-- |              f y
-- | ```
-- |
-- | where the function argument of `f` is given the name `y`.
-- |
-- | Instances must satisfy the following law in addition to the `Apply`
-- | laws:
-- |
-- | - Associativity: `(x >>= f) >>= g = x >>= (\k -> f k >>= g)`
-- |
-- | Associativity tells us that we can regroup operations which use `do`
-- | notation so that we can unambiguously write, for example:
-- |
-- | ```purescript
-- | do x <- m1
-- |    y <- m2 x
-- |    m3 x y
-- | ```
class Apply m <= Bind m where
  bind :: forall a b. m a -> (a -> m b) -> m b

infixl 1 bind as >>=

-- | `bindFlipped` is `bind` with its arguments reversed. For example:
-- |
-- | ```purescript
-- | print =<< random
-- | ```
bindFlipped :: forall m a b. Bind m => (a -> m b) -> m a -> m b
bindFlipped = flip bind

infixr 1 bindFlipped as =<<

instance bindFn :: Bind ((->) r) where
  bind m f x = f (m x) x

-- | The `Array` monad's "do notation" works like a nested for loop:
-- | ```
-- | foo :: Array Int
-- | foo = do
-- |   eachElementInArray1 <- [0, 1]
-- |   eachElementInArray2 <- [1, 2]
-- |   pure (eachElementInArray1 + eachElementInArray2)
-- |
-- | foo == [(0 + 1), (0 + 2), (1 + 1), (1 + 2)] == [1, 2, 2, 3]
-- | ```
instance bindArray :: Bind Array where
  bind = arrayBind

foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b

-- | A class for types whose values can safely be discarded
-- | in a `do` notation block.
-- |
-- | An example is the `Unit` type, since there is only one
-- | possible value which can be returned.
class Discard a where
  discard :: forall f b. Bind f => f a -> (a -> f b) -> f b

instance discardUnit :: Discard Unit where
  discard = bind

-- | Collapse two applications of a monadic type constructor into one.
join :: forall a m. Bind m => m (m a) -> m a
join m = m >>= identity

-- | Forwards Kleisli composition.
-- |
-- | For example:
-- |
-- | ```purescript
-- | import Data.Array (head, tail)
-- |
-- | third = tail >=> tail >=> head
-- | ```
composeKleisli :: forall a b c m. Bind m => (a -> m b) -> (b -> m c) -> a -> m c
composeKleisli f g a = f a >>= g

infixr 1 composeKleisli as >=>

-- | Backwards Kleisli composition.
composeKleisliFlipped :: forall a b c m. Bind m => (b -> m c) -> (a -> m b) -> a -> m c
composeKleisliFlipped f g a = f =<< g a

infixr 1 composeKleisliFlipped as <=<

-- | Execute a monadic action if a condition holds.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = ifM ((< 0.5) <$> random)
-- |          (trace "Heads")
-- |          (trace "Tails")
-- | ```
ifM :: forall a m. Bind m => m Boolean -> m a -> m a -> m a
ifM cond t f = cond >>= \cond' -> if cond' then t else f


Add Unfoldable1 instance for CatList

Add Unfoldable1 instance for CatList

-- | This module defines a strict catenable list.
-- |
-- | The implementation is based on a queue where all operations require
-- | `O(1)` amortized time.
-- |
-- | However, any single `uncons` operation may run in `O(n)` time.
-- |
-- | See [Purely Functional Data Structures](http://www.cs.cmu.edu/~rwh/theses/okasaki.pdf) (Okasaki 1996)
module Data.CatList
  ( CatList(..)
  , empty
  , null
  , singleton
  , append
  , cons
  , snoc
  , uncons
  , fromFoldable
  ) where

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Applicative (pure, class Applicative)
import Control.Apply ((<*>), class Apply)
import Control.Bind (class Bind)
import Control.Monad (ap, class Monad)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)
import Data.CatQueue as Q
import Data.Foldable (class Foldable)
import Data.Foldable as Foldable
import Data.Function (flip)
import Data.Functor ((<$>), class Functor)
import Data.List as L
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty, class Monoid)
import Data.NaturalTransformation (type (~>))
import Data.Semigroup (class Semigroup, (<>))
import Data.Show (class Show, show)
import Data.Traversable (sequence, traverse, class Traversable)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable)
import Data.Unfoldable1 (class Unfoldable1)

-- | A strict catenable list.
-- |
-- | `CatList` may be empty, represented by `CatNil`.
-- |
-- | `CatList` may be non-empty, represented by `CatCons`. The `CatCons`
-- | data constructor takes the first element of the list and a queue of
-- | `CatList`.
data CatList a = CatNil | CatCons a (Q.CatQueue (CatList a))

-- | Create an empty catenable list.
-- |
-- | Running time: `O(1)`
empty :: forall a. CatList a
empty = CatNil

-- | Test whether a catenable list is empty.
-- |
-- | Running time: `O(1)`
null :: forall a. CatList a -> Boolean
null CatNil = true
null _ = false

-- | Append all elements of a catenable list to the end of another
-- | catenable list, create a new catenable list.
-- |
-- | Running time: `O(1)`
append :: forall a. CatList a -> CatList a -> CatList a
append as CatNil = as
append CatNil as = as
append as bs = link as bs

-- | Append an element to the beginning of the catenable list, creating a new
-- | catenable list.
-- |
-- | Running time: `O(1)`
cons :: forall a. a -> CatList a -> CatList a
cons a cat = append (CatCons a Q.empty) cat

-- | Create a catenable list with a single item.
-- |
-- | Running time: `O(1)`
singleton :: forall a. a -> CatList a
singleton a = cons a CatNil

-- | Append an element to the end of the catenable list, creating a new
-- | catenable list.
-- |
-- | Running time: `O(1)`
snoc :: forall a. CatList a -> a -> CatList a
snoc cat a = append cat (CatCons a Q.empty)

-- | Decompose a catenable list into a `Tuple` of the first element and
-- | the rest of the catenable list.
-- |
-- | Running time: `O(1)`
-- |
-- | Note that any single operation may run in `O(n)`.
uncons :: forall a. CatList a -> Maybe (Tuple a (CatList a))
uncons CatNil = Nothing
uncons (CatCons a q) = Just (Tuple a (if Q.null q then CatNil else (foldr link CatNil q)))

-- | Links two catenable lists by making appending the queue in the
-- | first catenable list to the second catenable list. This operation
-- | creates a new catenable list.
-- |
-- | Running time: `O(1)`
link :: forall a. CatList a -> CatList a -> CatList a
link CatNil cat = cat
link (CatCons a q) cat = CatCons a (Q.snoc q cat)

-- | Tail recursive version of foldr on `CatList`.
-- |
-- | Ensures foldl on `List` is tail-recursive.
foldr :: forall a. (CatList a -> CatList a -> CatList a) -> CatList a -> Q.CatQueue (CatList a) -> CatList a
foldr k b q = go q L.Nil
  where
  go :: Q.CatQueue (CatList a) -> L.List (CatList a -> CatList a) -> CatList a
  go xs ys = case Q.uncons xs of
                  Nothing -> foldl (\x i -> i x) b ys
                  Just (Tuple a rest) -> go rest (L.Cons (k a) ys)

  foldl :: forall b c. (c -> b -> c) -> c -> L.List b -> c
  foldl _ c L.Nil = c
  foldl k' c (L.Cons b' as) = foldl k' (k' c b') as

-- | Convert any `Foldable` into a `CatList`.
-- |
-- | Running time: `O(n)`
fromFoldable :: forall f. Foldable f => f ~> CatList
fromFoldable f = Foldable.foldMap singleton f

map :: forall a b. (a -> b) -> CatList a -> CatList b
map _ CatNil = CatNil
map f (CatCons a q) =
  let d = if Q.null q then CatNil else (foldr link CatNil q)
  in f a `cons` map f d

foldMap :: forall a m. Monoid m => (a -> m) -> CatList a -> m
foldMap f CatNil = mempty
foldMap f (CatCons a q) =
  let d = if Q.null q then CatNil else (foldr link CatNil q)
  in f a <> foldMap f d

instance semigroupCatList :: Semigroup (CatList a) where
  append = append

instance monoidCatList :: Monoid (CatList a) where
  mempty = CatNil

instance showCatList :: Show a => Show (CatList a) where
  show CatNil = "CatNil"
  show (CatCons a as) = "(CatList " <> show a <> " " <> show as <> ")"

instance foldableCatList :: Foldable CatList where
  foldMap f l = foldMap f l
  foldl f s l = Foldable.foldlDefault f s l
  foldr f s l = Foldable.foldrDefault f s l

instance unfoldableCatList :: Unfoldable CatList where
  unfoldr f b = go b CatNil
    where
      go source memo = case f source of
        Nothing -> memo
        Just (Tuple one rest) -> go rest (snoc memo one)

instance unfoldable1CatList :: Unfoldable1 CatList where
  unfoldr1 f b = go b CatNil
    where
      go source memo = case f source of
        Tuple one Nothing -> snoc memo one
        Tuple one (Just rest) -> go rest (snoc memo one)

instance traversableCatList :: Traversable CatList where
  traverse _ CatNil = pure CatNil
  traverse f (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in cons <$> f a <*> traverse f d
  sequence CatNil = pure CatNil
  sequence (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in cons <$> a <*> sequence d

instance functorCatList :: Functor CatList where
  map = map

instance applyCatList :: Apply CatList where
  apply = ap

instance applicativeCatList :: Applicative CatList where
  pure = singleton

instance bindCatList :: Bind CatList where
  bind = flip foldMap

instance monadCatList :: Monad CatList

instance altCatList :: Alt CatList where
  alt = append

instance plusCatList :: Plus CatList where
  empty = empty

instance alternativeCatList :: Alternative CatList

instance monadZeroCatList :: MonadZero CatList

instance monadPlusCatList :: MonadPlus CatList

-- | This module defines a strict catenable list.
-- |
-- | The implementation is based on a queue where all operations require
-- | `O(1)` amortized time.
-- |
-- | However, any single `uncons` operation may run in `O(n)` time.
-- |
-- | See [Purely Functional Data Structures](http://www.cs.cmu.edu/~rwh/theses/okasaki.pdf) (Okasaki 1996)
module Data.CatList
  ( CatList(..)
  , empty
  , null
  , singleton
  , append
  , cons
  , snoc
  , uncons
  , fromFoldable
  ) where

import Data.CatQueue as Q
import Data.Foldable as Foldable
import Data.List as L
import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Applicative (pure, class Applicative)
import Control.Apply ((<*>), class Apply)
import Control.Bind (class Bind)
import Control.Monad (ap, class Monad)
import Control.MonadPlus (class MonadPlus)
import Control.MonadZero (class MonadZero)
import Control.Plus (class Plus)
import Data.Foldable (class Foldable)
import Data.Function (flip)
import Data.Functor ((<$>), class Functor)
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty, class Monoid)
import Data.NaturalTransformation (type (~>))
import Data.Semigroup (class Semigroup, (<>))
import Data.Show (class Show, show)
import Data.Traversable (sequence, traverse, class Traversable)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable)

-- | A strict catenable list.
-- |
-- | `CatList` may be empty, represented by `CatNil`.
-- |
-- | `CatList` may be non-empty, represented by `CatCons`. The `CatCons`
-- | data constructor takes the first element of the list and a queue of
-- | `CatList`.
data CatList a = CatNil | CatCons a (Q.CatQueue (CatList a))

-- | Create an empty catenable list.
-- |
-- | Running time: `O(1)`
empty :: forall a. CatList a
empty = CatNil

-- | Test whether a catenable list is empty.
-- |
-- | Running time: `O(1)`
null :: forall a. CatList a -> Boolean
null CatNil = true
null _ = false

-- | Append all elements of a catenable list to the end of another
-- | catenable list, create a new catenable list.
-- |
-- | Running time: `O(1)`
append :: forall a. CatList a -> CatList a -> CatList a
append as CatNil = as
append CatNil as = as
append as bs = link as bs

-- | Append an element to the beginning of the catenable list, creating a new
-- | catenable list.
-- |
-- | Running time: `O(1)`
cons :: forall a. a -> CatList a -> CatList a
cons a cat = append (CatCons a Q.empty) cat

-- | Create a catenable list with a single item.
-- |
-- | Running time: `O(1)`
singleton :: forall a. a -> CatList a
singleton a = cons a CatNil

-- | Append an element to the end of the catenable list, creating a new
-- | catenable list.
-- |
-- | Running time: `O(1)`
snoc :: forall a. CatList a -> a -> CatList a
snoc cat a = append cat (CatCons a Q.empty)

-- | Decompose a catenable list into a `Tuple` of the first element and
-- | the rest of the catenable list.
-- |
-- | Running time: `O(1)`
-- |
-- | Note that any single operation may run in `O(n)`.
uncons :: forall a. CatList a -> Maybe (Tuple a (CatList a))
uncons CatNil = Nothing
uncons (CatCons a q) = Just (Tuple a (if Q.null q then CatNil else (foldr link CatNil q)))

-- | Links two catenable lists by making appending the queue in the
-- | first catenable list to the second catenable list. This operation
-- | creates a new catenable list.
-- |
-- | Running time: `O(1)`
link :: forall a. CatList a -> CatList a -> CatList a
link CatNil cat = cat
link (CatCons a q) cat = CatCons a (Q.snoc q cat)

-- | Tail recursive version of foldr on `CatList`.
-- |
-- | Ensures foldl on `List` is tail-recursive.
foldr :: forall a. (CatList a -> CatList a -> CatList a) -> CatList a -> Q.CatQueue (CatList a) -> CatList a
foldr k b q = go q L.Nil
  where
  go :: Q.CatQueue (CatList a) -> L.List (CatList a -> CatList a) -> CatList a
  go xs ys = case Q.uncons xs of
                  Nothing -> foldl (\x i -> i x) b ys
                  Just (Tuple a rest) -> go rest (L.Cons (k a) ys)

  foldl :: forall b c. (c -> b -> c) -> c -> L.List b -> c
  foldl _ c L.Nil = c
  foldl k' c (L.Cons b' as) = foldl k' (k' c b') as

-- | Convert any `Foldable` into a `CatList`.
-- |
-- | Running time: `O(n)`
fromFoldable :: forall f. Foldable f => f ~> CatList
fromFoldable f = Foldable.foldMap singleton f

map :: forall a b. (a -> b) -> CatList a -> CatList b
map _ CatNil = CatNil
map f (CatCons a q) =
  let d = if Q.null q then CatNil else (foldr link CatNil q)
  in f a `cons` map f d

foldMap :: forall a m. Monoid m => (a -> m) -> CatList a -> m
foldMap f CatNil = mempty
foldMap f (CatCons a q) =
  let d = if Q.null q then CatNil else (foldr link CatNil q)
  in f a <> foldMap f d

instance semigroupCatList :: Semigroup (CatList a) where
  append = append

instance monoidCatList :: Monoid (CatList a) where
  mempty = CatNil

instance showCatList :: Show a => Show (CatList a) where
  show CatNil = "CatNil"
  show (CatCons a as) = "(CatList " <> show a <> " " <> show as <> ")"

instance foldableCatList :: Foldable CatList where
  foldMap f l = foldMap f l
  foldl f s l = Foldable.foldlDefault f s l
  foldr f s l = Foldable.foldrDefault f s l

instance unfoldableCatList :: Unfoldable CatList where
  unfoldr f b = go b CatNil
    where
      go source memo = case f source of
        Nothing -> memo
        Just (Tuple one rest) -> go rest (snoc memo one)

instance traversableCatList :: Traversable CatList where
  traverse _ CatNil = pure CatNil
  traverse f (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in cons <$> f a <*> traverse f d
  sequence CatNil = pure CatNil
  sequence (CatCons a q) =
    let d = if Q.null q then CatNil else (foldr link CatNil q)
    in cons <$> a <*> sequence d

instance functorCatList :: Functor CatList where
  map = map

instance applyCatList :: Apply CatList where
  apply = ap

instance applicativeCatList :: Applicative CatList where
  pure = singleton

instance bindCatList :: Bind CatList where
  bind = flip foldMap

instance monadCatList :: Monad CatList

instance altCatList :: Alt CatList where
  alt = append

instance plusCatList :: Plus CatList where
  empty = empty

instance alternativeCatList :: Alternative CatList

instance monadZeroCatList :: MonadZero CatList

instance monadPlusCatList :: MonadPlus CatList


Even higher

Even higher

-- | This module defines low-level bindings to the Node HTTPS module.

module Node.HTTP.Secure
  ( createServer

  , SSLOptions
  , handshakeTimeout
  , requestCert
  , rejectUnauthorized

  , NPNProtocols
  , npnProtocolsString
  , npnProtocolsBuffer
  , npnProtocolsUint8Array
  , npnProtocolsStringArray
  , npnProtocolsBufferArray
  , npnProtocolsUint8ArrayArray
  , npnProtocols

  , ALPNProtocols
  , alpnProtocolsString
  , alpnProtocolsBuffer
  , alpnProtocolsUint8Array
  , alpnProtocolsStringArray
  , alpnProtocolsBufferArray
  , alpnProtocolsUint8ArrayArray
  , alpnProtocols

  , sessionTimeout
  , ticketKeys

  , PFX
  , pfxString
  , pfxBuffer
  , pfx

  , Key
  , keyString
  , keyBuffer
  , keyStringArray
  , keyBufferArray
  , key

  , passphrase

  , Cert
  , certString
  , certBuffer
  , certStringArray
  , certBufferArray
  , cert

  , CA
  , caString
  , caBuffer
  , caStringArray
  , caBufferArray
  , ca

  , CRL
  , crlString
  , crlBuffer
  , crlStringArray
  , crlBufferArray
  , crl

  , ciphers
  , honorCipherOrder
  , ecdhCurve

  , DHParam
  , dhparamString
  , dhparamBuffer
  , dhparam

  , secureProtocol
  , secureOptions
  , sessionIdContext
  ) where

import Prelude

import Control.Monad.Eff (Eff)
import Data.ArrayBuffer.Types (Uint8Array)
import Data.Foreign (Foreign)
import Data.Options (Options, Option, options, opt)
import Node.Buffer (Buffer)
import Node.HTTP (Request, Response, Server, HTTP)
import Unsafe.Coerce (unsafeCoerce)

-- | Create an HTTPS server, given the SSL options and a function to be executed
-- | when a request is received.
foreign import createServerImpl ::
  forall eff.
  Foreign ->
  (Request -> Response -> Eff (http :: HTTP | eff) Unit) ->
  Eff (http :: HTTP | eff) Server

-- | Create an HTTPS server, given the SSL options and a function to be executed
-- | when a request is received.
createServer :: forall eff.
                Options SSLOptions ->
                (Request -> Response -> Eff (http :: HTTP | eff) Unit) ->
                Eff (http :: HTTP | eff) Server
createServer = createServerImpl <<< options

-- | The type of HTTPS server options
data SSLOptions

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
handshakeTimeout :: Option SSLOptions Int
handshakeTimeout = opt "handshakeTimeout"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
requestCert :: Option SSLOptions Boolean
requestCert = opt "requestCert"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
rejectUnauthorized :: Option SSLOptions Boolean
rejectUnauthorized = opt "rejectUnauthorized"

-- | The npnProtocols option can be a String, a Buffer, a Uint8Array, or an
-- | array of any of those types.
data NPNProtocols
npnProtocolsString :: String -> NPNProtocols
npnProtocolsString = unsafeCoerce
npnProtocolsBuffer :: Buffer -> NPNProtocols
npnProtocolsBuffer = unsafeCoerce
npnProtocolsUint8Array :: Uint8Array -> NPNProtocols
npnProtocolsUint8Array = unsafeCoerce
npnProtocolsStringArray :: Array String -> NPNProtocols
npnProtocolsStringArray = unsafeCoerce
npnProtocolsBufferArray :: Array Buffer -> NPNProtocols
npnProtocolsBufferArray = unsafeCoerce
npnProtocolsUint8ArrayArray :: Array Uint8Array -> NPNProtocols
npnProtocolsUint8ArrayArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
npnProtocols :: Option SSLOptions NPNProtocols
npnProtocols = opt "NPNProtocols"

-- | The alpnProtocols option can be a String, a Buffer, a Uint8Array, or an
-- | array of any of those types.
data ALPNProtocols
alpnProtocolsString :: String -> ALPNProtocols
alpnProtocolsString = unsafeCoerce
alpnProtocolsBuffer :: Buffer -> ALPNProtocols
alpnProtocolsBuffer = unsafeCoerce
alpnProtocolsUint8Array :: Uint8Array -> ALPNProtocols
alpnProtocolsUint8Array = unsafeCoerce
alpnProtocolsStringArray :: Array String -> ALPNProtocols
alpnProtocolsStringArray = unsafeCoerce
alpnProtocolsBufferArray :: Array Buffer -> ALPNProtocols
alpnProtocolsBufferArray = unsafeCoerce
alpnProtocolsUint8ArrayArray :: Array Uint8Array -> ALPNProtocols
alpnProtocolsUint8ArrayArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
alpnProtocols :: Option SSLOptions ALPNProtocols
alpnProtocols = opt "ALPNProtocols"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
sessionTimeout :: Option SSLOptions Int
sessionTimeout = opt "sessionTimeout"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
ticketKeys :: Option SSLOptions Buffer
ticketKeys = opt "ticketKeys"

-- | The PFX option can take either a String or a Buffer
data PFX
pfxString :: String -> PFX
pfxString = unsafeCoerce
pfxBuffer :: Buffer -> PFX
pfxBuffer = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
pfx :: Option SSLOptions PFX
pfx = opt "pfx"

-- | The key option can be a String, a Buffer, an array of strings, or an array
-- | of buffers.
data Key
keyString :: String -> Key
keyString = unsafeCoerce
keyBuffer :: Buffer -> Key
keyBuffer = unsafeCoerce
keyStringArray :: Array String -> Key
keyStringArray = unsafeCoerce
keyBufferArray :: Array Buffer -> Key
keyBufferArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
key :: Option SSLOptions Key
key = opt "key"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
passphrase :: Option SSLOptions String
passphrase = opt "passphrase"

-- | The cert option can be a String, a Buffer, an array of strings, or an array
-- | of buffers.
data Cert
certString :: String -> Cert
certString = unsafeCoerce
certBuffer :: Buffer -> Cert
certBuffer = unsafeCoerce
certStringArray :: Array String -> Cert
certStringArray = unsafeCoerce
certBufferArray :: Array Buffer -> Cert
certBufferArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
cert :: Option SSLOptions Cert
cert = opt "cert"

-- | The CA option can be a String, a Buffer, an array of strings, or an array
-- | of buffers.
data CA
caString :: String -> CA
caString = unsafeCoerce
caBuffer :: Buffer -> CA
caBuffer = unsafeCoerce
caStringArray :: Array String -> CA
caStringArray = unsafeCoerce
caBufferArray :: Array Buffer -> CA
caBufferArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ca :: Option SSLOptions CA
ca = opt "ca"

-- | The CRL option can be a String, a Buffer, an array of strings, or an array
-- | of buffers.
data CRL
crlString :: String -> CRL
crlString = unsafeCoerce
crlBuffer :: Buffer -> CRL
crlBuffer = unsafeCoerce
crlStringArray :: Array String -> CRL
crlStringArray = unsafeCoerce
crlBufferArray :: Array Buffer -> CRL
crlBufferArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
crl :: Option SSLOptions CRL
crl = opt "crl"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ciphers :: Option SSLOptions String
ciphers = opt "ciphers"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
honorCipherOrder :: Option SSLOptions Boolean
honorCipherOrder = opt "honorCipherOrder"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ecdhCurve :: Option SSLOptions String
ecdhCurve = opt "ecdhCurve"

-- | The DHParam option can take either a String or a Buffer
data DHParam
dhparamString :: String -> DHParam
dhparamString = unsafeCoerce
dhparamBuffer :: Buffer -> DHParam
dhparamBuffer = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
dhparam :: Option SSLOptions DHParam
dhparam = opt "dhparam"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
secureProtocol :: Option SSLOptions String
secureProtocol = opt "secureProtocol"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
secureOptions :: Option SSLOptions Int
secureOptions = opt "secureOptions"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
sessionIdContext :: Option SSLOptions String
sessionIdContext = opt "sessionIdContext"

-- | This module defines low-level bindings to the Node HTTPS module.

module Node.HTTP.Secure
  ( createServer

  , SSLOptions
  , handshakeTimeout
  , requestCert
  , rejectUnauthorized

  , NPNProtocols
  , npnProtocolsString
  , npnProtocolsBuffer
  , npnProtocolsUint8Array
  , npnProtocolsStringArray
  , npnProtocolsBufferArray
  , npnProtocolsUint8ArrayArray
  , npnProtocols

  , ALPNProtocols
  , alpnProtocolsString
  , alpnProtocolsBuffer
  , alpnProtocolsUint8Array
  , alpnProtocolsStringArray
  , alpnProtocolsBufferArray
  , alpnProtocolsUint8ArrayArray
  , alpnProtocols

  , sessionTimeout
  , ticketKeys

  , PFX
  , pfxString
  , pfxBuffer
  , pfx

  , Key
  , keyString
  , keyBuffer
  , keyStringArray
  , keyBufferArray
  , key

  , passphrase

  , Cert
  , certString
  , certBuffer
  , certStringArray
  , certBufferArray
  , cert

  , CA
  , caString
  , caBuffer
  , caStringArray
  , caBufferArray
  , ca

  , CRL
  , crlString
  , crlBuffer
  , crlStringArray
  , crlBufferArray
  , crl

  , ciphers
  , honorCipherOrder
  , ecdhCurve

  , DHParam
  , dhparamString
  , dhparamBuffer
  , dhparam

  , secureProtocol
  , secureOptions
  , sessionIdContext
  ) where

import Prelude

import Control.Monad.Eff (Eff)
import Data.ArrayBuffer.Types (Uint8Array)
import Data.Foreign (Foreign)
import Data.Options (Options, Option, options, opt)
import Node.Buffer (Buffer)
import Node.HTTP (Request, Response, Server, HTTP)
import Unsafe.Coerce (unsafeCoerce)

-- | The type of HTTPS server options
data SSLOptions

-- | Create an HTTPS server, given the SSL options and a function to be executed
-- | when a request is received.
foreign import createServerImpl ::
  forall eff.
  Foreign ->
  (Request -> Response -> Eff (http :: HTTP | eff) Unit) ->
  Eff (http :: HTTP | eff) Server

-- | Create an HTTPS server, given the SSL options and a function to be executed
-- | when a request is received.
createServer :: forall eff.
                Options SSLOptions ->
                (Request -> Response -> Eff (http :: HTTP | eff) Unit) ->
                Eff (http :: HTTP | eff) Server
createServer = createServerImpl <<< options

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
handshakeTimeout :: Option SSLOptions Int
handshakeTimeout = opt "handshakeTimeout"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
requestCert :: Option SSLOptions Boolean
requestCert = opt "requestCert"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
rejectUnauthorized :: Option SSLOptions Boolean
rejectUnauthorized = opt "rejectUnauthorized"

-- | The npnProtocols option can be a String, a Buffer, a Uint8Array, or an
-- | array of any of those types.
data NPNProtocols
npnProtocolsString :: String -> NPNProtocols
npnProtocolsString = unsafeCoerce
npnProtocolsBuffer :: Buffer -> NPNProtocols
npnProtocolsBuffer = unsafeCoerce
npnProtocolsUint8Array :: Uint8Array -> NPNProtocols
npnProtocolsUint8Array = unsafeCoerce
npnProtocolsStringArray :: Array String -> NPNProtocols
npnProtocolsStringArray = unsafeCoerce
npnProtocolsBufferArray :: Array Buffer -> NPNProtocols
npnProtocolsBufferArray = unsafeCoerce
npnProtocolsUint8ArrayArray :: Array Uint8Array -> NPNProtocols
npnProtocolsUint8ArrayArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
npnProtocols :: Option SSLOptions NPNProtocols
npnProtocols = opt "NPNProtocols"

-- | The alpnProtocols option can be a String, a Buffer, a Uint8Array, or an
-- | array of any of those types.
data ALPNProtocols
alpnProtocolsString :: String -> ALPNProtocols
alpnProtocolsString = unsafeCoerce
alpnProtocolsBuffer :: Buffer -> ALPNProtocols
alpnProtocolsBuffer = unsafeCoerce
alpnProtocolsUint8Array :: Uint8Array -> ALPNProtocols
alpnProtocolsUint8Array = unsafeCoerce
alpnProtocolsStringArray :: Array String -> ALPNProtocols
alpnProtocolsStringArray = unsafeCoerce
alpnProtocolsBufferArray :: Array Buffer -> ALPNProtocols
alpnProtocolsBufferArray = unsafeCoerce
alpnProtocolsUint8ArrayArray :: Array Uint8Array -> ALPNProtocols
alpnProtocolsUint8ArrayArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
alpnProtocols :: Option SSLOptions ALPNProtocols
alpnProtocols = opt "ALPNProtocols"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
sessionTimeout :: Option SSLOptions Int
sessionTimeout = opt "sessionTimeout"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createserver_options_secureconnectionlistener)
ticketKeys :: Option SSLOptions Buffer
ticketKeys = opt "ticketKeys"

-- | The PFX option can take either a String or a Buffer
data PFX
pfxString :: String -> PFX
pfxString = unsafeCoerce
pfxBuffer :: Buffer -> PFX
pfxBuffer = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
pfx :: Option SSLOptions PFX
pfx = opt "pfx"

-- | The key option can be a String, a Buffer, an array of strings, or an array
-- | of buffers.
data Key
keyString :: String -> Key
keyString = unsafeCoerce
keyBuffer :: Buffer -> Key
keyBuffer = unsafeCoerce
keyStringArray :: Array String -> Key
keyStringArray = unsafeCoerce
keyBufferArray :: Array Buffer -> Key
keyBufferArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
key :: Option SSLOptions Key
key = opt "key"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
passphrase :: Option SSLOptions String
passphrase = opt "passphrase"

-- | The cert option can be a String, a Buffer, an array of strings, or an array
-- | of buffers.
data Cert
certString :: String -> Cert
certString = unsafeCoerce
certBuffer :: Buffer -> Cert
certBuffer = unsafeCoerce
certStringArray :: Array String -> Cert
certStringArray = unsafeCoerce
certBufferArray :: Array Buffer -> Cert
certBufferArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
cert :: Option SSLOptions Cert
cert = opt "cert"

-- | The CA option can be a String, a Buffer, an array of strings, or an array
-- | of buffers.
data CA
caString :: String -> CA
caString = unsafeCoerce
caBuffer :: Buffer -> CA
caBuffer = unsafeCoerce
caStringArray :: Array String -> CA
caStringArray = unsafeCoerce
caBufferArray :: Array Buffer -> CA
caBufferArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ca :: Option SSLOptions CA
ca = opt "ca"

-- | The CRL option can be a String, a Buffer, an array of strings, or an array
-- | of buffers.
data CRL
crlString :: String -> CRL
crlString = unsafeCoerce
crlBuffer :: Buffer -> CRL
crlBuffer = unsafeCoerce
crlStringArray :: Array String -> CRL
crlStringArray = unsafeCoerce
crlBufferArray :: Array Buffer -> CRL
crlBufferArray = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
crl :: Option SSLOptions CRL
crl = opt "crl"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ciphers :: Option SSLOptions String
ciphers = opt "ciphers"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
honorCipherOrder :: Option SSLOptions Boolean
honorCipherOrder = opt "honorCipherOrder"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
ecdhCurve :: Option SSLOptions String
ecdhCurve = opt "ecdhCurve"

-- | The DHParam option can take either a String or a Buffer
data DHParam
dhparamString :: String -> DHParam
dhparamString = unsafeCoerce
dhparamBuffer :: Buffer -> DHParam
dhparamBuffer = unsafeCoerce

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
dhparam :: Option SSLOptions DHParam
dhparam = opt "dhparam"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
secureProtocol :: Option SSLOptions String
secureProtocol = opt "secureProtocol"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
secureOptions :: Option SSLOptions Int
secureOptions = opt "secureOptions"

-- | See the [node docs](https://nodejs.org/api/tls.html#tls_tls_createsecurecontext_options)
sessionIdContext :: Option SSLOptions String
sessionIdContext = opt "sessionIdContext"