Par added but not yet working

Par added but not yet working

-- | A low-level primitive for building asynchronous code.
module Control.Monad.Aff.Var
  ( AffVar()
  , Var()
  , VarFx()
  , killVar
  , makeVar
  , makeVar'
  , modifyVar
  , putVar
  , takeVar
  ) where

  import Control.Monad.Aff
  import Control.Monad.Eff.Exception(Error())

  foreign import data VarFx :: !

  foreign import data Var :: * -> *

  type AffVar e a = Aff (var :: VarFx | e) a

  -- | Makes a new asynchronous variable.
  foreign import makeVar """
    function makeVar(error) {
      return function(success) {
        return function() {
          success({
            consumers: [],
            producers: [],
            error: undefined
          })();
        }
      }
    }
  """ :: forall e a. AffVar e (Var a)

  -- | Makes a variable and sets it to some value.
  makeVar' :: forall e a. a -> AffVar e (Var a)
  makeVar' a = do
    v <- makeVar
    putVar v a
    return v

  -- | Takes the next value from the asynchronous variable.
  foreign import takeVar """
    function takeVar(avar) {
      return function(error) {
        return function(success) {
          return function() {
            if (avar.error !== undefined) {
              error(avar.error)();
            } else if (avar.producers.length > 0) {
              var producer = avar.producers.shift();

              producer(error, success);
            } else {
              avar.consumers.push({error: error, success: success});
            }
          }
        }
      }
    }
  """ :: forall e a. Var a -> AffVar e a

  -- | Puts a new value into the asynchronous variable. If the variable has
  -- | been killed, this will result in an error.
  foreign import putVar """
    function putVar(avar) {
      return function(a) {
        return function(error) {
          return function(success) {
            return function() {
              console.log("putting " + a + " into var: ");
              console.log(avar);

              if (avar.error !== undefined) {
                error(avar.error)();
              } else if (avar.consumers.length == 0) {
                avar.producers.push(function(error, success) {
                  success(a)();
                });
              } else {
                var consumer = avar.consumers.shift();

                try {
                  consumer.success(a)();
                } catch (e) {
                  error(e)();

                  return;
                }

                success({})();
              }
            }
          }
        }
      }
    }
  """ :: forall e a. Var a -> a -> AffVar e Unit

  -- | Modifies an asynchronous variable.
  modifyVar :: forall e a. (a -> a) -> Var a -> AffVar e Unit
  modifyVar f v = takeVar v >>= (f >>> putVar v)

  -- | Kills an asynchronous variable.
  foreign import killVar """
    function killVar(avar) {
      return function(e) {
        return function(error) {
          return function(success) {
            return function() {
              if (avar.error !== undefined) {
                error(avar.error);
              } else {
                var errors = [];

                avar.error = e;

                while (avar.consumers.length > 0) {
                  var consumer = avar.consumers.shift();

                  try {
                    consumer.error(e)();
                  } catch (e) {
                    errors.push(e);
                  }
                }

                if (errors.length > 0) error(errors[0])();
                else success({})();
              }
            }
          }
        }
      }
    }
  """ :: forall e a. Var a -> Error -> AffVar e Unit

-- | A low-level primitive for building asynchronous code.
module Control.Monad.Aff.Var
  ( AffVar()
  , Var()
  , VarFx()
  , killVar
  , makeVar
  , makeVar'
  , modifyVar
  , putVar
  , takeVar
  ) where

  import Control.Monad.Aff
  import Control.Monad.Eff.Exception(Error())

  foreign import data VarFx :: !

  foreign import data Var :: * -> *

  type AffVar e a = Aff (var :: VarFx | e) a

  -- | Makes a new asynchronous variable.
  foreign import makeVar """
    function makeVar(error) {
      return function(success) {
        return function() {
          success({
            consumers: [],
            producers: [],
            error: undefined
          })();
        }
      }
    }
  """ :: forall e a. AffVar e (Var a)

  -- | Makes a variable and sets it to some value.
  makeVar' :: forall e a. a -> AffVar e (Var a)
  makeVar' a = do
    v <- makeVar
    putVar v a
    return $ v

  -- | Takes the next value from the asynchronous variable.
  foreign import takeVar """
    function takeVar(avar) {
      return function(error) {
        return function(success) {
          return function() {
            if (avar.error !== undefined) {
              error(avar.error)();
            } else if (avar.producers.length > 0) {
              var producer = avar.producers.shift();

              producer(error, success);
            } else {
              avar.consumers.push({error: error, success: success});
            }
          }
        }
      }
    }
  """ :: forall e a. Var a -> AffVar e a

  -- | Puts a new value into the asynchronous variable. If the variable has
  -- | been killed, this will result in an error.
  foreign import putVar """
    function putVar(avar) {
      return function(a) {
        return function(error) {
          return function(success) {
            return function() {
              if (avar.error !== undefined) {
                error(avar.error)();
              } else if (avar.consumers.length == 0) {
                avar.producers.push(function(error, success) {
                  success(a)();
                });
              } else {
                var consumer = avar.consumers.shift();

                try {
                  consumer.success(a)();
                } catch (e) {
                  error(e)();

                  return;
                }

                success({})();
              }
            }
          }
        }
      }
    }
  """ :: forall e a. Var a -> a -> AffVar e Unit

  -- | Modifies an asynchronous variable.
  modifyVar :: forall e a. (a -> a) -> Var a -> AffVar e Unit
  modifyVar f v = takeVar v >>= (f >>> putVar v)

  -- | Kills an asynchronous variable.
  foreign import killVar """
    function killVar(avar) {
      return function(e) {
        return function(error) {
          return function(success) {
            return function() {
              if (avar.error !== undefined) {
                error(avar.error);
              } else {
                var errors = [];

                avar.error = e;

                while (avar.consumers.length > 0) {
                  var consumer = avar.consumers.shift();

                  try {
                    consumer.error(e)();
                  } catch (e) {
                    errors.push(e);
                  }
                }

                if (errors.length > 0) error(errors[0])();
                else success({})();
              }
            }
          }
        }
      }
    }
  """ :: forall e a. Var a -> Error -> AffVar e Unit


Add Snapshot.Error type

Add Snapshot.Error type

module Lambda.Language.Snapshot.Error
  ( Error(..)
  ) where

import Lambda.Prelude

import Data.Array as Array
import Lambda.Language.Name (Name)
import Lambda.Language.Pretty (class Pretty, text, pretty)
import Lambda.Language.Snapshot.Tag (Tag)

-- | Errors that can occur while creating or loading a `Snapshot`
data Error
  -- | Payload would use more than 29 bits
  = PayloadOutOfRange Tag Int
  -- | Unrecognized 3-bit tag (only 0b000 now)
  | UnrecognizedTag Tag
  -- | Unprocessed values on the stack after running out of instructions
  | ExtraStackValues Int
  -- | Not enough values on the stack
  | StackUnderflow { op :: String, wanted :: Int, saw :: Int }
  -- | Bad index into the name store
  | IndexOutOfRange Int (Array Name)

derive instance eqError :: Eq Error
derive instance genericError :: Generic Error _

instance showError :: Show Error where
  show x = genericShow x

instance Pretty Error where
  pretty rep = case _ of
    PayloadOutOfRange tag p -> fold
      [ text "payload "
      , text $ show p
      , text " for tag "
      , pretty rep tag
      , text " out of range for 29 bits"
      ]
    UnrecognizedTag tag -> fold
      [ text "unrecognized tag "
      , pretty rep tag
      ]
    ExtraStackValues n -> fold
      [ text "malformed snapshot; "
      , text $ show n
      , text " extra expressions left on stack"
      ]
    StackUnderflow { op, wanted, saw } -> fold
      [ text "stack underflow for "
      , text op
      , text "; wanted "
      , text $ show wanted
      , text " item(s), saw "
      , text $ show saw
      ]
    IndexOutOfRange i names -> fold
      [ text "index "
      , text $ show i
      , text " out of range for symbol table ["
      , Array.intercalate (text ", ") (pretty rep <$> names)
      , text "]"
      ]

error: pathspec 'frontend/src/Lambda/Language/Snapshot/Error.purs' did not match any file(s) known to git


Moved the assertions unto the runClient block.

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/gcross/habit-of-fate.git/'


Fix Respondable Foreign for IE

Fix Respondable Foreign for IE

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/aspidites/purescript-affjax.git/'


4.11.1

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/mikemcgowan/purescript-book.git/'


Added rudimentary types and their initial values

module Types where

type Z80State =
  { mem :: Mem
  , totalM :: I8
  }

cleanState :: Z80State
cleanState =
  { mem = cleanMem
  , totalM = 0
  }

type Mem =
  { regs :: Regs
  , mainMem :: MainMem
  }

cleanMem :: Mem
cleanMem =
  { regs = cleanRegs
  , mainMem = cleanMainMem
  }

type Regs =
  { pc :: I16
  , sp :: I16
  , m :: I8
  , a :: I8
  , b :: I8
  , c :: I8
  , d :: I8
  , e :: I8
  , h :: I8
  , l :: I8
  , f :: I8
  }

cleanRegs :: Regs
cleanRegs =
  { pc = 0
  , sp = 0
  , m = 0
  , t = 0
  , a = 0
  , b = 0
  , c = 0
  , d = 0
  , e = 0
  , h = 0
  , l = 0
  , f = 0
  }

--NOTE:: If you make these types 'newtype's you gain compile-time safety
--at the cost of verbosity. Consider doing the change
type I8 = Number
type I16 = Number

error: pathspec 'src/Types.purs' did not match any file(s) known to git


Add hacky way to parse deep JSON objects

module Genetics.Browser.Feature.Foreign where

import Prelude
import Data.Maybe.First
import Genetics.Browser.Events.Types
import Data.Argonaut as A
import Control.MonadPlus (guard)
import Data.Argonaut (class DecodeJson, Json, encodeJson, isObject, toObject, (.?), (:=))
import Data.Argonaut.Core (JObject)
import Data.Either (Either(..))
import Data.Foldable (class Foldable, foldMap, foldl)
import Data.Foreign (Foreign, F)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap, wrap)
import Genetics.Browser.Units (class HCoordinate, Bp(..), MBp(..), mbp)

type LocKeys = { locKeys :: Array String
               , chrKeys :: Array String
               , posKeys :: Array String
               }

-- tries keys in the Foldable f until one of them exists on the JObject obj,
-- returning the first value or a Left with an error.
keysDecode :: forall f a.
            Foldable f
         => DecodeJson a
         => JObject
         -> f String
         -> Either String a
keysDecode obj keys = case foldMap (\key -> First $ hush $ obj .? key) keys of
  First Nothing  -> Left $ "Object contained no keys from " <> "todo add error"
  First (Just v) -> Right v
  where hush (Left _)  = Nothing
        hush (Right v) = Just v

parseFeatureLocation :: LocKeys -> JObject -> Either String { chr :: String, pos :: Bp }
parseFeatureLocation { locKeys, chrKeys, posKeys } f = do
  loc <- f `keysDecode` locKeys
  -- pure $ { chr: _, pos: _ } <$> loc `keysDecode` chrKeys <*> (Bp <$> loc `keysDecode` posKeys)
  chr <- loc `keysDecode` chrKeys
  pos <- Bp <$> loc `keysDecode` posKeys
  pure $ { chr, pos }

parseFeatureLocation' :: LocKeys -> JObject -> Either String Event
parseFeatureLocation' ks f = do
  d <- parseFeatureLocation ks f
  let json = encodeJson [ "chr" := d.chr
                        , "pos" := (unwrap d.pos)
                        ]
  case toObject json of
    Nothing -> Left "Error when encoding Location Event"
    Just obj -> Right $ Event { eventData: obj }

type RanKeys = { chrKeys :: Array String
               , minKeys :: Array String
               , maxKeys :: Array String
               }

parseFeatureRange :: RanKeys
                  -> JObject
                  -> Either String { chr :: String, minPos :: Bp, maxPos :: Bp }
parseFeatureRange {chrKeys, minKeys, maxKeys} f = do
  chr <- f `keysDecode` chrKeys
  minPos <- Bp <$> f `keysDecode` minKeys
  maxPos <- Bp <$> f `keysDecode` maxKeys
  pure { chr, minPos, maxPos }

parseFeatureRange' :: RanKeys -> JObject -> Either String Event
parseFeatureRange' ks f = do
  d <- parseFeatureRange ks f
  let json = encodeJson [ "chr" := d.chr
                        , "minPos" := (unwrap d.minPos)
                        , "maxPos" := (unwrap d.maxPos)
                        ]
  case toObject json of
    Nothing -> Left "Error when encoding Range Event"
    Just obj -> Right $ Event { eventData: obj }

type ScoreKeys = { scoreKeys :: Array String }

parseFeatureScore :: ScoreKeys -> JObject -> Either String Event
parseFeatureScore { scoreKeys } f = do
  score <- f `keysDecode` scoreKeys
  let json = encodeJson [ "score" := (score :: Number)
                        ]
  case toObject json of
    Nothing -> Left "Error when encoding Score Event"
    Just obj -> Right $ Event { eventData: obj }

parsePath :: ∀ f. Foldable f => JObject -> f String -> Either String JObject
parsePath obj = foldl (\acc cur -> case acc of
                         Left er -> Left er
                         Right x -> x .? cur) (Right obj)

module Genetics.Browser.Feature.Foreign where

import Prelude
import Data.Maybe.First
import Genetics.Browser.Events.Types
import Data.Argonaut as A
import Control.MonadPlus (guard)
import Data.Argonaut (class DecodeJson, Json, encodeJson, isObject, toObject, (.?), (:=))
import Data.Argonaut.Core (JObject)
import Data.Either (Either(..))
import Data.Foldable (class Foldable, foldMap)
import Data.Foreign (Foreign, F)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap, wrap)
import Genetics.Browser.Units (class HCoordinate, Bp(..), MBp(..), mbp)

type LocKeys = { locKeys :: Array String
               , chrKeys :: Array String
               , posKeys :: Array String
               }

-- tries keys in the Foldable f until one of them exists on the JObject obj,
-- returning the first value or a Left with an error.
keysDecode :: forall f a.
            Foldable f
         => DecodeJson a
         => JObject
         -> f String
         -> Either String a
keysDecode obj keys = case foldMap (\key -> First $ hush $ obj .? key) keys of
  First Nothing  -> Left $ "Object contained no keys from " <> "todo add error"
  First (Just v) -> Right v
  where hush (Left _)  = Nothing
        hush (Right v) = Just v

parseFeatureLocation :: LocKeys -> JObject -> Either String { chr :: String, pos :: Bp }
parseFeatureLocation { locKeys, chrKeys, posKeys } f = do
  loc <- f `keysDecode` locKeys
  -- pure $ { chr: _, pos: _ } <$> loc `keysDecode` chrKeys <*> (Bp <$> loc `keysDecode` posKeys)
  chr <- loc `keysDecode` chrKeys
  pos <- Bp <$> loc `keysDecode` posKeys
  pure $ { chr, pos }

parseFeatureLocation' :: LocKeys -> JObject -> Either String Event
parseFeatureLocation' ks f = do
  d <- parseFeatureLocation ks f
  let json = encodeJson [ "chr" := d.chr
                        , "pos" := (unwrap d.pos)
                        ]
  case toObject json of
    Nothing -> Left "Error when encoding Location Event"
    Just obj -> Right $ Event { eventData: obj }

type RanKeys = { chrKeys :: Array String
               , minKeys :: Array String
               , maxKeys :: Array String
               }

parseFeatureRange :: RanKeys
                  -> JObject
                  -> Either String { chr :: String, minPos :: Bp, maxPos :: Bp }
parseFeatureRange {chrKeys, minKeys, maxKeys} f = do
  chr <- f `keysDecode` chrKeys
  minPos <- Bp <$> f `keysDecode` minKeys
  maxPos <- Bp <$> f `keysDecode` maxKeys
  pure { chr, minPos, maxPos }

parseFeatureRange' :: RanKeys -> JObject -> Either String Event
parseFeatureRange' ks f = do
  d <- parseFeatureRange ks f
  let json = encodeJson [ "chr" := d.chr
                        , "minPos" := (unwrap d.minPos)
                        , "maxPos" := (unwrap d.maxPos)
                        ]
  case toObject json of
    Nothing -> Left "Error when encoding Range Event"
    Just obj -> Right $ Event { eventData: obj }

type ScoreKeys = { scoreKeys :: Array String }

parseFeatureScore :: ScoreKeys -> JObject -> Either String Event
parseFeatureScore { scoreKeys } f = do
  score <- f `keysDecode` scoreKeys
  let json = encodeJson [ "score" := (score :: Number)
                        ]
  case toObject json of
    Nothing -> Left "Error when encoding Score Event"
    Just obj -> Right $ Event { eventData: obj }


solution for Day3 Part2

solution for Day3 Part2

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/michaelsbradleyjr/advent-of-code.git/'


Fixed the ordering of imports in test/Main.hs


Fleshed out divideAllEfforts(). Using mapWithKey. Learned that sequence can be applied to things besides lists and arrays.

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/0dB/cats-utils.git/'


Add File API types

Add File API types

-- | Types for the [W3C File API](http://dev.w3.org/2006/webapi/FileAPI/).
module DOM.File where

-- | A `File` object instance.
foreign import data File :: *

-- | A `FileList` object instance.
foreign import data FileList :: *

-- | A `FileReader` object instance.
foreign import data FileReader :: *

-- | A `Blob` object instance.
foreign import data Blob :: *

error: pathspec 'src/DOM/File.purs' did not match any file(s) known to git


Dropped spy in Client.hs

Dropped spy in Client.hs


Add Control.Monad.Trampoline

Add Control.Monad.Trampoline

module Control.Monad.Trampoline where

import Control.Monad.Free

data Delay a = Delay ({} -> a)

instance delayFunctor :: Functor Delay where
  (<$>) f (Delay g) = Delay (const (f (g {})))

instance delayApply :: Apply Delay where
  (<*>) (Delay f) (Delay a) = Delay (\{} -> (f {}) (a {}))

instance delayApplicative :: Applicative Delay where
  pure a = Delay (\{} -> a)

type Trampoline a = Free Delay a

done :: forall a. a -> Trampoline a
done = Pure

suspend :: forall a. Trampoline a -> Trampoline a
suspend a = Free (Delay (\{} -> a))

delay :: forall a. ({} -> a) -> Trampoline a
delay a = Free (done <$> Delay a)

runTrampoline :: forall a. Trampoline a -> a
runTrampoline = go (\(Delay f) -> f {})

error: pathspec 'src/Control/Monad/Trampoline.purs' did not match any file(s) known to git


Add MonadTrans

Add MonadTrans

module Control.Monad.Trans where

import Control.Monad.Eff

class MonadTrans t where
  lift :: forall m a. (Prelude.Monad m) => m a -> t m a

class MonadEff m where
  liftEff :: forall eff a. Eff eff a -> m a

error: pathspec 'src/Control.Monad.Trans.purs' did not match any file(s) known to git


Doc fix

Doc fix

module Gonimo.Client.Types where

import Prelude
import Servant.PureScript.Affjax as Affjax
import Browser.LocalStorage (STORAGE)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff, class MonadAff)
import Control.Monad.Eff.Class (liftEff, class MonadEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Exception (Error, EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Error.Class (catchError, throwError)
import Control.Monad.Except (ExceptT(ExceptT))
import Control.Monad.Except.Trans (runExceptT, class MonadError, ExceptT)
import Control.Monad.IO (IO)
import Control.Monad.IO.Class (liftIO, class MonadIO)
import Control.Monad.Reader (ReaderT(ReaderT))
import Control.Monad.Reader.Class (local, ask, class MonadReader)
import Control.Monad.Reader.Trans (runReaderT, ReaderT)
import Data.Either (Either(Right, Left), either)
import Data.Generic (class Generic)
import Gonimo.WebAPI (SPParams_)
import Gonimo.WebAPI.Types (DeviceInfo)
import Network.HTTP.Affjax (AJAX)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (SPSettings_)
import Signal.Channel (CHANNEL)
import WebSocket (WEBSOCKET)

type Settings = SPSettings_ SPParams_

data GonimoError = AjaxError Affjax.AjaxError
                 | UnexpectedAction String

-- | Action type to use when errors should be handled by the parent component.
data ReportParent action = ReportError GonimoError
                         | Child action

-- | Action types that can be used for error reporting:
class ReportErrorAction action where
  reportError :: GonimoError -> action

instance reportErrorActionReportParent :: ReportErrorAction (ReportParent action) where
  reportError = ReportError

newtype Gonimo a = Gonimo (ReaderT Settings (ExceptT GonimoError IO) a)

-- We have runGonimo in Gonimo.Pux, so call it unwrap
unwrapGonimo :: forall a. Gonimo a -> (ReaderT Settings (ExceptT GonimoError IO) a)
unwrapGonimo (Gonimo m) = m

toIO :: forall action. ReportErrorAction action
        => Settings -> Gonimo action -> IO action
toIO settings m = map (either reportError id) <<< runExceptT <<< flip runReaderT settings <<< unwrapGonimo $ m

instance functorGonimo :: Functor (Gonimo) where
  map f (Gonimo m) = Gonimo $ map f m

instance applyGonimo :: Apply (Gonimo) where
  apply (Gonimo mf) (Gonimo ma) = Gonimo $ apply mf ma

instance applicativeGonimo :: Applicative (Gonimo) where
  pure = Gonimo <<< pure

instance bindGonimo :: Bind (Gonimo) where
  bind (Gonimo ma) mf = Gonimo $ bind ma (unwrapGonimo <<< mf)

instance monadGonimo :: Monad (Gonimo)

instance monadReaderSettingsGonimo :: MonadReader (SPSettings_ SPParams_) (Gonimo) where
  ask = Gonimo ask
  --local :: forall a. (r -> r) -> m a -> m a
  local f (Gonimo ma) = Gonimo (local f ma)

instance monadErrorErrorGonimo :: MonadError GonimoError (Gonimo) where
  throwError = Gonimo <<< throwError
  catchError (Gonimo ma) ef = Gonimo $ catchError ma (unwrapGonimo <<< ef)

instance monadErrorAjaxErrorGonimo :: MonadError AjaxError (Gonimo) where
  throwError = Gonimo <<< throwError <<< AjaxError
  catchError (Gonimo ma) ef = Gonimo $ catchError ma (unwrapGonimo <<< handleAjax)
    where
      handleAjax (AjaxError err) = ef err
      handleAjax err = throwError err

instance monadEffeffGonimo :: MonadEff eff Gonimo where
  liftEff = Gonimo <<< liftEff

instance monadAffeffGonimo :: MonadAff eff Gonimo where
  liftAff = Gonimo <<< liftAff

instance monadIOGonimo :: MonadIO Gonimo where
  liftIO m = Gonimo $ ReaderT $ \r -> ExceptT (map Right m)

-- | Info about an online baby station.
type BabyStationInfo =
  { deviceInfo :: DeviceInfo
  , babyName :: String
  }

module Gonimo.Client.Types where

import Prelude
import Servant.PureScript.Affjax as Affjax
import Browser.LocalStorage (STORAGE)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff, class MonadAff)
import Control.Monad.Eff.Class (liftEff, class MonadEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Exception (Error, EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Error.Class (catchError, throwError)
import Control.Monad.Except (ExceptT(ExceptT))
import Control.Monad.Except.Trans (runExceptT, class MonadError, ExceptT)
import Control.Monad.IO (IO)
import Control.Monad.IO.Class (liftIO, class MonadIO)
import Control.Monad.Reader (ReaderT(ReaderT))
import Control.Monad.Reader.Class (local, ask, class MonadReader)
import Control.Monad.Reader.Trans (runReaderT, ReaderT)
import Data.Either (Either(Right, Left), either)
import Data.Generic (class Generic)
import Gonimo.WebAPI (SPParams_)
import Gonimo.WebAPI.Types (DeviceInfo)
import Network.HTTP.Affjax (AJAX)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (SPSettings_)
import Signal.Channel (CHANNEL)
import WebSocket (WEBSOCKET)

type Settings = SPSettings_ SPParams_

data GonimoError = AjaxError Affjax.AjaxError
                 | UnexpectedAction String

-- | Action type to use when errors should be handled by the parent component.
data ReportParent action = ReportError GonimoError
                         | Child action

-- | Action types that can be used for error reporting:
class ReportErrorAction action where
  reportError :: GonimoError -> action

instance reportErrorActionReportParent :: ReportErrorAction (ReportParent action) where
  reportError = ReportError

newtype Gonimo a = Gonimo (ReaderT Settings (ExceptT GonimoError IO) a)

-- We have unwrapGonimo in Gonimo.Pux, so call it unwrap
unwrapGonimo :: forall a. Gonimo a -> (ReaderT Settings (ExceptT GonimoError IO) a)
unwrapGonimo (Gonimo m) = m

toIO :: forall action. ReportErrorAction action
        => Settings -> Gonimo action -> IO action
toIO settings m = map (either reportError id) <<< runExceptT <<< flip runReaderT settings <<< unwrapGonimo $ m

instance functorGonimo :: Functor (Gonimo) where
  map f (Gonimo m) = Gonimo $ map f m

instance applyGonimo :: Apply (Gonimo) where
  apply (Gonimo mf) (Gonimo ma) = Gonimo $ apply mf ma

instance applicativeGonimo :: Applicative (Gonimo) where
  pure = Gonimo <<< pure

instance bindGonimo :: Bind (Gonimo) where
  bind (Gonimo ma) mf = Gonimo $ bind ma (unwrapGonimo <<< mf)

instance monadGonimo :: Monad (Gonimo)

instance monadReaderSettingsGonimo :: MonadReader (SPSettings_ SPParams_) (Gonimo) where
  ask = Gonimo ask
  --local :: forall a. (r -> r) -> m a -> m a
  local f (Gonimo ma) = Gonimo (local f ma)

instance monadErrorErrorGonimo :: MonadError GonimoError (Gonimo) where
  throwError = Gonimo <<< throwError
  catchError (Gonimo ma) ef = Gonimo $ catchError ma (unwrapGonimo <<< ef)

instance monadErrorAjaxErrorGonimo :: MonadError AjaxError (Gonimo) where
  throwError = Gonimo <<< throwError <<< AjaxError
  catchError (Gonimo ma) ef = Gonimo $ catchError ma (unwrapGonimo <<< handleAjax)
    where
      handleAjax (AjaxError err) = ef err
      handleAjax err = throwError err

instance monadEffeffGonimo :: MonadEff eff Gonimo where
  liftEff = Gonimo <<< liftEff

instance monadAffeffGonimo :: MonadAff eff Gonimo where
  liftAff = Gonimo <<< liftAff

instance monadIOGonimo :: MonadIO Gonimo where
  liftIO m = Gonimo $ ReaderT $ \r -> ExceptT (map Right m)

-- | Info about an online baby station.
type BabyStationInfo =
  { deviceInfo :: DeviceInfo
  , babyName :: String
  }


Language.PureScript.Optimizer.MagicDo partially done

Also needs the psc fix for qualified operators

module Language.PureScript.Optimizer.MagicDo (magicDo) where

import Data.Array (nub, length, filter)
import Data.Array.Unsafe (last, init)
import Data.Foldable (all, elem)
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import Data.Tuple

import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.CodeGen.Common (identToJs)
import Language.PureScript.Names

import qualified Language.PureScript.Constants as C

magicDo :: Options -> JS -> JS
magicDo (Options o) | o.noMagicDo = id
magicDo _ = inlineST <<< magicDo'

-- |
-- Inline type class dictionaries for >>= and return for the Eff monad
--
-- E.g.
--
--  Prelude[">>="](dict)(m1)(function(x) {
--    return ...;
--  })
--
-- becomes
--
--  function __do {
--    var x = m1();
--    ...
--  }
--
magicDo' :: JS -> JS
magicDo' = everywhereOnJS undo <<< everywhereOnJSTopDown convert
  where
  -- The name of the function block which is added to denote a do block
  fnName = "__do"
  -- Desugar monomorphic calls to >>= and return for the Eff monad
  convert :: JS -> JS
  -- Desugar return
  convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
  -- Desugar >>
  convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock js)]) | isBind bind && isJSReturn (last js) =
    case last js of JSReturn ret -> JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : init js ++ [JSReturn (JSApp ret [])] )
  -- Desugar >>=
  convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind && isJSReturn (last js) =
    case last js of JSReturn ret -> JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : init js ++ [JSReturn (JSApp ret [])] )
  -- Desugar untilE
  convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =
    JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) []
  -- Desugar whileE
  convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =
    JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) []
  convert other = other
  -- Check if an expression represents a monomorphic call to >>= for the Eff monad
  isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = true
  isBind _ = false
  -- Check if an expression represents a monomorphic call to return for the Eff monad
  isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = true
  isReturn _ = false
  -- Check if an expression represents the polymorphic >>= function
  -- isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == identToJs (Op (C.>>=))
  -- isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && bind == (C.>>=)
  isBindPoly _ = false
  -- Check if an expression represents the polymorphic return function
  isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped
  isRetPoly (JSIndexer (JSStringLiteral return') (JSVar prelude)) = prelude == C.prelude && return' == C.return
  isRetPoly _ = false
  -- Check if an expression represents a function in the Ef module
  isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'
  isEffFunc _ _ = false
  -- Check if an expression represents the Monad Eff dictionary
  isEffDict name (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == name = true
  isEffDict name (JSApp (JSAccessor prop (JSVar eff)) [JSObjectLiteral []]) = eff == C.eff && prop == name
  isEffDict _ _ = false
  -- Remove __do function applications which remain after desugaring
  undo :: JS -> JS
  undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
  undo other = other

  isJSReturn (JSReturn _) = true
  isJSReturn _ = false

-- |
-- Inline functions in the ST module
--
inlineST :: JS -> JS
inlineST = everywhereOnJS convertBlock
  where
  -- Look for runST blocks and inline the STRefs there.
  -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
  -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
  convertBlock (JSApp f [arg]) | isSTFunc C.runST f || isSTFunc C.runSTArray f =
    let refs = nub <<< findSTRefsIn $ arg
        usages = findAllSTUsagesIn arg
        allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
        localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
    in everywhereOnJS (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg
  convertBlock other = other
  -- Convert a block in a safe way, preserving object wrappers of references,
  -- or in a more aggressive way, turning wrappers into local variables depending on the
  -- agg(ressive) parameter.
  convert agg (JSApp f [arg]) | isSTFunc C.newSTRef f =
   JSFunction Nothing [] (JSBlock [JSReturn $ if agg then arg else JSObjectLiteral [Tuple C.stRefValue arg]])
  convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f =
    if agg then ref else JSAccessor C.stRefValue ref
  convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =
    if agg then JSAssignment ref arg else JSAssignment (JSAccessor C.stRefValue ref) arg
  convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc C.modifySTRef f =
    if agg then JSAssignment ref (JSApp func [ref]) else  JSAssignment (JSAccessor C.stRefValue ref) (JSApp func [JSAccessor C.stRefValue ref])
  convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc C.peekSTArray f =
    JSIndexer i arr
  convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc C.pokeSTArray f =
    JSAssignment (JSIndexer i arr) val
  convert _ other = other
  -- Check if an expression represents a function in the ST module
  isSTFunc name (JSAccessor name' (JSVar st)) = st == C.st && name == name'
  isSTFunc _ _ = false
  -- Find all ST Refs initialized in this block
  findSTRefsIn = everythingOnJS (++) isSTRef
    where
    isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc C.newSTRef f = [ident]
    isSTRef _ = []
  -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
  findAllSTUsagesIn = everythingOnJS (++) isSTUsage
    where
    isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref]
    isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
    isSTUsage _ = []
  -- Find all uses of a variable
  appearingIn ref = everythingOnJS (++) isVar
    where
    isVar e@(JSVar v) | v == ref = [e]
    isVar _ = []
  -- Convert a JS value to a String if it is a JSVar
  toVar (JSVar v) = Just v
  toVar _ = Nothing

error: pathspec 'src/Language/PureScript/Optimizer/MagicDo.purs' did not match any file(s) known to git


Fleshed out helper function jobToJHours().


Add ability to refer to the last answer via 'ans'

-- | This module defines the interpreter for the Insect language.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.Foldable (intercalate)
import Data.StrMap (lookup, insert, foldMap)
import Data.Bifunctor (lmap)

import Quantities (Quantity, DerivedUnit, UnificationError, asValueIn, pow,
                   qNegate, qAdd, qDivide, qMultiply, qSubtract, quantity,
                   unity, convert, errorMessage, prettyPrint, fullSimplify)

import Insect.Language (BinOp(..), Expression(..), Command(..), Statement(..))
import Insect.Environment (Environment, initialEnvironment)

-- | The types of errors that may appear during evaluation
data EvalError
  = UnificationError UnificationError
  | LookupError String

type Expect = Either EvalError

data MessageType = Value | Info | Error

data Message = Message MessageType String

-- A few helper functions
qSubtract' ∷ Quantity → Quantity → Expect Quantity
qSubtract' q1 q2 = lmap UnificationError (qSubtract q1 q2)

qAdd' ∷ Quantity → Quantity → Expect Quantity
qAdd' q1 q2 = lmap UnificationError (qAdd q1 q2)

asScalar ∷ Quantity → Expect Number
asScalar q = lmap UnificationError (q `asValueIn` unity)

convert' ∷ DerivedUnit → Quantity → Expect Quantity
convert' d q = lmap UnificationError (convert d q)

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Q n u)         = pure $ quantity n u
eval env (Negate x)      = qNegate <$> eval env x
eval env (BinOp Sub x y) = join $ qSubtract' <$> eval env x <*> eval env y
eval env (BinOp Add x y) = join $ qAdd'      <$> eval env x <*> eval env y
eval env (BinOp Mul x y) =        qMultiply  <$> eval env x <*> eval env y
eval env (BinOp Div x y) =        qDivide    <$> eval env x <*> eval env y
eval env (BinOp Pow x y) = do
  base ← eval env x
  exp ← eval env y
  expNumber ← asScalar exp
  pure $ base `pow` expNumber
eval env (Variable name) =
  case lookup name env of
    Just q → pure q
    Nothing → Left (LookupError name)

evalErrorMessage ∷ EvalError → String
evalErrorMessage (UnificationError ue) = errorMessage ue
evalErrorMessage (LookupError name) = "Unknown variable '" <> name <> "'"

message ∷ Environment → Expect Quantity → { msg ∷ Message, newEnv ∷ Environment }
message env (Left e) =
  { msg: Message Error (evalErrorMessage e)
  , newEnv: env
  }
message env (Right q) =
  { msg: Message Value (prettyPrint q)
  , newEnv: insert "ans" q env
  }

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → { msg ∷ Message, newEnv ∷ Environment }
runInsect env (Expression e) = message env (fullSimplify <$> eval env e)
runInsect env (Conversion e u) = message env (eval env e >>= convert' u)
runInsect env (Assignment n v) =
  case eval env v of
    Left evalErr → message env (Left evalErr)
    Right value → message (insert n value env) (Right (fullSimplify value))
runInsect env (Command Help) = { msg: Message Info (intercalate "\n"
  [ "insect is a command-line scientific calculator."
  , ""
  , "It evaluates simple calculations like 1920/16·9 as"
  , "well as expressions involving physical quantities."
  , ""
  , "You can start by trying one of these examples:"
  , ""
  , "--> 1920/16*9"
  , ""
  , "--> 2min + 30s"
  , ""
  , "--> 60mph -> m/s"
  , ""
  , "--> 6Mbps*1.5h -> Gb"
  ]), newEnv : env }
runInsect env (Command List) =
  { msg: Message Info list
  , newEnv: env }
  where
    list = foldMap toLine env
    toLine k v = k <> " = " <> prettyPrint v <> "\n"
runInsect env (Command Reset) =
  { msg: Message Info "Environment has been reset"
  , newEnv: initialEnvironment }
  where
    list = foldMap toLine env
    toLine k v = k <> " = " <> prettyPrint v <> "\n"
runInsect env (Command _) = { msg: Message Error "???", newEnv: env }

-- | This module defines the interpreter for the Insect language.
module Insect.Interpreter
  ( MessageType(..)
  , Message(..)
  , runInsect
  ) where

import Prelude hiding (degree)

import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.Foldable (intercalate)
import Data.StrMap (lookup, insert, foldMap)
import Data.Bifunctor (lmap)

import Quantities (Quantity, DerivedUnit, UnificationError, asValueIn, pow,
                   qNegate, qAdd, qDivide, qMultiply, qSubtract, quantity,
                   unity, convert, errorMessage, prettyPrint, fullSimplify)

import Insect.Language (BinOp(..), Expression(..), Command(..), Statement(..))
import Insect.Environment (Environment, initialEnvironment)

-- | The types of errors that may appear during evaluation
data EvalError
  = UnificationError UnificationError
  | LookupError String

type Expect = Either EvalError

data MessageType = Value | Info | Error

data Message = Message MessageType String

-- A few helper functions
qSubtract' ∷ Quantity → Quantity → Expect Quantity
qSubtract' q1 q2 = lmap UnificationError (qSubtract q1 q2)

qAdd' ∷ Quantity → Quantity → Expect Quantity
qAdd' q1 q2 = lmap UnificationError (qAdd q1 q2)

asScalar ∷ Quantity → Expect Number
asScalar q = lmap UnificationError (q `asValueIn` unity)

convert' ∷ DerivedUnit → Quantity → Expect Quantity
convert' d q = lmap UnificationError (convert d q)

-- | Evaluate a mathematical expression involving physical quantities.
eval ∷ Environment → Expression → Expect Quantity
eval env (Q n u)         = pure $ quantity n u
eval env (Negate x)      = qNegate <$> eval env x
eval env (BinOp Sub x y) = join $ qSubtract' <$> eval env x <*> eval env y
eval env (BinOp Add x y) = join $ qAdd'      <$> eval env x <*> eval env y
eval env (BinOp Mul x y) =        qMultiply  <$> eval env x <*> eval env y
eval env (BinOp Div x y) =        qDivide    <$> eval env x <*> eval env y
eval env (BinOp Pow x y) = do
  base ← eval env x
  exp ← eval env y
  expNumber ← asScalar exp
  pure $ base `pow` expNumber
eval env (Variable name) =
  case lookup name env of
    Just q → pure q
    Nothing → Left (LookupError name)

evalErrorMessage ∷ EvalError → String
evalErrorMessage (UnificationError ue) = errorMessage ue
evalErrorMessage (LookupError name) = "Unknown variable '" <> name <> "'"

message ∷ Environment → Expect Quantity → { msg ∷ Message, newEnv ∷ Environment }
message env (Left e) = { msg: Message Error (evalErrorMessage e), newEnv: env }
message env (Right q) = { msg: Message Value (prettyPrint q), newEnv: env }

-- | Run a single statement of an Insect program.
runInsect ∷ Environment → Statement → { msg ∷ Message, newEnv ∷ Environment }
runInsect env (Expression e) = message env (fullSimplify <$> eval env e)
runInsect env (Conversion e u) = message env (eval env e >>= convert' u)
runInsect env (Assignment n v) =
  case eval env v of
    Left evalErr → message env (Left evalErr)
    Right value → message (insert n value env) (Right (fullSimplify value))
runInsect env (Command Help) = { msg: Message Info (intercalate "\n"
  [ "insect is a command-line scientific calculator."
  , ""
  , "It evaluates simple calculations like 1920/16·9 as"
  , "well as expressions involving physical quantities."
  , ""
  , "You can start by trying one of these examples:"
  , ""
  , "--> 1920/16*9"
  , ""
  , "--> 2min + 30s"
  , ""
  , "--> 60mph -> m/s"
  , ""
  , "--> 6Mbps*1.5h -> Gb"
  ]), newEnv : env }
runInsect env (Command List) =
  { msg: Message Info list
  , newEnv: env }
  where
    list = foldMap toLine env
    toLine k v = k <> " = " <> prettyPrint v <> "\n"
runInsect env (Command Reset) =
  { msg: Message Info "Environment has been reset"
  , newEnv: initialEnvironment }
  where
    list = foldMap toLine env
    toLine k v = k <> " = " <> prettyPrint v <> "\n"
runInsect env (Command _) = { msg: Message Error "???", newEnv: env }


Fix next action guide

Fix next action guide

{-
Copyright 2016 SlamData, Inc.

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

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

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}
module SlamData.Workspace.Deck.Slider
  ( startSliding
  , stopSlidingAndSnap
  , updateSliderPosition
  , render
  , containerProperties
  ) where

import SlamData.Prelude

import Data.Array ((..))
import Data.Array as Array
import Data.Int as Int
import Data.Lens ((.~), (?~))
import Data.Lens as Lens
import Data.List ((:))
import Data.String as String
import Data.Tuple as Tuple

import CSS (CSS)

import Halogen as H
import Halogen.HTML.CSS.Indexed (style)
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Events.Types (Event, MouseEvent)
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed (IProp(), I)
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA

import SlamData.Render.CSS as ClassNames
import SlamData.Guide as Guide
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Card.CardId as CardId
import SlamData.Workspace.Card.Component as CardC
import SlamData.Workspace.Card.Component.CSS as CardCSS
import SlamData.Workspace.Card.InsertableCardType as ICT
import SlamData.Workspace.Card.Factory as Factory
import SlamData.Workspace.Card.Next.Component as Next
import SlamData.Workspace.Card.Error.Component as Error
import SlamData.Workspace.Card.Pending.Component as Pending
import SlamData.Workspace.Deck.Common (DeckOptions, DeckHTML, DeckDSL)
import SlamData.Workspace.Deck.Component.ChildSlot as ChildSlot
import SlamData.Workspace.Deck.Component.Cycle (DeckComponent)
import SlamData.Workspace.Deck.Component.Query (Query)
import SlamData.Workspace.Deck.Component.Query as DCQ
import SlamData.Workspace.Deck.Component.State (State)
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckId as DeckId
import SlamData.Workspace.Deck.Gripper as Gripper
import SlamData.Workspace.Deck.Gripper.Def (GripperDef(..))

import Utils.CSS as CSSUtils

render ∷ DeckOptions → (DeckOptions → DeckComponent) → State → Boolean → DeckHTML
render opts deckComponent st visible =
  HH.div
    ([ HP.key "deck-cards"
     , HP.classes [ ClassNames.cardSlider ]
     , HE.onTransitionEnd $ HE.input_ DCQ.StopSliderTransition
     , style do
         cardSliderTransformCSS (fromMaybe 0 st.activeCardIndex) st.sliderTranslateX
         cardSliderTransitionCSS st.sliderTransition
     ]
     ⊕ (guard (not visible) $> (HP.class_ ClassNames.invisible)))
    $ map (Tuple.uncurry $ renderCard opts deckComponent st)
    $ Array.zip st.displayCards (0 .. Array.length st.displayCards)

startSliding ∷ Event MouseEvent → GripperDef → DeckDSL Unit
startSliding mouseEvent gDef = do
  cardWidth ← H.gets _.cardElementWidth
  H.modify
    $ (DCS._initialSliderX .~ Just mouseEvent.screenX)
    ∘ (DCS._initialSliderCardWidth .~ cardWidth)
    ∘ (DCS._sliderTransition .~ false)
    ∘ (DCS._fadeTransition .~ DCS.FadeIn)
    ∘ (DCS._displayMode .~ DCS.Normal)
    ∘ (DCS._slidingTo ?~ gDef)

stopSlidingAndSnap ∷ Event MouseEvent → DeckDSL Unit
stopSlidingAndSnap mEvent =
  H.modify
    $ stopSliding
    ∘ snap
    ∘ stateUpdateSliderPosition mEvent

stateUpdateSliderPosition ∷ Event MouseEvent → State → State
stateUpdateSliderPosition mouseEvent =
  maybe id (Lens.set DCS._sliderTranslateX ∘ translateXCalc mouseEvent.screenX)
    <$> _.initialSliderX
    <*> id

updateSliderPosition ∷ Event MouseEvent → DeckDSL Unit
updateSliderPosition = H.modify ∘ stateUpdateSliderPosition

translateXCalc ∷ Number → Number → Number
translateXCalc eventScreenX initialX =
  eventScreenX - initialX

stopSliding ∷ State → State
stopSliding =
  (DCS._initialSliderX .~ Nothing)
  ∘ (DCS._sliderTranslateX .~ 0.0)
  ∘ (DCS._slidingTo .~ Nothing)
  ∘ (DCS._fadeTransition .~ DCS.FadeOut)
  ∘ startTransition

clickBound ∷ Number
clickBound = 4.0

isClick ∷ Number -> Boolean
isClick n = n < clickBound ∧ n > -clickBound

snapActiveCardIndexByTranslationAndCardWidth
  ∷ State
  → Number
  → Int
  → Int
snapActiveCardIndexByTranslationAndCardWidth st cardWidth idx =
  let
    translateX = st.sliderTranslateX

    numberOfCards = Array.length st.displayCards

    halfOffset = (offsetCardSpacing cardWidth) / 2.0

    result | isClick translateX  = case st.slidingTo of
      Just (Previous true) → min (numberOfCards - 1) $ idx - one
      Just (Next true) → max 0 $ idx + one
      _ → idx
    result | translateX <= -1.0 * halfOffset =
      min (numberOfCards - 1)
      $ sub idx
      $ one
      + Int.floor ((translateX - halfOffset) / cardWidth)
    result | translateX >= halfOffset =
      max 0
      $ idx
      + one
      + Int.floor ((-translateX - halfOffset) / cardWidth)
    result | otherwise =
      idx
  in
    result

offsetCardSpacing ∷ Number → Number
offsetCardSpacing = add cardSpacingPx

snapActiveCardIndex ∷ State → Int
snapActiveCardIndex st = maybe id snap' st.initialSliderCardWidth $ fromMaybe 0 st.activeCardIndex
  where
  snap' = snapActiveCardIndexByTranslationAndCardWidth st

snap ∷ State → State
snap st = st { activeCardIndex = Just $ snapActiveCardIndex st }

startTransition ∷ State → State
startTransition = DCS._sliderTransition .~ true

willChangeActiveCardWhenDropped ∷ State → Boolean
willChangeActiveCardWhenDropped st =
  fromMaybe 0 st.activeCardIndex ≠ snapActiveCardIndex st

cardPositionCSS ∷ Int → CSS
cardPositionCSS index = do
  CSSUtils.left $ CSSUtils.calc $
    "(100% + " ⊕ show cardSpacingPx ⊕ "px) * " ⊕ show index

cardSliderTransformCSS ∷ Int → Number → CSS
cardSliderTransformCSS activeCardIndex translateX =
  CSSUtils.transform
    $ CSSUtils.translate3d ((show (-100 * activeCardIndex)) ⊕ "%") "0" "0"
    ⊕ CSSUtils.translate3d ((show (-cardSpacingPx * Int.toNumber activeCardIndex)) ⊕ "px") "0" "0"
    ⊕ CSSUtils.translate3d ((show translateX) ⊕ "px") "0" "0"

cardSliderTransitionCSS ∷ Boolean → CSS
cardSliderTransitionCSS false = CSSUtils.transition "none"
cardSliderTransitionCSS true = CSSUtils.transition "all 0.125s"

dropEffect ∷ Boolean → String
dropEffect true = "execute"
dropEffect false = "none"

containerProperties
  ∷ ∀ a
  . State
  → Array (IProp (onMouseUp ∷ I, onMouseLeave ∷ I, onMouseMove ∷ I | a) (Query Unit))
containerProperties st =
  [ ARIA.dropEffect $ dropEffect $ willChangeActiveCardWhenDropped st ]
    ⊕ (guard (isJust st.initialSliderX)
         $> (HE.onMouseUp \e →
                pure $ Just (H.action (DCQ.StopSlidingAndSnap e))))
    ⊕ (guard (isJust st.initialSliderX)
         $> (HE.onMouseLeave \e →
                pure $ Just (H.action (DCQ.StopSlidingAndSnap e))))
    ⊕ (guard (isJust st.initialSliderX)
         $> (HE.onMouseMove $ HE.input DCQ.UpdateSliderPosition))

cardSelected ∷ State → DCS.DisplayCard → Boolean
cardSelected state card =
  fromMaybe true $
    DCS.eqDisplayCard card <$> DCS.activeCard state

cardPending ∷ State → DCS.DisplayCard → Boolean
cardPending state (Left _) = false
cardPending state (Right { coord }) =
  case state.pendingCardIndex, DCS.cardIndexFromCoord coord state of
    Just ix, Just ix' | ix < ix' → true
    _, _ → false

cardProperties ∷ ∀ a b. State → DCS.DisplayCard → Array (IProp a b)
cardProperties state card =
  [ ARIA.disabled ∘ show ∘ not $ cardSelected state card ]

cardSpacingGridSquares ∷ Number
cardSpacingGridSquares = 2.0

cardSpacingPx ∷ Number
cardSpacingPx = cardSpacingGridSquares * 24.0

renderCard
  ∷ DeckOptions
  → (DeckOptions → DeckComponent)
  → State
  → DCS.DisplayCard
  → Int
  → DeckHTML
renderCard opts deckComponent st card index =
  HH.div
    [ HP.key key
    , HP.classes classes
    , style $ cardPositionCSS index
    ]
    if opts.accessType == AT.ReadOnly
    then
      [ HH.div (cardProperties st card) cardComponent
      , loadingPanel
      ]
    else
      Gripper.renderGrippers
        (cardSelected st card)
        (isJust st.initialSliderX)
        (Gripper.gripperDefsForCard st.displayCards card)
        ⊕ [ HH.div
              (cardProperties st card)
              (cardComponent ⊕ (guard presentAccessNextActionCardGuide $> renderGuide))
          , loadingPanel
          ]
  where
  cardComponent = pure case card of
    Left m → renderMeta st m
    Right cd → renderDef opts deckComponent st cd

  key = case card of
    Left DCS.PendingCard → "card-pending"
    Left (DCS.ErrorCard _) → "card-error"
    Left (DCS.NextActionCard _) → "card-next-action"
    Right { coord } →
      "card-"
        ⊕ DeckId.toString (fst coord) ⊕ "-"
        ⊕ CardId.toString (snd coord)

  classes =
    [ ClassNames.card
    , HH.className case st.fadeTransition of
        DCS.FadeIn   → "sd-fade-in"
        DCS.FadeOut  → "sd-fade-out"
        DCS.FadeNone → "sd-fade-none"
    ]
      ⊕ (guard (not $ isClick st.sliderTranslateX) $> ClassNames.cardSliding)
      ⊕ (guard (cardSelected st card) $> ClassNames.cardActive)
      ⊕ (guard (cardPending st card) $> ClassNames.pending)

  renderGuide =
    Guide.render
      Guide.RightArrow
      (HH.className "sd-access-next-card-guide")
      DCQ.HideAccessNextActionCardGuide
      guideText

  outputs = case card of
    Right { cardType } → ICT.outputsFor (ICT.fromCardType cardType)
    _ → []

  guideText =
    outputs
      # map ICT.printIOType'
      # Array.catMaybes
      # String.joinWith " ? "
      # guideText'

  guideText' outputTypesString =
    "To do more with "
      ⊕ outputTypesString
      ⊕ " click or drag this gripper to the left and add a new card to the deck."

  isLastCard =
    fromMaybe false $
      DCS.eqDisplayCard card <$> DCS.findLastRealCard st

  presentAccessNextActionCardGuide =
    st.presentAccessNextActionCardGuide ∧ isLastCard ∧ st.focused

renderMeta
  ∷ State
  → DCS.MetaCard
  → DeckHTML
renderMeta st card =
  HH.div
    [ HP.classes [ CardCSS.deckCard ] ]
    [ case card of
        DCS.PendingCard →
          HH.div
            [ HP.classes [ HH.className "sd-card-pending" ] ]
            [ HH.slot' ChildSlot.cpPending unit \_ →
                { component: Pending.pendingCardComponent
                , initialState: Pending.initialState
                }
            ]
        DCS.ErrorCard message →
          HH.div
            [ HP.classes [ HH.className "sd-card-error" ] ]
            [ HH.slot' ChildSlot.cpError unit \_ →
                { component: Error.errorCardComponent
                , initialState: { message }
                }
            ]
        DCS.NextActionCard input →
          HH.div
            [ HP.classes [ HH.className "sd-card-next-action" ] ]
            [ HH.slot' ChildSlot.cpNext unit \_ →
                { component: Next.nextCardComponent
                , initialState: H.parentState (Next.initialState input)
                }
            ]
    ]

renderDef
  ∷ DeckOptions
  → (DeckOptions → DeckComponent)
  → State
  → DCS.CardDef
  → DeckHTML
renderDef opts deckComponent st card =
  HH.slot' ChildSlot.cpCard card.coord \_ →
    let
      cardOpts =
        { deck: opts
        , deckComponent
        , cursor: st.id : opts.cursor
        , coord: card.coord
        }
    in
      { component: Factory.cardComponent card.cardType cardOpts
      , initialState: H.parentState CardC.initialCardState
      }

loadingPanel ∷ DeckHTML
loadingPanel =
  HH.div
    [ HP.classes [ HH.className "sd-pending-overlay" ] ]
    [ HH.div_
        [ HH.i_ []
        , HH.span_ [ HH.text "Please wait while this card is evaluated" ]
        ]
  ]

{-
Copyright 2016 SlamData, Inc.

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

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

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}
module SlamData.Workspace.Deck.Slider
  ( startSliding
  , stopSlidingAndSnap
  , updateSliderPosition
  , render
  , containerProperties
  ) where

import SlamData.Prelude

import Data.Array ((..))
import Data.Array as Array
import Data.Int as Int
import Data.Lens ((.~), (?~))
import Data.Lens as Lens
import Data.List ((:))
import Data.String as String
import Data.Tuple as Tuple

import CSS (CSS)

import Halogen as H
import Halogen.HTML.CSS.Indexed (style)
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Events.Types (Event, MouseEvent)
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed (IProp(), I)
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA

import SlamData.Render.CSS as ClassNames
import SlamData.Guide as Guide
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Card.CardId as CardId
import SlamData.Workspace.Card.Component as CardC
import SlamData.Workspace.Card.Component.CSS as CardCSS
import SlamData.Workspace.Card.InsertableCardType as ICT
import SlamData.Workspace.Card.Factory as Factory
import SlamData.Workspace.Card.Next.Component as Next
import SlamData.Workspace.Card.Error.Component as Error
import SlamData.Workspace.Card.Pending.Component as Pending
import SlamData.Workspace.Deck.Common (DeckOptions, DeckHTML, DeckDSL)
import SlamData.Workspace.Deck.Component.ChildSlot as ChildSlot
import SlamData.Workspace.Deck.Component.Cycle (DeckComponent)
import SlamData.Workspace.Deck.Component.Query (Query)
import SlamData.Workspace.Deck.Component.Query as DCQ
import SlamData.Workspace.Deck.Component.State (State)
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckId as DeckId
import SlamData.Workspace.Deck.Gripper as Gripper
import SlamData.Workspace.Deck.Gripper.Def (GripperDef(..))

import Utils.CSS as CSSUtils

render ∷ DeckOptions → (DeckOptions → DeckComponent) → State → Boolean → DeckHTML
render opts deckComponent st visible =
  HH.div
    ([ HP.key "deck-cards"
     , HP.classes [ ClassNames.cardSlider ]
     , HE.onTransitionEnd $ HE.input_ DCQ.StopSliderTransition
     , style do
         cardSliderTransformCSS (fromMaybe 0 st.activeCardIndex) st.sliderTranslateX
         cardSliderTransitionCSS st.sliderTransition
     ]
     ⊕ (guard (not visible) $> (HP.class_ ClassNames.invisible)))
    $ map (Tuple.uncurry $ renderCard opts deckComponent st)
    $ Array.zip st.displayCards (0 .. Array.length st.displayCards)

startSliding ∷ Event MouseEvent → GripperDef → DeckDSL Unit
startSliding mouseEvent gDef = do
  cardWidth ← H.gets _.cardElementWidth
  H.modify
    $ (DCS._initialSliderX .~ Just mouseEvent.screenX)
    ∘ (DCS._initialSliderCardWidth .~ cardWidth)
    ∘ (DCS._sliderTransition .~ false)
    ∘ (DCS._fadeTransition .~ DCS.FadeIn)
    ∘ (DCS._displayMode .~ DCS.Normal)
    ∘ (DCS._slidingTo ?~ gDef)

stopSlidingAndSnap ∷ Event MouseEvent → DeckDSL Unit
stopSlidingAndSnap mEvent =
  H.modify
    $ stopSliding
    ∘ snap
    ∘ stateUpdateSliderPosition mEvent

stateUpdateSliderPosition ∷ Event MouseEvent → State → State
stateUpdateSliderPosition mouseEvent =
  maybe id (Lens.set DCS._sliderTranslateX ∘ translateXCalc mouseEvent.screenX)
    <$> _.initialSliderX
    <*> id

updateSliderPosition ∷ Event MouseEvent → DeckDSL Unit
updateSliderPosition = H.modify ∘ stateUpdateSliderPosition

translateXCalc ∷ Number → Number → Number
translateXCalc eventScreenX initialX =
  eventScreenX - initialX

stopSliding ∷ State → State
stopSliding =
  (DCS._initialSliderX .~ Nothing)
  ∘ (DCS._sliderTranslateX .~ 0.0)
  ∘ (DCS._slidingTo .~ Nothing)
  ∘ (DCS._fadeTransition .~ DCS.FadeOut)
  ∘ startTransition

clickBound ∷ Number
clickBound = 4.0

isClick ∷ Number -> Boolean
isClick n = n < clickBound ∧ n > -clickBound

snapActiveCardIndexByTranslationAndCardWidth
  ∷ State
  → Number
  → Int
  → Int
snapActiveCardIndexByTranslationAndCardWidth st cardWidth idx =
  let
    translateX = st.sliderTranslateX

    numberOfCards = Array.length st.displayCards

    halfOffset = (offsetCardSpacing cardWidth) / 2.0

    result | isClick translateX  = case st.slidingTo of
      Just (Previous true) → min (numberOfCards - 1) $ idx - one
      Just (Next true) → max 0 $ idx + one
      _ → idx
    result | translateX <= -1.0 * halfOffset =
      min (numberOfCards - 1)
      $ sub idx
      $ one
      + Int.floor ((translateX - halfOffset) / cardWidth)
    result | translateX >= halfOffset =
      max 0
      $ idx
      + one
      + Int.floor ((-translateX - halfOffset) / cardWidth)
    result | otherwise =
      idx
  in
    result

offsetCardSpacing ∷ Number → Number
offsetCardSpacing = add cardSpacingPx

snapActiveCardIndex ∷ State → Int
snapActiveCardIndex st = maybe id snap' st.initialSliderCardWidth $ fromMaybe 0 st.activeCardIndex
  where
  snap' = snapActiveCardIndexByTranslationAndCardWidth st

snap ∷ State → State
snap st = st { activeCardIndex = Just $ snapActiveCardIndex st }

startTransition ∷ State → State
startTransition = DCS._sliderTransition .~ true

willChangeActiveCardWhenDropped ∷ State → Boolean
willChangeActiveCardWhenDropped st =
  fromMaybe 0 st.activeCardIndex ≠ snapActiveCardIndex st

cardPositionCSS ∷ Int → CSS
cardPositionCSS index = do
  CSSUtils.left $ CSSUtils.calc $
    "(100% + " ⊕ show cardSpacingPx ⊕ "px) * " ⊕ show index

cardSliderTransformCSS ∷ Int → Number → CSS
cardSliderTransformCSS activeCardIndex translateX =
  CSSUtils.transform
    $ CSSUtils.translate3d ((show (-100 * activeCardIndex)) ⊕ "%") "0" "0"
    ⊕ CSSUtils.translate3d ((show (-cardSpacingPx * Int.toNumber activeCardIndex)) ⊕ "px") "0" "0"
    ⊕ CSSUtils.translate3d ((show translateX) ⊕ "px") "0" "0"

cardSliderTransitionCSS ∷ Boolean → CSS
cardSliderTransitionCSS false = CSSUtils.transition "none"
cardSliderTransitionCSS true = CSSUtils.transition "all 0.125s"

dropEffect ∷ Boolean → String
dropEffect true = "execute"
dropEffect false = "none"

containerProperties
  ∷ ∀ a
  . State
  → Array (IProp (onMouseUp ∷ I, onMouseLeave ∷ I, onMouseMove ∷ I | a) (Query Unit))
containerProperties st =
  [ ARIA.dropEffect $ dropEffect $ willChangeActiveCardWhenDropped st ]
    ⊕ (guard (isJust st.initialSliderX)
         $> (HE.onMouseUp \e →
                pure $ Just (H.action (DCQ.StopSlidingAndSnap e))))
    ⊕ (guard (isJust st.initialSliderX)
         $> (HE.onMouseLeave \e →
                pure $ Just (H.action (DCQ.StopSlidingAndSnap e))))
    ⊕ (guard (isJust st.initialSliderX)
         $> (HE.onMouseMove $ HE.input DCQ.UpdateSliderPosition))

cardSelected ∷ State → DCS.DisplayCard → Boolean
cardSelected state card =
  fromMaybe true $
    DCS.eqDisplayCard card <$> DCS.activeCard state

cardPending ∷ State → DCS.DisplayCard → Boolean
cardPending state (Left _) = false
cardPending state (Right { coord }) =
  case state.pendingCardIndex, DCS.cardIndexFromCoord coord state of
    Just ix, Just ix' | ix < ix' → true
    _, _ → false

cardProperties ∷ ∀ a b. State → DCS.DisplayCard → Array (IProp a b)
cardProperties state card =
  [ ARIA.disabled ∘ show ∘ not $ cardSelected state card ]

cardSpacingGridSquares ∷ Number
cardSpacingGridSquares = 2.0

cardSpacingPx ∷ Number
cardSpacingPx = cardSpacingGridSquares * 24.0

renderCard
  ∷ DeckOptions
  → (DeckOptions → DeckComponent)
  → State
  → DCS.DisplayCard
  → Int
  → DeckHTML
renderCard opts deckComponent st card index =
  HH.div
    [ HP.key key
    , HP.classes classes
    , style $ cardPositionCSS index
    ]
    if opts.accessType == AT.ReadOnly
    then
      [ HH.div (cardProperties st card) cardComponent
      , loadingPanel
      ]
    else
      Gripper.renderGrippers
        (cardSelected st card)
        (isJust st.initialSliderX)
        (Gripper.gripperDefsForCard st.displayCards card)
        ⊕ [ HH.div
              (cardProperties st card)
              (cardComponent ⊕ (guard presentAccessNextActionCardGuide $> renderGuide))
          , loadingPanel
          ]
  where
  cardComponent = pure case card of
    Left m → renderMeta st m
    Right cd → renderDef opts deckComponent st cd

  key = case card of
    Left DCS.PendingCard → "card-pending"
    Left (DCS.ErrorCard _) → "card-error"
    Left (DCS.NextActionCard _) → "card-next-action"
    Right { coord } →
      "card-"
        ⊕ DeckId.toString (fst coord) ⊕ "-"
        ⊕ CardId.toString (snd coord)

  classes =
    [ ClassNames.card
    , HH.className case st.fadeTransition of
        DCS.FadeIn   → "sd-fade-in"
        DCS.FadeOut  → "sd-fade-out"
        DCS.FadeNone → "sd-fade-none"
    ]
      ⊕ (guard (not $ isClick st.sliderTranslateX) $> ClassNames.cardSliding)
      ⊕ (guard (cardSelected st card) $> ClassNames.cardActive)
      ⊕ (guard (cardPending st card) $> ClassNames.pending)

  renderGuide =
    Guide.render
      Guide.RightArrow
      (HH.className "sd-access-next-card-guide")
      DCQ.HideAccessNextActionCardGuide
      guideText

  outputs = case card of
    Right { cardType } → ICT.outputsFor (ICT.fromCardType cardType)
    _ → []

  guideText =
    outputs
      # map ICT.printIOType'
      # Array.catMaybes
      # String.joinWith " ? "
      # guideText'

  guideText' outputTypesString =
    "To do more with "
      ⊕ outputTypesString
      ⊕ " click or drag this gripper to the left and add a new card to the deck."

  isLastCard =
    fromMaybe true $
      DCS.eqDisplayCard card <$> DCS.findLastRealCard st

  presentAccessNextActionCardGuide =
    st.presentAccessNextActionCardGuide ∧ isLastCard ∧ st.focused

renderMeta
  ∷ State
  → DCS.MetaCard
  → DeckHTML
renderMeta st card =
  HH.div
    [ HP.classes [ CardCSS.deckCard ] ]
    [ case card of
        DCS.PendingCard →
          HH.div
            [ HP.classes [ HH.className "sd-card-pending" ] ]
            [ HH.slot' ChildSlot.cpPending unit \_ →
                { component: Pending.pendingCardComponent
                , initialState: Pending.initialState
                }
            ]
        DCS.ErrorCard message →
          HH.div
            [ HP.classes [ HH.className "sd-card-error" ] ]
            [ HH.slot' ChildSlot.cpError unit \_ →
                { component: Error.errorCardComponent
                , initialState: { message }
                }
            ]
        DCS.NextActionCard input →
          HH.div
            [ HP.classes [ HH.className "sd-card-next-action" ] ]
            [ HH.slot' ChildSlot.cpNext unit \_ →
                { component: Next.nextCardComponent
                , initialState: H.parentState (Next.initialState input)
                }
            ]
    ]

renderDef
  ∷ DeckOptions
  → (DeckOptions → DeckComponent)
  → State
  → DCS.CardDef
  → DeckHTML
renderDef opts deckComponent st card =
  HH.slot' ChildSlot.cpCard card.coord \_ →
    let
      cardOpts =
        { deck: opts
        , deckComponent
        , cursor: st.id : opts.cursor
        , coord: card.coord
        }
    in
      { component: Factory.cardComponent card.cardType cardOpts
      , initialState: H.parentState CardC.initialCardState
      }

loadingPanel ∷ DeckHTML
loadingPanel =
  HH.div
    [ HP.classes [ HH.className "sd-pending-overlay" ] ]
    [ HH.div_
        [ HH.i_ []
        , HH.span_ [ HH.text "Please wait while this card is evaluated" ]
        ]
  ]


findPos

findPos


added Binary Search in Purescript

added Binary Search in Purescript

module BinarySearch where

import Prelude

import Data.Array (index, length)
import Data.Int (floor, toNumber)
import Data.Maybe (Maybe(..))

--Assume the list is sorted
--return the position of the value otherwise it return -1
binarySearch :: Int -> Array Int -> Int
binarySearch _ [] = (-1)
binarySearch x arr = findMid x arr 0 ((length arr) - 1)

findMid :: Int -> Array Int -> Int -> Int -> Int
findMid x arr low high | low <= high = checkMid (floor (toNumber(low + high))/2) (index arr (floor (toNumber(low + high))/2)) x arr low high
                       | otherwise = (-1)

checkMid :: Int -> Maybe Int -> Int -> Array Int -> Int -> Int -> Int
checkMid pos (Just val) x arr low high
                          | val < x = findMid x arr (pos + 1) high
                          | val > x = findMid x arr low (pos - 1)
                          | otherwise = pos
checkMid pos Nothing x arr low high = (-1)

error: pathspec 'search/binary_search/purescript/binary_search.purs' did not match any file(s) known to git


Include current chromosome in view, since it's used by BD features.

module Genetics.Browser.Types where

import Data.Foreign (Foreign)

type Point = { x :: Number, y :: Number}

type View = { viewStart :: Number
            , scale :: Number
            , height :: Number
            , chr :: String
            }

-- TODO: replace Array Foreign with Array ForeignFeature
-- or similar, for clarity. Could be a newtype or type synonym
type Renderer = View -> Array Foreign -> Foreign

module Genetics.Browser.Types where

import Data.Foreign (Foreign)

type Point = { x :: Number, y :: Number}

type View = { viewStart :: Number
            , scale :: Number
            , height :: Number
            }

-- TODO: replace Array Foreign with Array ForeignFeature
-- or similar, for clarity. Could be a newtype or type synonym
type Renderer = View -> Array Foreign -> Foreign


added Cluster back in

added Cluster back in

module Test.Cluster ( doCluster, fsmw ) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console ( CONSOLE, log )
import FV.Types ( VHMeas )

doCluster :: forall e. VHMeas -> Eff (console :: CONSOLE | e) Unit
doCluster vm' = do
  log "test doCluster"

type WeightedPoint = Number
fsmw :: Int -> Array WeightedPoint -> WeightedPoint
fsmw 1 [x] = x
fsmw _ _ = 0.0
{-- import FV.Types (  VHMeas (..), HMeas (..), QMeas (..), Prong (..) --}
{--   , XMeas (..), xXMeas, yXMeas --}
{--   , XFit (..), Chi2 (..) --}
{--   , chi2Vertex, zVertex, z0Helix ) --}
{-- import FV.Fit ( kAdd, kAddF, ksm', kChi2, fit ) --}
{-- import Data.Cov --}

{-- --import Data.Text --}

{-- import Data.Maybe ( Maybe (..) ) --}
{-- import Data.List ( List (..), mapMaybe, catMaybes, sort ) --}
{-- import Data.Tuple ( Tuple (..) ) --}
{-- import Math ( abs, exp, sqrt ) as Math --}
{-- --import Math.Gamma ( q ) as Math.Gamma --}
{-- import Data.Array ( filter ) as A --}

{-- --import Text.Printf ( printf ) --}
{-- -- import Control.Monad ( when ) --}
{-- -- import Data.Maybe ( mapMaybe ) --}
{-- -- import qualified Graphics.Gnuplot.Frame.OptionSet as Opts --}
{-- --import Graphics.Histogram --}

{-- import Stuff --}

{-- doCluster :: forall e. VHMeas -> Eff (console :: CONSOLE | e) Unit --}
{-- doCluster vm' = do --}
{--   let vm = cleanup vm' --}
{--       v0 = vertex vm' -- beamspot --}
{--   putStrLn $ "beam spot -> " <> show v0 --}
{--   putStrLn $ "# tracks  -> " <> show (length . helices $ vm') --}
{--   putStrLn $ "# after cleanup-> " <> show (length . helices $ vm) --}

  {-- let histz = histogramNumBins 90 $ zs vm --}
  {-- -- _ <- plot "cluster-z.png" histz --}
  {-- let histp = histogramNumBins 11 $ 1.0 : 0.0 : probs vm --}
  {-- --  _ <- plot "cluster-pd.png" histp --}

  {-- let Node p0 ht = vList vm --}
  {-- putStrLn "---------------------------------------------------------" --}
  {-- print $ vList vm --}
  {-- -- print . nProng $ p0 --}
  {-- -- print . vertex . measurements $ p0 --}
  {-- -- print . fitVertex $ p0 --}
  {-- -- print . zip (fitChi2s p0) . map z0Helix . helices . measurements $ p0 --}
  {-- case ht of --}
  {--   Empty     -> putStrLn "Empty" --}
  {--   Node p1 _ -> print $ fitVertex p1 --}
  {-- pure unit --}

{-- ftvtx :: Prong -> Tuple Number List Chi2 --}
{-- ftvtx p = Tuple (zVertex . xFit . fitVertex $ p) (fitChi2s p) --}

{-- xFit :: XMeas -> XFit --}
{-- xFit (XMeas v vv) = XFit v vv (Chi2 1e6) --}

{-- gamma :: Chi2 -> Number --}
{-- gamma (Chi2 c2) = Math.Gamma.q 1.0 c2 --}
{-- probs :: VHMeas -> Array Number --}
{-- probs (VHMeas v hl) = A.filter (\x -> x>0.01) $ map (gamma <<< chi2Vertex <<< kAddF (xFit v)) hl --}
{-- zs :: VHMeas -> Array Number --}
{-- zs (VHMeas v hl) = A.filter (\x -> Math.abs x<10.0) $ map (zVertex <<< kAddF (xFit v)) hl --}

{-- cleanup :: VHMeas -> VHMeas --}
{-- -- remove vm helices that are incompatible with vm vertex --}
{-- cleanup (VHMeas v hl) = VHMeas v hl' where --}
  {-- hl' = sortOn z0Helix . mapMaybe (filtProb 0.01 v) $ hl --}

{-- filtProb :: Number -> XMeas -> HMeas -> Maybe HMeas --}
{-- filtProb cut v h = mh where --}
{-- -- check chi2 of this helix w/r to vertex position v --}
  {-- vf  =   kAddF (xFit v) h --}
  {-- zvf =   zVertex vf --}
  {-- Chi2 chi2f = chi2Vertex vf --}
  {-- prob =  gamma $ Chi2 (chi2f/2.0) -- chi2 distribution with NDOF=2 --}
  {-- good =  (prob > cut) && Math.abs zvf < 10.0 --}
  {-- mh =    if good --}
  {--           then Just h --}
  {--           else Nothing --}

{-- -- Now the "v" parameter can be mapped over without any care for list invariants --}
{-- data HList v = Empty | Node v (HList v) deriving (hListShow::Show, hListFunctor::Functor) --}

{-- vList :: VHMeas -> HList Prong --}
{-- vList vm = Node p vRight where --}
  {-- Tuple p vmr = cluster vm --}
  {-- vRight = case vmr of --}
  {--            Nothing -> Empty --}
  {--            Just vm' -> vList vm' --}

{-- wght :: Number -> Chi2 -> Number -- weight function with Temperature t --}
{-- wght t (Chi2 chi2) = w where --}
  {-- chi2cut = 3.0 --}
  {-- w = 1.0/(1.0 + Math.exp ((chi2-chi2cut)/2.0/t)) --}

{-- cluster'' :: VHMeas -> (Tuple Prong  (Maybe VHMeas)) --}
{-- cluster'' vm | trace ("--> cluster called with " <> (show . length . helices $ vm) <> " helices, initial vertex at " <> (show . vertex $ vm) ) false = undefined --}
{-- cluster'' (VHMeas v hl) = trace ( --}
  {--       "--> cluster debug:" --}
  {--       <> "\n--> cluster fit zs " <> show zs --}
  {--       <> "\n--> cluster fit vertex " <> show (fitVertex p) --}
  {--       <> "\n--> cluster # remaining helices " <> show ( length hlr) <> (show . fmap z0Helix . take 3 $ hlr) --}
  {--       ) (Tuple  p r) where --}
  {-- -- split off 10 h with lowest z and determine initial fit position with FSMW --}
  {-- (Tuple hl' hlr) = splitAt 10 . sortOn z0Helix $ hl --}

  {-- -- constract vertex v0 at z=z0 as starting point, using cov matrix from v --}
  {-- zs = sort . filter (\x -> Math.abs x < 10.0) . map (zVertex . kAddF (xFit v)) $ hl' --}
  {-- z0 = fsmw (length zs) zs --}
  {-- XMeas vx0 cx0  = v --}
  {-- v0 = XMeas Vec {v= fromList [xXMeas v, yXMeas v, z0]} cx0 --}

  {-- -- do the fit with v0 --}
  {-- p             = fit (VHMeas v0 hl') --}

  {-- r = case length hlr of --}
  {--       0 -> Nothing --}
  {--       _ -> Just (VHMeas v hlr) --}

{-- cluster :: VHMeas -> (Tuple Prong Maybe VHMeas) --}
{-- cluster vm | trace ("--> cluster called with " <> (show . length . helices $ vm) <> " helices, initial vertex at " <> (show . vertex $ vm) ) false = undefined --}
{-- cluster (VHMeas v hllll) = trace ( --}
  {--       "--> cluster debug:" --}
  {--       <> "\n--> cluster zs=" <> take 160 (show zs) --}
  {--       <> printf "\n--> cluster z0=%9.3f " (z0 :: Number) --}
  {--       <> "\n--> cluster v0=" <> show v0 --}
  {--       <> "\n--> cluster fit v0 hl0 " <> (show . ftvtx . fit $ VHMeas v0 $take 10 hl) --}
  {--       <> "\n--> cluster fit v0 hl0 " <> (show . ftvtx . fit $ VHMeas v0 $ take 10 $ drop 10 hl) --}
  {--       <> "\n--> cluster fit v0 hl0 " <> (show . ftvtx . fit $ VHMeas v0 $take 10 $ drop 20 hl) --}
  {--       <> "\n--> cluster fit v0 hl0 " <> (show . ftvtx . fit $ VHMeas v0 $take 10 $ drop 30 hl) --}
  {--       <> "\n--> cluster fit v0 hl0 " <> (show . ftvtx . fit $ VHMeas v0 $take 10 $ drop 40 hl) --}
  {--       <> "\n--> cluster fit v0 hl0 " <> (show . ftvtx . fit $ VHMeas v0 $take 10 $ drop 50 hl) --}
  {--       <> "\n--> cluster fit v0 hl0 " <> (show . ftvtx . fit $ VHMeas v0 $take 10 $ drop 60 hl) --}
  {--       <> "\n--> cluster v1: #hl0=" <> (show . length . catMaybes $ hl0) <> " v1=" <> show v1 --}
  {--       <> "\n--> cluster chi2s1" <> (take 160 . foldl (\s c -> s <> bDouble c) "") c21s --}
  {--       <> "\n--> cluster weights1" <> (take 160 . foldl (\s w -> s <> sDouble w) "") ws1 --}
  {--       <> "\n--> cluster v2=" <> show v2 --}
  {--       <> "\n--> cluster chi2s2" <> (take 160 . foldl (\s c -> s <> bDouble c) "") c22s --}
  {--       <> "\n--> cluster weights2" <> (take 160 . foldl (\s w -> s <> sDouble w) "") ws2 --}
  {--       <> "\n--> cluster v3=" <> show v3 --}
  {--       <> "\n--> cluster chi2s3" <> (take 160 . foldl (\s c -> s <> bDouble c) "") c23s --}
  {--       <> "\n--> cluster weights3" <> (take 160 . foldl (\s w -> s <> sDouble w) "") ws3 --}
  {--       <> "\n--> cluster v4=" <> show v4 --}
  {--       <> "\n--> cluster chi2s4" <> (take 160 . foldl (\s c -> s <> bDouble c) "") c24s --}
  {--       <> "\n--> cluster weights4" <> (take 160 . foldl (\s w -> s <> sDouble w) "") ws4 --}
  {--       <> "\n--> cluster v5=" <> show v5 --}
  {--       <> "\n-----------------------------------------------------------------" --}
  {--       <> "\n--> cluster #hl1=" <> (show . length . catMaybes $ hl1) <> " vv=" <> show vv --}
  {--       <> printf "\n--> cluster nothing=%5d just=%5d" (length hlnothing) (length hljust) --}
  {--       <> "\n--> cluster nProng=" <> show nProng --}
  {--                                 ) --}
  {--   (Tuple p r ) where --}

  {-- sDouble :: Number -> String --}
  {-- sDouble c = if c > 0.001 --}
  {--               then printf "%6.3f" c --}
  {--               else " eps" --}

  {-- bDouble :: Chi2 -> String --}
  {-- bDouble (Chi2 c) = if c<999.9 --}
  {--               then printf "%6.1f" c --}
  {--               else " big" --}

  {-- hl = hllll --}

  {-- -- FSMW method to find initial z for primary vertex --}
  {-- zs = sort . filter (\x -> Math.abs x < 10.0) . map (zVertex . kAddF (xFit v)) $ hl --}
  {-- z0 = fsmw (length zs) zs --}
  {-- -- constract vertex v0 at z=z0 as starting point, using cov matrix from v --}
  {-- XMeas vx0 cx0  = v --}
  {-- v0 = XMeas Vec {v= fromList [xXMeas v, yXMeas v, z0]} cx0 --}
  {-- -- filter hl for v1, with starting point v0 --}
  {-- hl0 :: Array (Maybe HMeas) --}
  {-- hl0           = map (filtProb 0.00001 v0) hl --}
  {-- v1            = foldl (\v mh -> case mh of --}
  {--                                   Just h -> kAdd v h --}
  {--                                   Nothing -> v) v0 hl0 --}

  {-- kAddW' :: XMeas -> (Tuple (Maybe HMeas) Number) -> XMeas --}
  {-- kAddW' v (Tuple mh w) =  case mh of --}
  {--                       Just h -> kAdd v h --}
  {--                       Nothing -> v --}
  {-- annealingSchedule = [256.0, 64.0, 16.0, 4.0, 1.0] --}
  {-- t0 = head annealingSchedule --}
  {-- t1 = annealingSchedule !! 3 --}

  {-- c21s          = map (\mh -> case mh of --}
  {--                               Just h -> kChi2 v1 h --}
  {--                               Nothing -> Chi2 0.0) hl0 --}
  {-- ws1 = fmap (max 0.001 . wght t0) c21s --}
  {-- v2 = foldl kAddW' v1 $ zip hl0 ws1 --}
  {-- c22s          = map (\mh -> case mh of --}
  {--                               Just h -> kChi2 v2 h --}
  {--                               Nothing -> Chi2 0.0) hl0 --}
  {-- ws2 = fmap (max 0.001 . wght t0) c22s --}
  {-- v3 = foldl kAddW' v2 $ zip hl0 ws2 --}
  {-- c23s          = map (\mh -> case mh of --}
  {--                               Just h -> kChi2 v3 h --}
  {--                               Nothing -> Chi2 0.0) hl0 --}
  {-- ws3 = fmap (max 0.001 . wght 4.0) c23s --}
  {-- v4 = foldl kAddW' v3 $ zip hl0 ws3 --}
  {-- c24s          = map (\mh -> case mh of --}
  {--                               Just h -> kChi2 v4 h --}
  {--                               Nothing -> Chi2 0.0) hl0 --}
  {-- ws4 = fmap (max 0.001 . wght 1.0) c24s --}
  {-- v5 = foldl kAddW' v4 $ zip hl0 ws4 --}

  {-- vv0 = v5 --}

  {-- -- cut any track with prob < 0.001 w/r to v1 --}
  {-- hl1           = map (filtProb 0.00001 vv0) hl --}
  {-- -- re-do filter with initial position and filtered helices --}
  {-- vv            = foldl (\v h -> case h of --}
  {--                                 Just h' -> kAdd v h' --}
  {--                                 Nothing -> v) vv0 hl1 --}
  {-- -- smooth with vv --}
  {-- ll :: List (Tuple (Maybe (Tuple QMeas Chi2)) HMeas) --}
  {-- ll        = zip (map (ksm' vv) hl1) hl --}
  {-- hlnothing :: Array HMeas --}
  {-- hlnothing = do --}
  {--   (Tuple Nothing h) <- ll --}
  {--   pure h --}
  {-- hljust :: Array HMeas --}
  {-- hljust = do --}
  {--   Tuple (Just (Tuple q c2)) h <- ll --}
  {--   pure h --}
  {-- qljust = do --}
  {--   Tuple (Just (Tuple q c2)) h <- ll --}
  {--   pure q --}
  {-- c2just = do --}
  {--   Tuple (Just (Tuple q c2)) h <- ll --}
  {--   pure c2 --}

  {-- fitVertex    = vv --}
  {-- fitMomenta   = qljust --}
  {-- fitChi2s     = c2just --}
  {-- nProng       = length qljust --}
  {-- measurements = VHMeas v hljust --}
{-- --  p = Prong  {..} --}

  {-- nnn = fromIntegral (length hlnothing) `div` 3 --}
  {-- r = if null hlnothing then Nothing --}
  {--       else  Just (VHMeas v (drop nnn  hlnothing)) --}

{-- -- ------------------------------------------------------- --}
{-- -- use robust Mode finding to get initial vertex position --}
{-- -- ------------------------------------------------------- --}
{-- -- Fraction-of Sample Mode with Weight method, --}
{-- -- see Frühwirth & Waltenberger CMS Note 2007/008 --}
{-- --newtype WeightedPoint = WeightedPoint Number --}
{-- type WeightedPoint = Number --}
{-- fsmw :: Int -> List WeightedPoint -> WeightedPoint --}
{-- fsmw 1 xs = uidx 0 xs --}
{-- fsmw 2 [x0, x1] = 0.5 * (x1+x0) --}
{-- fsmw 3 [x0, x1, x2] = case 2*x1-x0-x2 of --}
  {--                      xx | xx < 0 -> (x0+x1)/2.0 --}
  {--                      xx | xx > 0 -> (x1+x2)/2.0 --}
  {--                      xx | xx == 0 -> x1 --}
{-- -- fsmw 4 [x0, x1, x2, x3] = x where --}
{-- --   w  = weightOfInterval [x0, x1, x2, x3] --}
{-- --   w0 = weightOfInterval [x0, x1, x2] --}
{-- --   w1 = weightOfInterval [x1, x2, x3] --}
{-- --   x  = if w0/w < w1/w then fsmw 3 [x0, x1, x2] else fsmw 3 [x1, x2, x3] `debug` (show w <> ", " <> show w0 <> ", " <> show w1) --}
{-- fsmw n xs = h where --}
  {-- h = if n>6 then hsm n xs -- for large n, fall back to no-weight hsm formula --}
  {--         else fsmw n' xs' where --}
  {--           alpha = 0.5 :: Number --}
  {--           n' = ceiling (fromIntegral n * alpha) --}
  {--           findMin :: (Tuple WeightedPoint Int) -> (Tuple WeightedPoint Int) -> (Tuple WeightedPoint Int) --}
  {--           findMin (Tuple w0 j0) (Tuple w j) = if w<w0 || w0<0 then (Tuple w j) else (Tuple w0 j0) --}
  {--           -- (Tuple _ j') = foldl' findMin (Tuple -1.0 0) <<< zip (map ( \j ->  weightOfInterval <<< take n' <<< drop j $ xs ) [0..(n-n')]) $ [0  .. n] --}
  {--           Array WeightedPoint ys0 = 0 .. n --}
  {--           Array WeightedPoint ys1 = do --}
  {--              j <- 0 .. (n-n') --}
  {--              pure $ weightOfInterval <<< take n' <<< drop j $ xs --}
  {--           (Tuple _ j') = foldl' (findMin (Tuple -1.0 0)) zip ys1 ys0 --}
  {--           xs' = take n' <<< drop j' $ xs -- `debug` ("fsmw--> " <> show n <> ", " <> show n' <> ", " <> show j' <> ", " <> show xs) --}

{-- -- HalfSampleMode --}
{-- -- see Bickel & Frühwirth, On a Fast, Robust Estimator of the Mode, 2006 --}
{-- -- http://ideas.repec.org/a/eee/csdana/v50y2006i12p3500-3530.html --}
{-- hsm :: Int -> Array WeightedPoint -> WeightedPoint --}
{-- hsm n xs = fsmw n' xs' where --}
  {-- alpha = 0.5 :: Number --}
  {-- n' = ceiling (fromIntegral n * alpha) --}
  {-- xns = drop (n'-1) xs --}
  {-- wmin = last xs - head xs --}
  {-- findMin :: (Tuple WeightedPoint Int) -> (Tuple WeightedPoint Int) -> (Tuple WeightedPoint Int) --}
  {-- findMin (Tuple w0 j0) (Tuple w j) = if w<w0 then (Tuple w j) else (Tuple w0 j0) --}
  {-- calcWeight :: WeightedPoint -> WeightedPoint -> WeightedPoint --}
  {-- calcWeight = (-) --}
  {-- (Tuple _ j') = foldl' findMin (Tuple wmin 0) <<< zip (zipWith calcWeight xns xs) $ 0 .. n --}
  {-- xs' = take n' <<< drop j' $ xs --`debug` ("hsm---> " <> show n <> ", " <> show n' <> ", " <> show j' <> ", " <> show xs <> ", " <> show xns) --}

{-- wDist :: WeightedPoint -> WeightedPoint -> WeightedPoint --}
{-- wDist x0 x1 = 1.0 / Math.sqrt (x1 - x0 + dmin) where dmin = 0.001 -- 10 µm --}
{-- weightOfInterval :: Array WeightedPoint -> WeightedPoint --}
{-- weightOfInterval xs = w where --`debug` ("weightOfInterval--> " <> show xs <> ", " <> show ws <> ", " <> show w) where --}
  {-- ws :: Array WeightedPoint --}
  {-- ws = do --}
  {--   x0 <- xs --}
  {--   x1 <- xs --}
  {--   guard $ x1>x0 --}
  {--   pure $ wDist x0 x1 --}
  {-- -- ws = [ wDist x0 x1 | x0 <- xs , x1 <- xs, x1>x0] --}
  {-- w  = (last xs - head xs) / sum ws --}

{-
-- gamma function P(a, x) from https://wiki.haskell.org/Gamma_and_Beta_function
-- approximation is taken from [Lanczos, C. 1964 SIAM Journal on Numerical Analysis,
-- ser. B, vol. 1, pp. 86-96]

-- standard normal CDF https://www.johndcook.com/blog/haskell-erf/
erf :: Number -> Number
erf x = sign*y
    where
        a1 =  0.254829592
        a2 = -0.284496736
        a3 =  1.421413741
        a4 = -1.453152027
        a5 =  1.061405429
        p  =  0.3275911

        -- Abramowitz and Stegun formula 7.1.26
        sign = if x > 0
                   then  1
                   else -1
        t  =  1.0/(1.0 + p* Math.abs x)
        y  =  1.0 - (((((a5*t + a4)*t) + a3)*t + a2)*t + a1)*t*Math.exp(-x*x)

test_erf :: Bool
test_erf = maximum [ Math.abs(erf x - y)  | (x, y) <- zip xs ys ] < epsilon
    where
        epsilon = 1.5e-7 -- accuracy promised by A&S
        xs = [-3, -1, 0.0, 0.5, 2.1 ]
        ys = [-0.999977909503,
              -0.842700792950,
               0.0,
               0.520499877813,
               0.997020533344]

-- standard normal CDF https://www.johndcook.com/blog/haskell-phi/
phi :: Number -> Number
phi x = y
    where
        a1 =  0.254829592
        a2 = -0.284496736
        a3 =  1.421413741
        a4 = -1.453152027
        a5 =  1.061405429
        p  =  0.3275911

        -- Abramowitz and Stegun formula 7.1.26
        sign = if x > 0
                   then  1
                   else -1
        t = 1.0/(1.0 + p * Math.abs x / Math.sqrt 2.0)
        e = 1.0 - (((((a5*t + a4)*t) + a3)*t + a2)*t + a1)*t*Math.exp(-x*x/2.0)
        y = 0.5*(sign*e + 1.0)

test_phi :: Bool
test_phi = maximum [ Math.abs(phi x - y) | (x, y) <- zip xs ys ] < epsilon
    where
        epsilon = 1.5e-7 -- accuracy promised by A&S
        xs = [-3, -1, 0.0, 0.5, 2.1 ]
        ys = [0.00134989803163,
              0.158655253931,
              0.5,
              0.691462461274,
              0.982135579437]

-- returns the number of samples and the mean,
-- but does not directly return variance, skewness and kurtosis.
-- Instead it returns moments from which these statistics can easily be calculated
-- using the mvks function
moments (n, m1, m2, m3, m4) x = (n', m1', m2', m3', m4')
        where
            n' = n + 1
            delta = x - m1
            delta_n = delta / n'
            delta_n2 = delta_n**2
            t = delta*delta_n*n
            m1' = m1 + delta_n
            m4' = m4 + t*delta_n2*(n'*n' - 3*n' + 3) + 6*delta_n2*m2 - 4*delta_n*m3
            m3' = m3 + t*delta_n*(n' - 2) - 3*delta_n*m2
            m2' = m2 + t

mvsk (n, m1, m2, m3, m4) = (m1, m2/(n-1.0), (Math.sqrt n)*m3/m2**1.5, n*m4/m2**2 - 3.0)
-}

error: pathspec 'src/Test/Cluster.purs' did not match any file(s) known to git


Added Demo.purs

Added Demo.purs

module Tutorial.Ractive.Main where

import Control.Monad.Eff
import qualified Control.Monad.Eff.Ractive as Ract
import Debug.Trace
import Control.Apply ((*>),(<*))
import Control.Bind ((>=>))
import Control.Monad.Trans
import Control.Monad.Cont.Trans
import Data.Maybe
import Network.HTTP
import Network.XHR
import Tutorial.Ractive

type Template = String

type TutorialPartials = {
  output  :: Template,
  content :: Template}

tutorialPartials :: Template -> Template -> TutorialPartials
tutorialPartials output content = {output: output, content: content}

type TutorialConfig = {
  contentTemplate :: URI,
  outputTemplate :: URI,
  element :: String,
  template :: String}

data Launcher = Launcher TutorialConfig
type TutorialConfigEff = Eff(xhr::XHR,ractiveM::Ract.RactiveM,trace::Trace)

ractiveTemplate = "#ractive-template"
ractiveElement = "ractive-element"

tutorials = [{"name": "tut1"},{"name": "tut2"}]

template :: String -> String -> URI -> URI -> TutorialConfig
template element template baseUri dir = {contentTemplate: content, outputTemplate: output, element: element, template: template}
  where
    content = baseUri ++ "/" ++ dir ++ "/" ++ "content.html"
    output  = baseUri ++ "/" ++ dir ++ "/" ++ "output.html"

templateTuto :: URI -> TutorialConfig
templateTuto = template ractiveElement ractiveTemplate "http://localhost/templates"

templateTuto1 :: TutorialConfig
templateTuto1 = templateTuto "tut1"

getFrom :: forall r. URI -> (RequestConfig r -> EffXHR r Unit)
getFrom url = (flip $ flip get url) {}

getTemplate :: forall e a b. (String -> a -> b) -> URI -> a -> ContT Unit (Eff (xhr::XHR | e)) b
getTemplate fun uri = \v -> ContT \next -> do
  getFrom uri $ defaultConfig {onLoadEnd = \response -> next $ fun (responseText response) v}

outputPartialTut :: forall e. URI -> Unit -> ContT Unit (Eff (xhr::XHR | e)) (String -> TutorialPartials)
outputPartialTut = getTemplate \tmpl -> \_ -> tutorialPartials tmpl

contentPartialTut :: forall e. URI -> (String -> TutorialPartials) -> ContT Unit (Eff (xhr::XHR | e)) TutorialPartials
contentPartialTut = getTemplate \tmpl -> \fun -> fun tmpl

ractiveTut :: forall e. TutorialConfig -> TutorialPartials -> ContT Unit (Eff (ractiveM::Ract.RactiveM | e)) Ract.Ractive
ractiveTut config partials = ContT \next -> do
  r <- Ract.ractiveFromData {template: config.template,
    el: config.element,
    partials: {outputP: partials.output, contentP: partials.content}}
  next r
--  ractive <- Ract.ractive config.template config.element {}
--  Ract.setPartial "outputP" partials.output ractive
--  Ract.setPartial "contentP" partials.content ractive

loadTutorial :: forall e. TutorialConfig -> Unit -> ContT Unit (Eff (ractiveM::Ract.RactiveM,xhr::XHR | e)) Ract.Ractive
loadTutorial config = outputPartialTut config.outputTemplate >=> contentPartialTut config.contentTemplate >=> ractiveTut config

launch :: forall e. TutorialConfig -> Eff (trace :: Trace, ractiveM :: Ract.RactiveM, xhr :: XHR | e) Unit
launch tutorial = runContT (loadTutorial tutorial unit) $ \r ->
  trace "DONE"

init = do
  r <- Ract.ractive "#ractive-nav-template" "ractive-nav" {tutorials: tutorials}
  flip (Ract.on "loadtutorial") r \r -> do
    launch templateTuto1
    trace "Cargado"
  trace "Initialization done"

error: pathspec 'src/Tutorial/Ractive/demo.purs' did not match any file(s) known to git


adding sample ideas on how to code this

adding sample ideas on how to code this

module PureLik where

import Data.List

type TableName = String
type Attribute { key :: String, value :: String }
type Attributes = List

putItem = TableName -> Attributes -> String

error: pathspec 'src/first-ideas.purs' did not match any file(s) known to git


add world module

add world module

error: pathspec 'src/Data/Phaser/World.purs' did not match any file(s) known to git


make use of import from Day1.Part1

make use of import from Day1.Part1


More interesting morphing steps.

More interesting morphing steps.


Add Unit example

Add Unit example

module Main where

import Prelude
import Debug.Trace

main = print (unit "Hello world")

error: pathspec 'examples/passing/Unit.purs' did not match any file(s) known to git


Added missing file

Added missing file

-- File auto generated by servant-purescript! --
module Counter.WebAPI.MakeRequests where

import Prelude

import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Error.Class (class MonadError)
import Control.Monad.Reader.Class (ask, class MonadReader)
import Counter.ServerTypes (AuthToken, CounterAction)
import Counter.WebAPI (SPParams_(..))
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Argonaut.Printer (printJson)
import Data.Maybe (Maybe(..))
import Data.Nullable (Nullable(), toNullable)
import Data.Tuple (Tuple(..))
import Global (encodeURIComponent)
import Network.HTTP.Affjax (AJAX)
import Prim (Int, String)
import Servant.PureScript.Affjax (AjaxError(..), affjax, defaultRequest)
import Servant.PureScript.Settings (SPSettings_(..), gDefaultToURLPiece)
import Servant.PureScript.Util (encodeListQuery, encodeQueryItem, encodeURLPiece, getResult)
import Servant.Subscriber (ToUserType)
import Servant.Subscriber.Request (HttpRequest(..))
import Servant.Subscriber.Subscriptions (Subscriptions, makeSubscriptions)
import Servant.Subscriber.Types (Path(..))
import Servant.Subscriber.Util (TypedToUser, subGenFlagQuery, subGenListQuery, subGenNormalQuery, toUserType)

getCounter :: forall m. MonadReader (SPSettings_ SPParams_) m => m HttpRequest
getCounter = do
  spOpts_' <- ask
  let spOpts_ = case spOpts_' of SPSettings_ o -> o
  let spParams_ = case spOpts_.params of SPParams_ ps_ -> ps_
  let authToken = spParams_.authToken
  let baseURL = spParams_.baseURL
  let httpMethod = "GET"
  let reqPath = Path ["counter"]
  let reqHeaders =
        [Tuple "AuthToken" (gDefaultToURLPiece authToken)]
  let reqQuery =
        []
  let spReq = HttpRequest
                { httpMethod: httpMethod
                , httpPath: reqPath
                , httpHeaders: reqHeaders
                , httpQuery: reqQuery
                , httpBody: ""
                }
  pure spReq

putCounter :: forall m. MonadReader (SPSettings_ SPParams_) m => CounterAction
              -> m HttpRequest
putCounter reqBody = do
  spOpts_' <- ask
  let spOpts_ = case spOpts_' of SPSettings_ o -> o
  let spParams_ = case spOpts_.params of SPParams_ ps_ -> ps_
  let authToken = spParams_.authToken
  let baseURL = spParams_.baseURL
  let httpMethod = "PUT"
  let reqPath = Path ["counter"]
  let reqHeaders =
        [Tuple "AuthToken" (gDefaultToURLPiece authToken)]
  let reqQuery =
        []
  let spReq = HttpRequest
                { httpMethod: httpMethod
                , httpPath: reqPath
                , httpHeaders: reqHeaders
                , httpQuery: reqQuery
                , httpBody: printJson <<< encodeJson $ reqBody
                }
  pure spReq

error: pathspec 'examples/central-counter/frontend/src/Counter/WebAPI/MakeRequests.purs' did not match any file(s) known to git


Start parsing config for GWAS tracks etc. in native browser

module Genetics.Browser.Config.Templates where

import Prelude

import Control.Alternative (empty)
import Data.Argonaut (JCursor(..), Json, JsonPrim(..), _Number, _Object, _String, cursorGet, insideOut, primToJson, runJsonPrim)
import Data.Array as Array
import Data.Either (Either, note)
import Data.Foldable (foldMap)
import Data.Lens (Getter', Traversal, Traversal', over, re, to, traverseOf, traversed, view, viewOn, (^.), (^?))
import Data.Lens.Iso.Newtype (_Newtype)
import Data.List (List)
import Data.List.NonEmpty (NonEmptyList(..))
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Monoid (mempty)
import Data.Newtype (wrap)
import Data.StrMap (StrMap)
import Data.StrMap as SM
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Data.Validation.Semigroup (V, invalid)
import Data.Variant (Variant, inj, prj)
import Genetics.Browser.Types (Bp(..), ChrId(..))

-- | A module for defining JSON-parsers with JSON templates

type JSONPath = { name :: String
                , path :: JCursor
                , contents :: JsonPrim
                }

type TemplatePath i = { name :: String
                      , path :: JCursor
                      , contents :: i
                      }

type Template a = StrMap (TemplatePath a)

type Validated a = V (NonEmptyList String) a

type GWASConfig = { pointPath :: JCursor
                  , scorePath :: JCursor
                  , chrIdPath :: JCursor
                  }

type GWASFeatureRow = ( point :: Bp
                      , chrId :: ChrId
                      , score :: Number )

type GWASFeature = Record GWASFeatureRow

type GWASTrack = { name :: String
                 , url :: String
                 , parser :: Json -> Either String GWASFeature }

gwasItemParse :: String -> Json -> Maybe (Variant GWASFeatureRow)
gwasItemParse name v
  | name == "point" =
      (inj (SProxy :: SProxy "point") <<< wrap) <$> v ^? _Number

  | name == "score" =
      inj (SProxy :: SProxy "score") <$> v ^? _Number

  | name == "chrId" =
      (inj (SProxy :: SProxy "chrId") <<< wrap) <$> v ^? _String

  | otherwise = Nothing

gwasParse :: Template (Variant GWASFeatureRow)
          -> Json
          -> Maybe (Record GWASFeatureRow)
gwasParse tmp j = do
  pointT <- SM.lookup "point" tmp
  scoreT <- SM.lookup "score" tmp
  chrIdT <- SM.lookup "chrId" tmp
  point <- cursorGet pointT.path j >>= prj (SProxy :: SProxy "point")
  score <- cursorGet scoreT.path j >>= prj (SProxy :: SProxy "score")
  chrId <- cursorGet chrIdT.path j >>= prj (SProxy :: SProxy "chrId")
  pure { point, score, chrId }

cursorHead :: JCursor
           -> Maybe String
cursorHead c =
  case insideOut c of
    JField str _ -> pure str
    JIndex i   _ -> pure $ show i
    JCursorTop   -> empty

parseTemplatePath :: forall a.
                     (String -> JsonPrim -> Maybe a)
                  -> (Tuple JCursor JsonPrim)
                  -> Maybe (TemplatePath a)
parseTemplatePath f (Tuple path end) = do
  name <- cursorHead path
  val <- f name end
  pure { name, path, contents: val }

parseTemplate :: forall a.
                 (String -> JsonPrim -> Maybe a)
              -> List (Tuple JCursor JsonPrim)
              -> Template a
parseTemplate p = SM.fromFoldable
                  <<< map (\r@{name} -> Tuple name r)
                  <<< fromMaybe mempty
                  <<< traverse (parseTemplatePath p)

gwasBasicParse :: (List (Tuple JCursor JsonPrim))
               -> Template (Variant GWASFeatureRow)
gwasBasicParse = parseTemplate (\n v -> gwasItemParse n (primToJson v))

error: pathspec 'src/Genetics/Browser/Config/Templates.purs' did not match any file(s) known to git