Halogen 1.0.0 updates Mount.SQL2.Component

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.FileSystem.Dialog.Mount.SQL2.Component
  ( comp
  , Query
  , module SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery
  , module SlamData.FileSystem.Dialog.Mount.SQL2.Component.State
  ) where

import SlamData.Prelude

import Data.Array (filter)
import Data.Path.Pathy as Pt
import Data.StrMap as Sm

import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Halogen.Component (AceQuery(..), Autocomplete(..), aceComponent)
import Ace.Types (Editor)

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Elements.Keyed as HHEK

import SlamData.Monad (Slam)
import SlamData.FileSystem.Dialog.Mount.Common.Render (propList, section)
import SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery (SettingsQuery(..))
import SlamData.FileSystem.Dialog.Mount.SQL2.Component.State (State, _initialQuery, _vars, emptyVar, initialState, isEmptyVar, processState, rxEmpty, stateFromViewInfo)
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Query as API

type Query = SettingsQuery State
type SQLMountDSL = H.ParentDSL State Query AceQuery Unit Unit Slam
type SQLMountHTML = H.ParentHTML Query AceQuery Unit Slam

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

render ∷ State → SQLMountHTML
render state@{ initialQuery } =
  HHEK.div_
    [ "mount-sql2" × section "SQL² query"
        [ HH.slot
            unit
            (aceComponent (aceSetup initialQuery) (Just Live))
            unit
            (const Nothing)
        ]
    , "mount-sql2" × section "Query variables" [ propList _vars state ]
    ]

eval ∷ Query ~> SQLMountDSL
eval (ModifyState f next) = H.modify (processState <<< f) $> next
eval (Validate k) = do
  sql ← fromMaybe "" <$> H.query unit (H.request GetText)
  pure $ k if sql == "" then Just "Please enter a query" else Nothing
eval (Submit parent name k) = do
  sql ← fromMaybe "" <$> H.query unit (H.request GetText)
  vars ← Sm.fromFoldable <<< filter (not isEmptyVar) <$> H.gets _.vars
  let destPath = parent Pt.</> Pt.file name
      view = R.View $ destPath
      dest = R.Mount view
  result ← API.viewQuery (Left parent) destPath sql vars
  pure $ k $ map (const view) result

aceSetup ∷ Maybe String → Editor → Slam Unit
aceSetup initialQuery editor = H.liftEff do
  Editor.setMinLines 6 editor
  Editor.setMaxLines 10000 editor
  Editor.setAutoScrollEditorIntoView true editor
  Editor.setTheme "ace/theme/chrome" editor
  Editor.setEnableLiveAutocompletion true editor
  Editor.setEnableBasicAutocompletion true editor
  session ← Editor.getSession editor
  Session.setMode "ace/mode/sql" session
  case initialQuery of
    Just q → void $ Editor.setValue q Nothing editor
    Nothing → pure unit

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.FileSystem.Dialog.Mount.SQL2.Component
  ( comp
  , Query
  , QueryP
  , StateP
  , module SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery
  , module SlamData.FileSystem.Dialog.Mount.SQL2.Component.State
  ) where

import SlamData.Prelude

import Data.Array (filter)
import Data.Path.Pathy as Pt
import Data.StrMap as Sm

import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Halogen.Component (AceQuery(..), AceState, Autocomplete(..), aceComponent, initialAceState)
import Ace.Types (Editor)

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

import SlamData.Monad (Slam)
import SlamData.FileSystem.Dialog.Mount.Common.Render (propList, section)
import SlamData.FileSystem.Dialog.Mount.Common.SettingsQuery (SettingsQuery(..))
import SlamData.FileSystem.Dialog.Mount.SQL2.Component.State (State, _initialQuery, _vars, emptyVar, initialState, isEmptyVar, processState, rxEmpty, stateFromViewInfo)
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Query as API

type Query = SettingsQuery State
type StateP = H.ParentState State AceState Query AceQuery Slam Unit
type QueryP = Coproduct Query (H.ChildF Unit AceQuery)
type SQLMountDSL = H.ParentDSL State AceState Query AceQuery Slam Unit
type SQLMountHTML = H.ParentHTML AceState Query AceQuery Slam Unit

comp ∷ H.Component StateP QueryP Slam
comp = H.parentComponent { render, eval, peek: Nothing }

render ∷ State → SQLMountHTML
render state@{ initialQuery } =
  HH.div
    [ HP.key "mount-sql2" ]
    [ section "SQL² query"
        [ HH.slot unit \_ →
            { component: aceComponent (aceSetup initialQuery) (Just Live)
            , initialState: initialAceState
            }
        ]
    , section "Query variables" [ propList _vars state ]
    ]

eval ∷ Query ~> SQLMountDSL
eval (ModifyState f next) = H.modify (processState <<< f) $> next
eval (Validate k) = do
  sql ← fromMaybe "" <$> H.query unit (H.request GetText)
  pure $ k if sql == "" then Just "Please enter a query" else Nothing
eval (Submit parent name k) = do
  sql ← fromMaybe "" <$> H.query unit (H.request GetText)
  vars ← Sm.fromFoldable <<< filter (not isEmptyVar) <$> H.gets _.vars
  let destPath = parent Pt.</> Pt.file name
      view = R.View $ destPath
      dest = R.Mount view
  result ← API.viewQuery (Left parent) destPath sql vars
  pure $ k $ map (const view) result

aceSetup ∷ Maybe String → Editor → Slam Unit
aceSetup initialQuery editor = H.liftEff do
  Editor.setMinLines 6 editor
  Editor.setMaxLines 10000 editor
  Editor.setAutoScrollEditorIntoView true editor
  Editor.setTheme "ace/theme/chrome" editor
  Editor.setEnableLiveAutocompletion true editor
  Editor.setEnableBasicAutocompletion true editor
  session ← Editor.getSession editor
  Session.setMode "ace/mode/sql" session
  case initialQuery of
    Just q → void $ Editor.setValue q Nothing editor
    Nothing → pure unit


Add short motivation of Void type

Add short motivation of Void type

module Data.Void (Void, absurd) where

import Data.Show (class Show)

-- | An uninhabited data type.
-- |
-- | `Void` is useful to eliminate the possibility of a value being created.
-- | For example, a value of type `Either Void Boolean` can never have
-- | a Left value created in PureScript.
newtype Void = Void Void

instance showVoid :: Show Void where
  show = absurd

absurd :: forall a. Void -> a
absurd a = spin a
  where
  spin (Void b) = spin b

module Data.Void (Void, absurd) where

import Data.Show (class Show)

newtype Void = Void Void

instance showVoid :: Show Void where
  show = absurd

absurd :: forall a. Void -> a
absurd a = spin a
  where
  spin (Void b) = spin b


Simplify sopt solver

Simplify sopt solver

-- | Resolve ambiguities by combining the parsed usage section with any parsed
-- | Option sections, as well as some best effort guessing.
-- |
-- | ===
-- |
-- | Thoughts:
-- |    * It appears there is never a reason to fail hard. It would be nice if
-- |      we could produce warnings, however -> Write monad?

module Language.Docopt.Solver where

import Prelude
import Debug.Trace
import Data.Either (Either(..))
import Data.Maybe.Unsafe (fromJust)
import Data.Maybe (Maybe(..), isJust, maybe, maybe', isNothing)
import Data.List (List(..), filter, head, foldM, concat, (:), singleton
                , catMaybes, toList, last, init, length)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Foldable (foldl)
import Control.MonadPlus (guard)
import Control.Plus (empty)
import Control.Alt ((<|>))
import Data.Monoid (mempty)
import Control.Monad.Error.Class (throwError)
import qualified Data.Array as A
import qualified Data.String as Str

import Language.Docopt.Errors
import Language.Docopt.Argument
import Language.Docopt.Usage
import Language.Docopt.Parser.Desc (Desc(..))
import Language.Docopt.Value (Value(..))
import qualified Language.Docopt.Option                as O
import qualified Language.Docopt.Parser.Desc           as Desc
import qualified Language.Docopt.Parser.Usage          as U
import qualified Language.Docopt.Parser.Usage.Argument as U
import qualified Language.Docopt.Parser.Usage.Option   as UO

data Result = Consumed (List Argument) | Unconsumed (List Argument)

(^=) :: String -> String -> Boolean
(^=) a b = Str.toUpper a == Str.toUpper b

solveBranch :: U.Branch -> List Desc -> Either SolveError Branch
solveBranch as ds = Branch <$> f as
  where f :: U.Branch -> Either SolveError (List Argument)
        f Nil = return Nil
        f (Cons x Nil) = do
          m <- solveArgs x Nothing
          return $ case m of
            Unconsumed zs -> zs
            Consumed   zs -> zs
        f (Cons x (Cons y xs)) = do
          m <- solveArgs x (Just y)
          case m of
            Unconsumed zs -> (zs ++) <$> f (y:xs)
            Consumed   zs -> (zs ++) <$> f xs

        -- | Solve two adjacent arguments.
        -- | Should the first argument be an option with an argument that
        -- | matches an adjacent command or positional, consume the adjacent
        -- | argument from the input (consume).
        solveArgs :: U.Argument
                  -> Maybe U.Argument
                  -> Either SolveError Result

        solveArgs (U.EOA) _
          = Unconsumed <<< singleton <$> return (EOA)

        solveArgs (U.Stdin) _
          = Unconsumed <<< singleton <$> return (Stdin)

        solveArgs (U.Command s) _
          = Unconsumed <<< singleton <$> return (Command s)

        solveArgs (U.Positional s r) _
          = Unconsumed <<< singleton <$> return (Positional s r)

        solveArgs (U.Group o bs r) _
          = Unconsumed <<< singleton <$> do
            flip (Group o) r <$> do
              flip solveBranch ds `traverse` bs

        solveArgs (U.Option (UO.LOpt o)) y = do

          -- XXX: Is `head` the right thing to do here? What if there are more
          -- matches? That would indicate ambigiutiy and needs to be treated,
          -- possibly with an error?
          let x = O.runOption $ flip maybe' id
                    (\_ -> O.lopt' o.name (toArg o.arg) (o.repeatable))
                    (head $ catMaybes $ convert <$> ds)

          -- Validate the argument matches
          if (argMatches o.arg x.arg)
            then return unit
            else throwError $ DescriptionError $ ArgumentMismatchError {
                    option: O.Option x
                  , description: {
                      arg: x.arg <#> O.runArgument >>> _.name
                    }
                  }

          -- Look ahead if any of the following arguments should be consumed.
          -- Return either `Nothing` to signify that nothing should be consumed
          -- or a value signifieng that it should be consumed, and the
          -- `isRepeated` should be inherited.
          let mr = do
                guard (not o.repeatable)
                arg' <- O.runArgument <$> x.arg
                case y of
                  Just (U.Positional n r) | n == arg'.name -> return r
                  Just (U.Command n)      | n == arg'.name -> return false
                  _                                        -> Nothing

          return $ (maybe Unconsumed (const Consumed) mr)
                 $ singleton
                 $ Option
                 $ O.Option (x { repeatable = maybe (x.repeatable) id mr })

          where
            convert :: Desc -> Maybe O.Option
            convert (Desc.OptionDesc (Desc.Option x))
              = convert' x
                where
                  convert' { name = Desc.Long n', arg = arg' }
                    | n' ^= o.name
                    = return $ O.lopt' (o.name)
                                       (resolveOptArg o.arg arg')
                                       (o.repeatable)
                  convert' { name = Desc.Full f' n', arg = arg' }
                    | n' ^= o.name
                    = return $ O.opt' (Just f')
                                      (Just o.name)
                                      (resolveOptArg o.arg arg')
                                      (o.repeatable)
            convert _ = Nothing

        solveArgs (U.OptionStack (UO.SOpt o)) y = do

          -- Figure out trailing flag, in order to couple it with an adjacent
          -- option where needed.
          (Tuple xs x) <- do
              let fs = toList o.stack
                  t  = case last fs of
                        Just f  -> Tuple (o.flag:(fromJust $ init fs)) f
                        Nothing -> Tuple Nil o.flag
              Tuple
                <$> (match false `traverse` (fst t))
                <*> (O.runOption <$> do match true (snd t))

          -- Validate the argument matches
          if (argMatches o.arg x.arg)
            then return unit
            else throwError $ DescriptionError $ ArgumentMismatchError {
                    option: O.Option x
                  , description: {
                      arg: x.arg <#> O.runArgument >>> _.name
                    }
                  }

          -- Look ahead if any of the following arguments should be consumed.
          -- Return either `Nothing` to signify that nothing should be consumed
          -- or a value signifieng that it should be consumed, and the
          -- `isRepeated` should be inherited.
          let mr = do
                guard (not x.repeatable)
                arg' <- O.runArgument <$> x.arg
                case y of
                    Just (U.Positional n r) | n == arg'.name -> return r
                    Just (U.Command n)      | n == arg'.name -> return false
                    _                                        -> Nothing

          return $ (maybe Unconsumed (const Consumed) mr)
                 $ (Option <$> xs)
                    ++ (singleton $ Option $ O.Option $ x {
                          repeatable = maybe (x.repeatable) id mr
                        })

          where
            match :: Boolean -> Char -> Either SolveError O.Option
            match isTrailing f = return $
              maybe' (\_ -> O.sopt' f (toArg o.arg) (o.repeatable))
                    id
                    (head $ catMaybes $ convert f isTrailing <$> ds)

            convert :: Char -> Boolean -> Desc -> Maybe O.Option
            convert f isTrailing (Desc.OptionDesc (Desc.Option y))
              = convert' y
                where
                  convert' { name = Desc.Flag f', arg = arg' }
                    | (f == f') && (isTrailing || isNothing arg')
                    = return $ O.sopt' (f)
                                       (resolveOptArg o.arg arg')
                                       (o.repeatable)
                  convert' { name = Desc.Full f' n', arg = arg' }
                    | (f == f') && (isTrailing || isNothing arg')
                    = return $ O.opt' (Just f)
                                      (Just n')
                                      (resolveOptArg o.arg arg')
                                      (o.repeatable)
                  convert' _ = Nothing
            convert _ _ _ = Nothing

        -- | Resolve an option's argument name against that given in the
        -- | description, returning the most complete argument known.
        resolveOptArg :: Maybe String
                      -> Maybe Desc.Argument
                      -> Maybe O.Argument
        resolveOptArg (Just n) Nothing = do
          return $ O.Argument { name: n
                              , default: Nothing }
        resolveOptArg Nothing (Just (Desc.Argument a))
          = do
          -- XXX: The conversion to `StringValue` should not be needed,
          -- `Desc.Argument` should be of type `Maybe Value`.
          return $ O.Argument { name: a.name
                              , default: a.default
                              }
        resolveOptArg (Just an) (Just (Desc.Argument a))
          = do
          -- XXX: Do we need to guard that `an == a.name` here?
          -- XXX: The conversion to `StringValue` should not be needed,
          -- `Desc.Argument` should be of type `Maybe Value`.
          return $ O.Argument { name: a.name
                              , default: a.default
                              }
        resolveOptArg _ _ = Nothing

        toArg:: Maybe String -> Maybe O.Argument
        toArg a = do
          an <- a
          return $ O.Argument { name: an
                              , default: Nothing }

        argMatches :: Maybe String
                   -> Maybe O.Argument
                   -> Boolean
        argMatches a a'
          =  (isNothing a)
          || (isNothing a && isNothing a')
          || (maybe false id do
              an <- a
              (O.Argument { name: an' }) <- a'
              return $ Str.toUpper an == Str.toUpper an'
            )

solveUsage :: U.Usage -> List Desc -> Either SolveError Usage
solveUsage (U.Usage _ bs) ds = Usage <$> do
  traverse (flip solveBranch ds) bs

solve :: (List U.Usage)
      -> (List Desc)
      -> Either SolveError (List Usage)
solve us ds = traverse (flip solveUsage ds) us

-- | Resolve ambiguities by combining the parsed usage section with any parsed
-- | Option sections, as well as some best effort guessing.
-- |
-- | ===
-- |
-- | Thoughts:
-- |    * It appears there is never a reason to fail hard. It would be nice if
-- |      we could produce warnings, however -> Write monad?

module Language.Docopt.Solver where

import Prelude
import Debug.Trace
import Data.Either (Either(..))
import Data.Maybe.Unsafe (fromJust)
import Data.Maybe (Maybe(..), isJust, maybe, maybe', isNothing)
import Data.List (List(..), filter, head, foldM, concat, (:), singleton
                , catMaybes, toList, last, init, length)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Foldable (foldl)
import Control.MonadPlus (guard)
import Control.Plus (empty)
import Control.Alt ((<|>))
import Data.Monoid (mempty)
import Control.Monad.Error.Class (throwError)
import qualified Data.Array as A
import qualified Data.String as Str

import Language.Docopt.Errors
import Language.Docopt.Argument
import Language.Docopt.Usage
import Language.Docopt.Parser.Desc (Desc(..))
import Language.Docopt.Value (Value(..))
import qualified Language.Docopt.Option                as O
import qualified Language.Docopt.Parser.Desc           as Desc
import qualified Language.Docopt.Parser.Usage          as U
import qualified Language.Docopt.Parser.Usage.Argument as U
import qualified Language.Docopt.Parser.Usage.Option   as UO

data Result = Consumed (List Argument) | Unconsumed (List Argument)

solveBranch :: U.Branch -> List Desc -> Either SolveError Branch
solveBranch as ds = Branch <$> f as
  where f :: U.Branch -> Either SolveError (List Argument)
        f Nil = return Nil
        f (Cons x Nil) = do
          m <- solveArgs x Nothing
          return $ case m of
            Unconsumed zs -> zs
            Consumed   zs -> zs
        f (Cons x (Cons y xs)) = do
          m <- solveArgs x (Just y)
          case m of
            Unconsumed zs -> (zs ++) <$> f (y:xs)
            Consumed   zs -> (zs ++) <$> f xs

        -- | Solve two adjacent arguments.
        -- | Should the first argument be an option with an argument that
        -- | matches an adjacent command or positional, consume the adjacent
        -- | argument from the input (consume).
        solveArgs :: U.Argument
                  -> Maybe U.Argument
                  -> Either SolveError Result

        solveArgs (U.EOA) _
          = Unconsumed <<< singleton <$> return (EOA)

        solveArgs (U.Stdin) _
          = Unconsumed <<< singleton <$> return (Stdin)

        solveArgs (U.Command s) _
          = Unconsumed <<< singleton <$> return (Command s)

        solveArgs (U.Positional s r) _
          = Unconsumed <<< singleton <$> return (Positional s r)

        solveArgs (U.Group o bs r) _
          = Unconsumed <<< singleton <$> do
            flip (Group o) r <$> do
              flip solveBranch ds `traverse` bs

        solveArgs (U.Option (UO.LOpt o)) y = do

          -- XXX: Is `head` the right thing to do here? What if there are more
          -- matches? That would indicate ambigiutiy and needs to be treated,
          -- possibly with an error?
          let o' = O.runOption $ flip maybe' id
                    (\_ -> O.lopt' o.name (toArg o.arg) (o.repeatable))
                    (head $ catMaybes $ convert <$> ds)

          if (argMatches o.arg o'.arg)
            then return unit
            else throwError $ DescriptionError $ ArgumentMismatchError {
                    option: {
                      flag: o'.flag
                    , name: o'.name
                    , arg:  o.arg
                    }
                  , description: {
                      arg: o'.arg <#> \(O.Argument a') -> a'.name
                    }
                  }

          -- Look ahead if any of the following arguments should be consumed.
          -- Return either `Nothing` to signify that nothing should be consumed
          -- or a value signifieng that it should be consumed, and the
          -- `isRepeated` should be inherited.
          let mr = do
                guard (not o.repeatable)
                arg' <- O.runArgument <$> o'.arg
                case y of
                  Just (U.Positional n r) | n == arg'.name -> return r
                  Just (U.Command n)      | n == arg'.name -> return false
                  _                                        -> Nothing

          return $ (maybe Unconsumed (const Consumed) mr)
                 $ singleton
                 $ Option
                 $ O.Option (o' { repeatable = maybe (o'.repeatable) id mr })

          where
            convert :: Desc -> Maybe O.Option
            convert (Desc.OptionDesc (Desc.Option {
                      name=Desc.Long n'
                    , arg=a'
                    }))
              | Str.toUpper n' == Str.toUpper o.name
              = return $ O.lopt' o.name
                                (resolveOptArg o.arg a')
                                (o.repeatable)
            convert (Desc.OptionDesc (Desc.Option {
                      name=Desc.Full f n'
                    , arg=a'
                    }))
              | Str.toUpper n' == Str.toUpper o.name
              = return $ O.opt' (Just f)
                                (Just o.name)
                                (resolveOptArg o.arg a')
                                (o.repeatable)
            convert _ = Nothing

        solveArgs (U.OptionStack (UO.SOpt o)) y = do

          -- Figure out trailing flag, in order to couple it with an adjacent
          -- option where needed.
          let fs' = toList o.stack
              x   = case last fs' of
                      Just f' -> Tuple (o.flag:(fromJust $ init fs')) f'
                      Nothing -> Tuple Nil o.flag
              fs'' = fst x
              f''  = snd x

          xs <- match false `traverse` fs''
          x  <- match true f''

          case x of
            -- XXX: Non-exhaustive on purpose. How to improve?
            (Option (O.Option o')) ->
              if (argMatches o.arg o'.arg)
                then return unit
                else throwError $ DescriptionError $ ArgumentMismatchError {
                        option: {
                          flag: o'.flag
                        , name: o'.name
                        , arg:  o.arg
                        }
                      , description: {
                          arg: o'.arg <#> \(O.Argument a') -> a'.name
                        }
                      }

          -- Look ahead if any of the following arguments should be consumed.
          -- Return either `Nothing` to signify that nothing should be consumed
          -- or a value signifieng that it should be consumed, and the
          -- `isRepeated` should be inherited.
          let adjArg = if (isRepeatable x)
                then Nothing
                else
                  case y of
                    Just (U.Positional n r) ->
                      case x of
                        (Option (O.Option { arg: Just (O.Argument a') } ))
                          | Str.toUpper n == Str.toUpper a'.name -> Just r
                        _ -> Nothing
                    Just (U.Command n) ->
                      case x of
                        (Option (O.Option { arg: Just (O.Argument a') } ))
                          | Str.toUpper n == Str.toUpper a'.name -> Just false
                        _ -> Nothing
                    _ -> Nothing

          -- Apply adjacent argument
          return $ maybe'
            (\_ -> Unconsumed $ xs ++ singleton x)
            (\r -> case x of
              -- XXX: Non-exhaustive on purpose. How to improve?
              (Option (O.Option o')) -> do
                Consumed $ xs ++ (singleton $ Option $ O.Option o' {
                                                        repeatable = r
                                                       })
            )
            adjArg

          where
            match :: Boolean -> Char -> Either SolveError Argument
            match isTrailing f = do
              return $ flip maybe' id
                        (\_ -> sopt' f
                                     (toArg o.arg)
                                     o.repeatable)
                        (head $ catMaybes $ convert f isTrailing <$> ds)

            convert :: Char -> Boolean -> Desc -> Maybe Argument
            convert f isTrailing (Desc.OptionDesc (Desc.Option {
                                  name=Desc.Flag f'
                                , arg=a'
                                }))
              | (f == f')
                && (isTrailing || isNothing a')
              = return $ sopt' f
                               (resolveOptArg o.arg a')
                               o.repeatable
            convert f isTrailing (Desc.OptionDesc (Desc.Option {
                                  name=Desc.Full f' n
                                , arg=a'
                                }))
              | (f == f')
                && (isTrailing || isNothing a')
              = return $ opt' (Just f)
                              (Just n)
                              (resolveOptArg o.arg a')
                              o.repeatable
            convert _ _ _ = Nothing

        -- | Resolve an option's argument name against that given in the
        -- | description, returning the most complete argument known.
        resolveOptArg :: Maybe String
                      -> Maybe Desc.Argument
                      -> Maybe O.Argument
        resolveOptArg (Just n) Nothing = do
          return $ O.Argument { name: n
                              , default: Nothing }
        resolveOptArg Nothing (Just (Desc.Argument a))
          = do
          -- XXX: The conversion to `StringValue` should not be needed,
          -- `Desc.Argument` should be of type `Maybe Value`.
          return $ O.Argument { name: a.name
                              , default: a.default
                              }
        resolveOptArg (Just an) (Just (Desc.Argument a))
          = do
          -- XXX: Do we need to guard that `an == a.name` here?
          -- XXX: The conversion to `StringValue` should not be needed,
          -- `Desc.Argument` should be of type `Maybe Value`.
          return $ O.Argument { name: a.name
                              , default: a.default
                              }
        resolveOptArg _ _ = Nothing

        toArg:: Maybe String -> Maybe O.Argument
        toArg a = do
          an <- a
          return $ O.Argument { name: an
                              , default: Nothing }

        argMatches :: Maybe String
                   -> Maybe O.Argument
                   -> Boolean
        argMatches a a'
          =  (isNothing a)
          || (isNothing a && isNothing a')
          || (maybe false id do
              an <- a
              (O.Argument { name: an' }) <- a'
              return $ Str.toUpper an == Str.toUpper an'
            )

solveUsage :: U.Usage -> List Desc -> Either SolveError Usage
solveUsage (U.Usage _ bs) ds = Usage <$> do
  traverse (flip solveBranch ds) bs

solve :: (List U.Usage)
      -> (List Desc)
      -> Either SolveError (List Usage)
solve us ds = traverse (flip solveUsage ds) us


Use new coords & backend in UI

Use new coords & backend in UI

module Genetics.Browser.Track.UI where

import Prelude

import Control.Alt ((<|>))
import Control.Alternative (empty, (<*>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, tryPeekVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (take, zip)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Filterable as Filterable
import Data.Foldable (class Foldable, foldMap, for_, length, maximum, maximumBy, sum)
import Data.Int (round)
import Data.Int as Int
import Data.Lens (_Left, view, (^?), (^.))
import Data.Lens.Index (ix)
import Data.List (List(..), (:))
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (ala, alaF, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Ord.Max (Max(..))
import Data.Pair (Pair(..))
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Semigroup.Foldable (foldMap1)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd)
import Debug.Trace (traceShow)
import Debug.Trace as Debug
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (GWASFeature, Gene, drawDemo, getDataDemo, mouseChrIds)
import Genetics.Browser.Types (Bp(..), ChrId(..), Point)
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordInterval, CoordSys(..), Interval, RelPoint, _BrowserSize, canvasToView, findBrowserInterval, intervalToGlobal, mkCoordSys, shiftIntervalBy)
import Genetics.Browser.View (Pixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, Transform, TranslateTransform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, transform, translate, withContext)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
foreign import scrollCanvas :: forall eff.
                               CanvasElement
                            -> CanvasElement
                            -> Point
                            -> Eff eff Unit

foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
                                                        , total :: Nullable Point }

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { w :: Number, h :: Number }
                         -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

foreign import canvasEvent :: String -> CanvasElement -> Event Point

foreign import setViewUI :: forall eff. String -> Eff eff Unit

type BrowserView = Interval BrowserPoint

data UpdateView =
    Scroll BrowserPoint
  | Zoom (Ratio BigInt)
  | ScrollView (Ratio BigInt)
  | NoOp

btnScroll :: forall r.
             BrowserPoint
          -> Event UpdateView
          --    BrowserPoint
          -- -> BrowserPoint
          -- -> Event UpdateView
btnScroll x = const (Scroll x) <$> buttonEvent "scrollLeft" <|>
              const (Scroll (negate x)) <$> buttonEvent "scrollRight"
-- btnScroll s (BPoint x) = scrollView s (wrap x)  <$> buttonEvent "scrollLeft"
                         -- const (scrollView s (wrap $ negate x)) <$> buttonEvent "scrollRight"

btnZoom :: (Ratio BigInt)
        -> Event UpdateView
btnZoom m = const (Zoom (m )) <$> buttonEvent "zoomOut" <|>
            const (Zoom (m * (BigInt.fromInt 9 % BigInt.fromInt 100))) <$> buttonEvent "zoomIn"

btnUpdateView :: {scroll :: BrowserPoint, zoom :: Ratio BigInt } -> Event UpdateView
-- btnUpdateView {scroll,zoom} = btnScroll scroll <|> btnZoom zoom <|> (const NoOp <$> buttonEvent "redraw")
btnUpdateView  {scroll, zoom } = btnScroll scroll <|>
                                 btnZoom zoom <|>
                                 (const NoOp <$> buttonEvent "redraw")
-- btnUpdateView = const NoOp <$> buttonEvent "redraw"

scrollView :: CoordSys ChrId BrowserPoint
           -> BrowserPoint
           -> BrowserView
           -> BrowserView
scrollView cs p v = (_ - p) <$> v
  -- let p' = p
  -- in Interval (BPoint $ max zero (l - p')) (BPoint $ min size (r - p'))

-- scrollViewRel :: CoordSys _ _
--               -> RelPoint
--               -> BrowserView
--               -> BrowserView
-- scrollViewRel p v

scrollViewGood :: Ratio BigInt
               -> BrowserView
               -> BrowserView
scrollViewGood rat iv = iv `shiftIntervalBy` rat

-- zoomView :: BrowserPoint
--          -> Ratio BigInt
--          -> BrowserView
--          -> BrowserView
-- zoomView (BPoint size) p iv@(Interval (BPoint l) (BPoint r)) =
--   let len = r - l
--       len' = (len * (Ratio.numerator p)) / (Ratio.denominator p)
--   in (Interval (BPoint $ max zero (l + len')) (BPoint $ min size (r - len')))

normalizeView :: BrowserView
              -> BrowserView
              -> BrowserView
normalizeView (Pair lhs rhs)
              -- (Pair l   r) = Pair (max lhs l) (min r rhs)
              (Pair l   r) = Pair l r

updateViewFold :: CoordSys ChrId BrowserPoint
               -> UpdateView
               -> BrowserView
               -> BrowserView
-- updateViewFold _ iv = iv
updateViewFold cs uv iv@(Pair l r) = case uv of
  Scroll p  -> scrollView cs p iv
  -- Zoom r    -> zoomView ssz.size r iv
  ScrollView x -> scrollViewGood x iv
  _ -> iv

browserViewEvent :: CoordSys ChrId BrowserPoint
                 -> BrowserView
                 -> Event UpdateView
                 -> Event BrowserView
browserViewEvent cs start ev =
  Event.fold
    (\a b -> (normalizeView start) (updateViewFold cs a b)) ev start

drawingEvent :: { min :: Number, max :: Number }
             -> CoordSys ChrId BrowserPoint
             -> { width :: Pixels, height :: Pixels, yOffset :: Pixels }
             -> { gwas  :: Map ChrId (List _)
                , annots :: Map ChrId (List _) }
             -> Event BrowserView
             -> Event Drawing
drawingEvent s csys box dat = let dd = drawDemo csys s 0.25 box dat
                              in map dd

clickEvent :: forall r. CanvasElement -> Event Pixels
clickEvent el = (_.x) <$> canvasEvent "mousedown" el

viewClick :: forall r. { width :: Pixels | r} -> Event Pixels -> Event (Ratio BigInt)
viewClick w = map (canvasToView w)

globalClick :: Event (Interval BrowserPoint) -> Event (Ratio BigInt) -> Event BrowserPoint
globalClick vs vx = (\iv r -> intervalToGlobal iv r) <$> vs <*> vx

frameClick :: CoordSys ChrId BrowserPoint
           -> Event BrowserPoint
           -> Event (Maybe (CoordInterval _ _))
frameClick csys = map (findBrowserInterval csys)

chrClick :: CoordSys ChrId BrowserPoint
         -> Event (Maybe (CoordInterval _ _))
         -> Event (Maybe (Tuple ChrId Bp))
chrClick csys ev = (map <<< map) f $ ev
  where f {chrSize, index} = Tuple index chrSize

showView :: Interval BrowserPoint -> String
showView (Pair l r) = "< " <> BigInt.toString (unwrap l) <> " -- " <> BigInt.toString (unwrap r) <> " >"

showLP :: Interval BrowserPoint -> RelPoint -> String
showLP iv p = "Interval: " <> showView iv <> ";\t" <> show p

canvasDrag :: CanvasElement -> Event (Either Point Point)
canvasDrag el = f <$> canvasDragImpl el
  where f ev = case toMaybe ev.during of
          Just p  -> Right p
          Nothing -> Left $ unsafePartial $ fromJust (toMaybe ev.total)

browserDrag :: forall r.
               { width :: Number | r }
            -> Event Point
            -> Event (Ratio BigInt)
browserDrag w ev = f <$> ev
  where f :: _ -> _
        f {x} = let width = BigInt.fromInt $ Int.round w.width
                    x' = BigInt.fromInt $ Int.round x
                    p = x' % width
                in Debug.trace (show p) \_ -> p

scrollViewEvent :: Event (Ratio BigInt)
                -> Event UpdateView
scrollViewEvent = map ScrollView

main :: Eff _ _
main = launchAff do

  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      chrIds = mouseChrIds

  let dragCanvasEv :: _
      dragCanvasEv = canvasDrag canvas

      browserDragEv :: Event (Ratio BigInt)
      browserDragEv = browserDrag {width: w} (filterMap (_^?_Left) dragCanvasEv)

      dregs :: _
      dregs = scrollViewEvent browserDragEv

  let cs@(CoordSys s) = coordSys

      scroll :: BrowserPoint
      scroll = wrap $ BigInt.fromInt 10000000

      zoom :: Ratio BigInt
      zoom = one % (BigInt.fromInt 1000)

  let
      begin :: Interval BrowserPoint
      -- begin = Interval (BPoint $ BigInt.fromInt 652428823) (BPoint $ BigInt.fromInt 1829028329)
      -- begin = Pair (wrap $ BigInt.fromInt 652428823) s.size
      begin = Pair zero s.size

      viewEvent :: Event _
      viewEvent = browserViewEvent cs begin
                    $ btnUpdateView {scroll, zoom} <|> dregs

      click :: Event Pixels
      click = clickEvent canvas

      vClick :: Event (Ratio BigInt)
      vClick = viewClick {width: w} click

      gClick :: Event BrowserPoint
      gClick = globalClick viewEvent vClick

      fClick :: Event (Maybe _)
      fClick = frameClick cs gClick

      cClick :: Event (Maybe _)
      cClick = chrClick cs fClick

      clickEvs :: Event { view :: _
                        , canvasClick :: _
                        , vClick :: _
                        , gClick :: _
                        , fClick :: _
                        , cClick :: _ }
      clickEvs = { view: _, canvasClick: _, vClick: _
                 , gClick: _, fClick: _, cClick: _ }
                 <$> viewEvent <*> click <*> vClick
                 <*> gClick <*> fClick <*> cClick

  void $ liftEff $ unsafeCoerceEff $ FRP.subscribe dragCanvasEv $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  void $ liftEff $ Event.subscribe clickEvs
       (\ev -> do
           let sF (Just x) = "Frame: " <> show (unsafeStringify x)
               sF Nothing = "No Frame"
               sChr x = "Chr: " <> unsafeStringify x
               -- sChr (Just x) = "Chr: " <> show chr <> "\t" <> show (unwrap bp)
               -- sChr Nothing = "No Chr"

           setViewUI $ "
" <> showView ev.view <> "
"
                    <> "
" <> "Canvas click:" <> show ev.canvasClick <> "
"
                    <> "
" <> "View click:" <> show ev.vClick <> "
"
                    <> "
" <> "Global click:" <> show (unwrap ev.gClick) <> "
"
                    <> "
Frame click: " <> sF ev.fClick <> "
"
                    <> "
Chr click: " <> sChr ev.cClick <> "
"
           )

  dat <- getDataDemo { gwas: "./gwas.json"
                     , annots: "./annots_fake.json" }

  let sizes = {width: w, height: h, yOffset: 5.0}
      score = {min: 0.125, max: 0.42}

  let ev' = drawingEvent score cs sizes dat viewEvent
      bg = filled (fillColor white) $ rectangle 0.0 0.0 w h

  void $ liftEff $ Event.subscribe ev' (\d -> Drawing.render ctx (bg <> d))

coordSys :: _
coordSys = mkCoordSys mouseChrSizes (BigInt.fromInt 2000000)

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
            [ Tuple (ChrId "1")   (unsafePartial $ fromJust $ BigInt.fromString "195471971")
            , Tuple (ChrId "2")   (unsafePartial $ fromJust $ BigInt.fromString "182113224")
            , Tuple (ChrId "3")   (unsafePartial $ fromJust $ BigInt.fromString "160039680")
            , Tuple (ChrId "4")   (unsafePartial $ fromJust $ BigInt.fromString "156508116")
            , Tuple (ChrId "5")   (unsafePartial $ fromJust $ BigInt.fromString "151834684")
            , Tuple (ChrId "6")   (unsafePartial $ fromJust $ BigInt.fromString "149736546")
            , Tuple (ChrId "7")   (unsafePartial $ fromJust $ BigInt.fromString "145441459")
            , Tuple (ChrId "8")   (unsafePartial $ fromJust $ BigInt.fromString "129401213")
            , Tuple (ChrId "9")   (unsafePartial $ fromJust $ BigInt.fromString "124595110")
            , Tuple (ChrId "10")  (unsafePartial $ fromJust $ BigInt.fromString "130694993")
            , Tuple (ChrId "11")  (unsafePartial $ fromJust $ BigInt.fromString "122082543")
            , Tuple (ChrId "12")  (unsafePartial $ fromJust $ BigInt.fromString "120129022")
            , Tuple (ChrId "13")  (unsafePartial $ fromJust $ BigInt.fromString "120421639")
            , Tuple (ChrId "14")  (unsafePartial $ fromJust $ BigInt.fromString "124902244")
            , Tuple (ChrId "15")  (unsafePartial $ fromJust $ BigInt.fromString "104043685")
            , Tuple (ChrId "16")  (unsafePartial $ fromJust $ BigInt.fromString "98207768")
            , Tuple (ChrId "17")  (unsafePartial $ fromJust $ BigInt.fromString "94987271")
            , Tuple (ChrId "18")  (unsafePartial $ fromJust $ BigInt.fromString "90702639")
            , Tuple (ChrId "19")  (unsafePartial $ fromJust $ BigInt.fromString "61431566")
            , Tuple (ChrId "X")   (unsafePartial $ fromJust $ BigInt.fromString "17103129")
            , Tuple (ChrId "Y")   (unsafePartial $ fromJust $ BigInt.fromString "9174469")
            ]

module Genetics.Browser.Track.UI where

import Prelude

import Control.Alt ((<|>))
import Control.Alternative (empty, (<*>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, tryPeekVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (take, zip)
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Filterable as Filterable
import Data.Foldable (class Foldable, foldMap, for_, length, maximum, maximumBy, sum)
import Data.Int (round)
import Data.Int as Int
import Data.Lens (_Left, view, (^?))
import Data.Lens.Index (ix)
import Data.List (List(..), (:))
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (ala, alaF, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Ord.Max (Max(..))
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Semigroup.Foldable (foldMap1)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), fst, snd)
import Debug.Trace (traceShow)
import Debug.Trace as Debug
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (GWASFeature, Gene, drawDemo, drawDemo', getDataDemo, mouseChrIds)
import Genetics.Browser.Types (Bp(..), BrowserPoint(..), ChrId(..), CoordSys(..), Interval(..), IntervalPoint, LocalPoint(..), Point, canvasToBrowserOffset, canvasToView, frameToChr, globalToFrame, intervalSize, localToGlobal, mkCoordSys, shiftIntervalBy)
import Genetics.Browser.View (Pixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, Transform, TranslateTransform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, transform, translate, withContext)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
foreign import scrollCanvas :: forall eff.
                               CanvasElement
                            -> CanvasElement
                            -> Point
                            -> Eff eff Unit

foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
                                                        , total :: Nullable Point }

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { w :: Number, h :: Number }
                         -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

foreign import canvasEvent :: String -> CanvasElement -> Event Point

foreign import setViewUI :: forall eff. String -> Eff eff Unit

type BrowserView = Interval BrowserPoint

data UpdateView =
    Scroll BigInt
  | Zoom (Ratio BigInt)
  | ScrollView (Ratio BigInt)
  | NoOp

btnScroll :: forall r.
             BigInt
          -> Event UpdateView
          --    BrowserPoint
          -- -> BrowserPoint
          -- -> Event UpdateView
btnScroll x = const (Scroll x) <$> buttonEvent "scrollLeft" <|>
              const (Scroll (negate x)) <$> buttonEvent "scrollRight"
-- btnScroll s (BPoint x) = scrollView s (wrap x)  <$> buttonEvent "scrollLeft"
                         -- const (scrollView s (wrap $ negate x)) <$> buttonEvent "scrollRight"

btnZoom :: (Ratio BigInt)
        -> Event UpdateView
btnZoom m = const (Zoom (m )) <$> buttonEvent "zoomOut" <|>
            const (Zoom (m * (BigInt.fromInt 9 % BigInt.fromInt 100))) <$> buttonEvent "zoomIn"

btnUpdateView :: {scroll :: BigInt, zoom :: Ratio BigInt } -> Event UpdateView
-- btnUpdateView {scroll,zoom} = btnScroll scroll <|> btnZoom zoom <|> (const NoOp <$> buttonEvent "redraw")
btnUpdateView  {scroll, zoom } = btnScroll scroll <|>
                                 btnZoom zoom <|>
                                 (const NoOp <$> buttonEvent "redraw")
-- btnUpdateView = const NoOp <$> buttonEvent "redraw"

scrollView :: BrowserPoint
           -> BigInt
           -> BrowserView
           -> BrowserView
scrollView (BPoint size) p (Interval (BPoint l) (BPoint r)) =
  let p' = p
  in Interval (BPoint $ max zero (l - p')) (BPoint $ min size (r - p'))

scrollViewGood :: Ratio BigInt
               -> BrowserView
               -> BrowserView
scrollViewGood rat iv@(Interval (BPoint l) (BPoint r)) =
  iv `shiftIntervalBy` rat

zoomView :: BrowserPoint
         -> Ratio BigInt
         -> BrowserView
         -> BrowserView
zoomView (BPoint size) p iv@(Interval (BPoint l) (BPoint r)) =
  let len = r - l
      len' = (len * (Ratio.numerator p)) / (Ratio.denominator p)
  in (Interval (BPoint $ max zero (l + len')) (BPoint $ min size (r - len')))

normalizeView :: BrowserView
              -> BrowserView
              -> BrowserView
normalizeView (Interval (BPoint lhs) (BPoint rhs))
              (Interval (BPoint l)   (BPoint r)) = Interval (BPoint $ max lhs l) (BPoint $ min r rhs)

updateViewFold :: { size :: _, scroll :: _, zoom :: _ }
               -> UpdateView
               -> BrowserView
               -> BrowserView
-- updateViewFold _ iv = iv
updateViewFold ssz uv iv@(Interval l r) = case uv of
  Scroll p  -> scrollView ssz.size p iv
  Zoom r    -> zoomView ssz.size r iv
  ScrollView x -> scrollViewGood x iv
  _ -> iv

browserViewEvent :: { size :: BrowserPoint, scroll :: _, zoom :: _ }
                 -> BrowserView
                 -> Event UpdateView
                 -> Event BrowserView
browserViewEvent ssz start ev = Event.fold (\a b -> (normalizeView start) (updateViewFold ssz a b)) ev start

drawingEvent :: { min :: Number, max :: Number }
             -> CoordSys ChrId BrowserPoint
             -> { width :: Pixels, height :: Pixels, yOffset :: Pixels }
             -> { gwas  :: Map ChrId (List _)
                , annots :: Map ChrId (List _) }
             -> Event BrowserView
             -> Event Drawing
drawingEvent s csys box dat = let dd = drawDemo' csys s 0.25 box dat
                              in map dd

clickEvent :: forall r. CanvasElement -> Event Pixels
clickEvent el = (_.x) <$> canvasEvent "mousedown" el

viewClick :: forall r. { width :: Pixels | r} -> Event Pixels -> Event (Ratio BigInt)
viewClick w = map (canvasToView w)

globalClick :: Event (Interval BrowserPoint) -> Event (Ratio BigInt) -> Event BrowserPoint
globalClick vs vx = (\iv r -> localToGlobal $ Local iv r) <$> vs <*> vx

frameClick :: CoordSys ChrId BrowserPoint -> Event BrowserPoint -> Event (Maybe (Tuple ChrId IntervalPoint))
frameClick csys = map (globalToFrame csys)

chrClick :: CoordSys ChrId BrowserPoint
         -> Event (Maybe (Tuple ChrId IntervalPoint))
         -> Event (Maybe (Tuple ChrId Bp))
chrClick csys ev = f <$> ev
  where f x = do
          p@(Tuple i _) <- x
          Tuple i <$> frameToChr csys p

showView :: Interval BrowserPoint -> String
showView (Interval (BPoint l) (BPoint r)) = "< " <> BigInt.toString l <> " -- " <> BigInt.toString r <> " >"

showLP :: IntervalPoint -> String
showLP (Local iv p) = "Interval: " <> showView iv <> ";\t" <> show p

canvasDrag :: CanvasElement -> Event (Either Point Point)
canvasDrag el = f <$> canvasDragImpl el
  where f ev = case toMaybe ev.during of
          Just p  -> Right p
          Nothing -> Left $ unsafePartial $ fromJust (toMaybe ev.total)

browserDrag :: forall r.
               { width :: Number | r }
            -> Event Point
            -> Event (Ratio BigInt)
browserDrag w ev = f <$> ev
  where f :: _ -> _
        f {x} = let width = BigInt.fromInt $ Int.round w.width
                    x' = BigInt.fromInt $ Int.round x
                in x' % width

scrollViewEvent :: Event (Ratio BigInt)
                -> Event UpdateView
scrollViewEvent = map ScrollView

  -- let cDrag = canvasDrag canvas
  --     lefts = case _ of
  --       Left x -> Just x
  --       Right _ -> Nothing
  --     -- the alt operator <|> combines the two event streams,
  --     -- resulting in an event of both button-click scrolls
  --     -- and canvas-drag scrolls

      -- dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      -- updateViews = btnScroll (Bp 500.0)
      --           <|> dragScroll
      --           <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
      --                       (wrap <<< (_ * 1.2) <<< unwrap)
      --           <|> scrollZoom canvas
      -- viewB = FRP.fold foldView updateViews v

  -- _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
  --   Left _      -> pure unit
  --   Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

main :: Eff _ _
main = launchAff do

  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      chrIds = mouseChrIds

  let dragCanvasEv :: _
      dragCanvasEv = canvasDrag canvas

      browserDragEv :: Event (Ratio BigInt)
      browserDragEv = browserDrag {width: w} (filterMap (_^?_Left) dragCanvasEv)

      dregs :: _
      dregs = scrollViewEvent browserDragEv

  let cs@(CoordSys s) = coordSys

      scroll :: BigInt
      scroll = BigInt.fromInt 10000000

      zoom :: Ratio BigInt
      zoom = one % (BigInt.fromInt 1000)

  let
      begin :: Interval BrowserPoint
      -- begin = Interval (BPoint $ BigInt.fromInt 652428823) (BPoint $ BigInt.fromInt 1829028329)
      begin = Interval (BPoint $ BigInt.fromInt 652428823) s.size

      viewEvent :: Event (Interval BrowserPoint)
      viewEvent = browserViewEvent {size: s.size, scroll, zoom } begin
                    $ btnUpdateView {scroll: scroll, zoom } <|> dregs

      click :: Event Pixels
      click = clickEvent canvas

      vClick :: Event (Ratio BigInt)
      vClick = viewClick {width: w} click

      gClick :: Event BrowserPoint
      gClick = globalClick viewEvent vClick

      fClick :: Event (Maybe _)
      fClick = frameClick cs gClick

      cClick :: Event (Maybe _)
      cClick = chrClick cs fClick

      clickEvs :: Event { view :: _
                        , canvasClick :: _
                        , vClick :: _
                        , gClick :: _
                        , fClick :: _
                        , cClick :: _ }
      clickEvs = { view: _, canvasClick: _, vClick: _
                 , gClick: _, fClick: _, cClick: _ }
                 <$> viewEvent <*> click <*> vClick
                 <*> gClick <*> fClick <*> cClick

  void $ liftEff $ unsafeCoerceEff $ FRP.subscribe dragCanvasEv $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  void $ liftEff $ Event.subscribe clickEvs
       (\ev -> do
           let sF (Just (Tuple chr i)) = "Frame: " <> show chr <> showLP i
               sF Nothing = "No Frame"
               sChr (Just (Tuple chr bp)) = "Chr: " <> show chr <> "\t" <> show (unwrap bp)
               sChr Nothing = "No Chr"

           setViewUI $ "
" <> showView ev.view <> "
"
                    <> "
" <> "Canvas click:" <> show ev.canvasClick <> "
"
                    <> "
" <> "View click:" <> show ev.vClick <> "
"
                    <> "
" <> "Global click:" <> show (unwrap ev.gClick) <> "
"
                    <> "
Frame click: " <> sF ev.fClick <> "
"
                    <> "
Chr click: " <> sChr ev.cClick <> "
"
           )

  dat <- getDataDemo { gwas: "./gwas.json"
                     , annots: "./annots_fake.json" }

  let sizes = {width: w, height: h, yOffset: 5.0}
      score = {min: 0.125, max: 0.42}

  let ev' = drawingEvent score cs sizes dat viewEvent
      bg = filled (fillColor white) $ rectangle 0.0 0.0 w h

  void $ liftEff $ Event.subscribe ev' (\d -> Drawing.render ctx (bg <> d))

coordSys = mkCoordSys mouseChrSizes (BigInt.fromInt 2000000)

mouseChrSizes :: Array (Tuple ChrId BigInt)
mouseChrSizes =
            [ Tuple (ChrId "1")   (unsafePartial $ fromJust $ BigInt.fromString "195471971")
            , Tuple (ChrId "2")   (unsafePartial $ fromJust $ BigInt.fromString "182113224")
            , Tuple (ChrId "3")   (unsafePartial $ fromJust $ BigInt.fromString "160039680")
            , Tuple (ChrId "4")   (unsafePartial $ fromJust $ BigInt.fromString "156508116")
            , Tuple (ChrId "5")   (unsafePartial $ fromJust $ BigInt.fromString "151834684")
            , Tuple (ChrId "6")   (unsafePartial $ fromJust $ BigInt.fromString "149736546")
            , Tuple (ChrId "7")   (unsafePartial $ fromJust $ BigInt.fromString "145441459")
            , Tuple (ChrId "8")   (unsafePartial $ fromJust $ BigInt.fromString "129401213")
            , Tuple (ChrId "9")   (unsafePartial $ fromJust $ BigInt.fromString "124595110")
            , Tuple (ChrId "10")  (unsafePartial $ fromJust $ BigInt.fromString "130694993")
            , Tuple (ChrId "11")  (unsafePartial $ fromJust $ BigInt.fromString "122082543")
            , Tuple (ChrId "12")  (unsafePartial $ fromJust $ BigInt.fromString "120129022")
            , Tuple (ChrId "13")  (unsafePartial $ fromJust $ BigInt.fromString "120421639")
            , Tuple (ChrId "14")  (unsafePartial $ fromJust $ BigInt.fromString "124902244")
            , Tuple (ChrId "15")  (unsafePartial $ fromJust $ BigInt.fromString "104043685")
            , Tuple (ChrId "16")  (unsafePartial $ fromJust $ BigInt.fromString "98207768")
            , Tuple (ChrId "17")  (unsafePartial $ fromJust $ BigInt.fromString "94987271")
            , Tuple (ChrId "18")  (unsafePartial $ fromJust $ BigInt.fromString "90702639")
            , Tuple (ChrId "19")  (unsafePartial $ fromJust $ BigInt.fromString "61431566")
            , Tuple (ChrId "X")   (unsafePartial $ fromJust $ BigInt.fromString "17103129")
            , Tuple (ChrId "Y")   (unsafePartial $ fromJust $ BigInt.fromString "9174469")
            ]


fixing genericCoarbitrary (#99)

fixing genericCoarbitrary (#99)

module Test.QuickCheck.Arbitrary
  ( class Arbitrary
  , arbitrary
  , class Coarbitrary
  , coarbitrary
  , genericArbitrary
  , genericCoarbitrary
  , class ArbitraryGenericSum
  , arbitraryGenericSum
  , class ArbitraryRowList
  , arbitraryRecord
  ) where

import Prelude

import Control.Monad.Gen.Class (chooseBool)
import Control.Monad.Gen.Common as MGC
import Control.Monad.ST as ST
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Array.NonEmpty as NEA
import Data.Array.ST as STA
import Data.Either (Either(..))
import Data.Enum (fromEnum, toEnumWithDefaults)
import Data.Foldable (foldl)
import Data.Generic.Rep (class Generic, to, from, NoArguments(..), Sum(..), Product(..), Constructor(..), Argument(..))
import Data.Identity (Identity(..))
import Data.Int (toNumber)
import Data.Lazy (Lazy, defer, force)
import Data.List (List)
import Data.List.NonEmpty (NonEmptyList(..))
import Data.Maybe (Maybe(..), fromJust)
import Data.Newtype (wrap)
import Data.NonEmpty (NonEmpty(..), (:|))
import Data.String (split)
import Data.String.CodeUnits (charAt, fromCharArray)
import Data.String.NonEmpty (NonEmptyString)
import Data.String.NonEmpty as NES
import Data.String.NonEmpty.CodeUnits as NESCU
import Data.Symbol (class IsSymbol)
import Data.Tuple (Tuple(..))
import Partial.Unsafe (unsafePartial)
import Prim.Row as Row
import Prim.RowList as RL
import Record as Record
import Test.QuickCheck.Gen (Gen, arrayOf, chooseInt, elements, listOf, oneOf, perturbGen, repeatable, sized, uniform)
import Type.Proxy (Proxy(..))

-- | The `Arbitrary` class represents those types whose values can be
-- | _randomly-generated_.
-- |
-- | `arbitrary` uses the `Gen` monad to express a random generator for
-- | the type `t`. Combinators in the `Test.QuickCheck.Gen`
-- | module can be used to construct random generators.
class Arbitrary t where
  arbitrary :: Gen t

-- | The `Coarbitrary` class represents types which appear on the left of
-- | an `Arbitrary` function arrow.
-- |
-- | To construct an `Arbitrary` instance for the type `a -> b`, we need to
-- | use the input of type `a` to _perturb_ a random generator for `b`. This
-- | is the role of the `coarbitrary` function.
-- |
-- | `Coarbitrary` instances can be written using the `perturbGen` function.
class Coarbitrary t where
  coarbitrary :: forall r. t -> Gen r -> Gen r

instance arbBoolean :: Arbitrary Boolean where
  arbitrary = chooseBool

instance coarbBoolean :: Coarbitrary Boolean where
  coarbitrary true = perturbGen 1.0
  coarbitrary false = perturbGen 2.0

instance arbNumber :: Arbitrary Number where
  arbitrary = uniform

instance coarbNumber :: Coarbitrary Number where
  coarbitrary = perturbGen

instance arbInt :: Arbitrary Int where
  arbitrary = chooseInt (-1000000) 1000000

instance coarbInt :: Coarbitrary Int where
  coarbitrary = perturbGen <<< toNumber

instance arbString :: Arbitrary String where
  arbitrary = fromCharArray <$> arbitrary

instance coarbString :: Coarbitrary String where
  coarbitrary s = coarbitrary $ (charAt zero <$> split (wrap "") s)

instance arbNonEmptyString :: Arbitrary NonEmptyString where
  arbitrary = NESCU.cons <$> arbitrary <*> arbitrary

instance coarbNonEmptyString :: Coarbitrary NonEmptyString where
  coarbitrary = coarbitrary <<< NES.toString

instance arbChar :: Arbitrary Char where
  arbitrary = toEnumWithDefaults bottom top <$> chooseInt 0 65536

instance coarbChar :: Coarbitrary Char where
  coarbitrary c = coarbitrary $ fromEnum c

instance arbUnit :: Arbitrary Unit where
  arbitrary = pure unit

instance coarbUnit :: Coarbitrary Unit where
  coarbitrary _ = perturbGen 1.0

instance arbOrdering :: Arbitrary Ordering where
  arbitrary = elements $ LT :| [EQ, GT]

instance coarbOrdering :: Coarbitrary Ordering where
  coarbitrary LT = perturbGen 1.0
  coarbitrary EQ = perturbGen 2.0
  coarbitrary GT = perturbGen 3.0

instance arbArray :: Arbitrary a => Arbitrary (Array a) where
  arbitrary = arrayOf arbitrary

instance coarbArray :: Coarbitrary a => Coarbitrary (Array a) where
  coarbitrary = foldl (\f x -> f <<< coarbitrary x) identity

instance arbNonEmptyArray :: Arbitrary a => Arbitrary (NonEmptyArray a) where
  arbitrary = do
     x <- arbitrary
     xs <- arbitrary
     pure $ unsafePartial fromJust $ NEA.fromArray $ ST.run do
        mxs <- STA.unsafeThaw xs
        _ <- STA.push x mxs
        STA.unsafeFreeze mxs

instance coarbNonEmptyArray :: Coarbitrary a => Coarbitrary (NonEmptyArray a) where
  coarbitrary = coarbitrary <<< NEA.toArray

instance arbFunction :: (Coarbitrary a, Arbitrary b) => Arbitrary (a -> b) where
  arbitrary = repeatable (\a -> coarbitrary a arbitrary)

instance coarbFunction :: (Arbitrary a, Coarbitrary b) => Coarbitrary (a -> b) where
  coarbitrary f gen = do
    xs <- arbitrary
    coarbitrary (map f (xs :: Array a)) gen

instance arbTuple :: (Arbitrary a, Arbitrary b) => Arbitrary (Tuple a b) where
  arbitrary = Tuple <$> arbitrary <*> arbitrary

instance coarbTuple :: (Coarbitrary a, Coarbitrary b) => Coarbitrary (Tuple a b) where
  coarbitrary (Tuple a b) = coarbitrary a >>> coarbitrary b

instance arbMaybe :: Arbitrary a => Arbitrary (Maybe a) where
  arbitrary = MGC.genMaybe arbitrary

instance coarbMaybe :: Coarbitrary a => Coarbitrary (Maybe a) where
  coarbitrary Nothing = perturbGen 1.0
  coarbitrary (Just a) = coarbitrary a

instance arbEither :: (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where
  arbitrary = MGC.genEither arbitrary arbitrary

instance coarbEither :: (Coarbitrary a, Coarbitrary b) => Coarbitrary (Either a b) where
  coarbitrary (Left a)  = coarbitrary a
  coarbitrary (Right b) = coarbitrary b

instance arbitraryList :: Arbitrary a => Arbitrary (List a) where
  arbitrary = sized \n -> chooseInt zero n >>= flip listOf arbitrary

instance coarbList :: Coarbitrary a => Coarbitrary (List a) where
  coarbitrary = foldl (\f x -> f <<< coarbitrary x) identity

instance arbitraryIdentity :: Arbitrary a => Arbitrary (Identity a) where
  arbitrary = Identity <$> arbitrary

instance coarbIdentity :: Coarbitrary a => Coarbitrary (Identity a) where
  coarbitrary (Identity a) = coarbitrary a

instance arbitraryLazy :: Arbitrary a => Arbitrary (Lazy a) where
  arbitrary = arbitrary >>= pure <<< defer <<< const

instance coarbLazy :: Coarbitrary a => Coarbitrary (Lazy a) where
  coarbitrary a = coarbitrary (force a)

instance arbNonEmpty :: (Arbitrary (f a), Arbitrary a) => Arbitrary (NonEmpty f a) where
  arbitrary = NonEmpty <$> arbitrary <*> arbitrary

instance coarbNonEmpty :: (Coarbitrary (f a), Coarbitrary a) => Coarbitrary (NonEmpty f a) where
  coarbitrary (NonEmpty head tail) = coarbitrary head >>> coarbitrary tail

instance arbNonEmptyList :: Arbitrary a => Arbitrary (NonEmptyList a) where
  arbitrary = NonEmptyList <$> arbitrary

instance coarbNonEmptyList :: Coarbitrary a => Coarbitrary (NonEmptyList a) where
  coarbitrary (NonEmptyList nel) = coarbitrary nel

instance arbitraryNoArguments :: Arbitrary NoArguments where
  arbitrary = pure NoArguments

instance coarbitraryNoArguments :: Coarbitrary NoArguments where
  coarbitrary NoArguments = identity

-- | To be able to evenly distribute over chains of Sum types we build up
-- | a collection of generators and choose between.  Each right component
-- | of a Sum is either a Constructor or another Sum.
class ArbitraryGenericSum t where
  arbitraryGenericSum :: Array (Gen t)

instance arbGenSumSum :: (Arbitrary l, ArbitraryGenericSum r) => ArbitraryGenericSum (Sum l r) where
  arbitraryGenericSum = [Inl <$> arbitrary] <> (map Inr <$> arbitraryGenericSum)

instance arbGenSumConstructor :: Arbitrary a => ArbitraryGenericSum (Constructor s a) where
  arbitraryGenericSum = [arbitrary]

instance arbitrarySum :: (Arbitrary l, ArbitraryGenericSum r) => Arbitrary (Sum l r) where
  arbitrary = oneOf $ (Inl <$> arbitrary) :| (map Inr <$> arbitraryGenericSum)

instance coarbitrarySum :: (Coarbitrary l, Coarbitrary r) => Coarbitrary (Sum l r) where
  coarbitrary (Inl l) = coarbitrary l
  coarbitrary (Inr r) = coarbitrary r

instance arbitraryProduct :: (Arbitrary l, Arbitrary r) => Arbitrary (Product l r) where
  arbitrary = Product <$> arbitrary <*> arbitrary

instance coarbitraryProduct :: (Coarbitrary l, Coarbitrary r) => Coarbitrary (Product l r) where
  coarbitrary (Product a b) = coarbitrary a >>> coarbitrary b

instance arbitraryConstructor :: Arbitrary a => Arbitrary (Constructor s a) where
  arbitrary = Constructor <$> arbitrary

instance coarbitraryConstructor :: Coarbitrary a => Coarbitrary (Constructor s a) where
  coarbitrary (Constructor a) = coarbitrary a

instance arbitraryArgument :: Arbitrary a => Arbitrary (Argument a) where
  arbitrary = Argument <$> arbitrary

instance coarbitraryArgument :: Coarbitrary a => Coarbitrary (Argument a) where
  coarbitrary (Argument a) = coarbitrary a

-- | A `Generic` implementation of the `arbitrary` member from the `Arbitrary` type class.
genericArbitrary :: forall a rep. Generic a rep => Arbitrary rep => Gen a
genericArbitrary = to <$> (arbitrary :: Gen rep)

-- | A `Generic` implementation of the `coarbitrary` member from the `Coarbitrary` type class.
genericCoarbitrary :: forall a rep t. Generic a rep => Coarbitrary rep => a -> Gen t -> Gen t
genericCoarbitrary x = coarbitrary (from x)

-- | A helper typeclass to implement `Arbitrary` for records.
class ArbitraryRowList :: RL.RowList Type -> Row Type -> Constraint
class ArbitraryRowList list row | list -> row where
  arbitraryRecord :: forall rlproxy. rlproxy list -> Gen (Record row)

instance arbitraryRowListNil :: ArbitraryRowList RL.Nil () where
  arbitraryRecord _ = pure {}

instance arbitraryRowListCons ::
  ( Arbitrary a
  , ArbitraryRowList listRest rowRest
  , Row.Lacks key rowRest
  , Row.Cons key a rowRest rowFull
  , RL.RowToList rowFull (RL.Cons key a listRest)
  , IsSymbol key
  ) => ArbitraryRowList (RL.Cons key a listRest) rowFull where
  arbitraryRecord _ = do
     value <- arbitrary
     previous <- arbitraryRecord (Proxy :: Proxy listRest)
     pure $ Record.insert (Proxy :: Proxy key) value previous

instance arbitraryRecordInstance ::
  ( RL.RowToList row list
  , ArbitraryRowList list row
  ) => Arbitrary (Record row) where
  arbitrary = arbitraryRecord (Proxy :: Proxy list)

module Test.QuickCheck.Arbitrary
  ( class Arbitrary
  , arbitrary
  , class Coarbitrary
  , coarbitrary
  , genericArbitrary
  , genericCoarbitrary
  , class ArbitraryGenericSum
  , arbitraryGenericSum
  , class ArbitraryRowList
  , arbitraryRecord
  ) where

import Prelude

import Control.Monad.Gen.Class (chooseBool)
import Control.Monad.Gen.Common as MGC
import Control.Monad.ST as ST
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Array.NonEmpty as NEA
import Data.Array.ST as STA
import Data.Either (Either(..))
import Data.Enum (fromEnum, toEnumWithDefaults)
import Data.Foldable (foldl)
import Data.Generic.Rep (class Generic, to, from, NoArguments(..), Sum(..), Product(..), Constructor(..), Argument(..))
import Data.Identity (Identity(..))
import Data.Int (toNumber)
import Data.Lazy (Lazy, defer, force)
import Data.List (List)
import Data.List.NonEmpty (NonEmptyList(..))
import Data.Maybe (Maybe(..), fromJust)
import Data.Newtype (wrap)
import Data.NonEmpty (NonEmpty(..), (:|))
import Data.String (split)
import Data.String.CodeUnits (charAt, fromCharArray)
import Data.String.NonEmpty (NonEmptyString)
import Data.String.NonEmpty as NES
import Data.String.NonEmpty.CodeUnits as NESCU
import Data.Symbol (class IsSymbol)
import Data.Tuple (Tuple(..))
import Partial.Unsafe (unsafePartial)
import Prim.Row as Row
import Prim.RowList as RL
import Record as Record
import Test.QuickCheck.Gen (Gen, arrayOf, chooseInt, elements, listOf, oneOf, perturbGen, repeatable, sized, uniform)
import Type.Proxy (Proxy(..))

-- | The `Arbitrary` class represents those types whose values can be
-- | _randomly-generated_.
-- |
-- | `arbitrary` uses the `Gen` monad to express a random generator for
-- | the type `t`. Combinators in the `Test.QuickCheck.Gen`
-- | module can be used to construct random generators.
class Arbitrary t where
  arbitrary :: Gen t

-- | The `Coarbitrary` class represents types which appear on the left of
-- | an `Arbitrary` function arrow.
-- |
-- | To construct an `Arbitrary` instance for the type `a -> b`, we need to
-- | use the input of type `a` to _perturb_ a random generator for `b`. This
-- | is the role of the `coarbitrary` function.
-- |
-- | `Coarbitrary` instances can be written using the `perturbGen` function.
class Coarbitrary t where
  coarbitrary :: forall r. t -> Gen r -> Gen r

instance arbBoolean :: Arbitrary Boolean where
  arbitrary = chooseBool

instance coarbBoolean :: Coarbitrary Boolean where
  coarbitrary true = perturbGen 1.0
  coarbitrary false = perturbGen 2.0

instance arbNumber :: Arbitrary Number where
  arbitrary = uniform

instance coarbNumber :: Coarbitrary Number where
  coarbitrary = perturbGen

instance arbInt :: Arbitrary Int where
  arbitrary = chooseInt (-1000000) 1000000

instance coarbInt :: Coarbitrary Int where
  coarbitrary = perturbGen <<< toNumber

instance arbString :: Arbitrary String where
  arbitrary = fromCharArray <$> arbitrary

instance coarbString :: Coarbitrary String where
  coarbitrary s = coarbitrary $ (charAt zero <$> split (wrap "") s)

instance arbNonEmptyString :: Arbitrary NonEmptyString where
  arbitrary = NESCU.cons <$> arbitrary <*> arbitrary

instance coarbNonEmptyString :: Coarbitrary NonEmptyString where
  coarbitrary = coarbitrary <<< NES.toString

instance arbChar :: Arbitrary Char where
  arbitrary = toEnumWithDefaults bottom top <$> chooseInt 0 65536

instance coarbChar :: Coarbitrary Char where
  coarbitrary c = coarbitrary $ fromEnum c

instance arbUnit :: Arbitrary Unit where
  arbitrary = pure unit

instance coarbUnit :: Coarbitrary Unit where
  coarbitrary _ = perturbGen 1.0

instance arbOrdering :: Arbitrary Ordering where
  arbitrary = elements $ LT :| [EQ, GT]

instance coarbOrdering :: Coarbitrary Ordering where
  coarbitrary LT = perturbGen 1.0
  coarbitrary EQ = perturbGen 2.0
  coarbitrary GT = perturbGen 3.0

instance arbArray :: Arbitrary a => Arbitrary (Array a) where
  arbitrary = arrayOf arbitrary

instance coarbArray :: Coarbitrary a => Coarbitrary (Array a) where
  coarbitrary = foldl (\f x -> f <<< coarbitrary x) identity

instance arbNonEmptyArray :: Arbitrary a => Arbitrary (NonEmptyArray a) where
  arbitrary = do
     x <- arbitrary
     xs <- arbitrary
     pure $ unsafePartial fromJust $ NEA.fromArray $ ST.run do
        mxs <- STA.unsafeThaw xs
        _ <- STA.push x mxs
        STA.unsafeFreeze mxs

instance coarbNonEmptyArray :: Coarbitrary a => Coarbitrary (NonEmptyArray a) where
  coarbitrary = coarbitrary <<< NEA.toArray

instance arbFunction :: (Coarbitrary a, Arbitrary b) => Arbitrary (a -> b) where
  arbitrary = repeatable (\a -> coarbitrary a arbitrary)

instance coarbFunction :: (Arbitrary a, Coarbitrary b) => Coarbitrary (a -> b) where
  coarbitrary f gen = do
    xs <- arbitrary
    coarbitrary (map f (xs :: Array a)) gen

instance arbTuple :: (Arbitrary a, Arbitrary b) => Arbitrary (Tuple a b) where
  arbitrary = Tuple <$> arbitrary <*> arbitrary

instance coarbTuple :: (Coarbitrary a, Coarbitrary b) => Coarbitrary (Tuple a b) where
  coarbitrary (Tuple a b) = coarbitrary a >>> coarbitrary b

instance arbMaybe :: Arbitrary a => Arbitrary (Maybe a) where
  arbitrary = MGC.genMaybe arbitrary

instance coarbMaybe :: Coarbitrary a => Coarbitrary (Maybe a) where
  coarbitrary Nothing = perturbGen 1.0
  coarbitrary (Just a) = coarbitrary a

instance arbEither :: (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where
  arbitrary = MGC.genEither arbitrary arbitrary

instance coarbEither :: (Coarbitrary a, Coarbitrary b) => Coarbitrary (Either a b) where
  coarbitrary (Left a)  = coarbitrary a
  coarbitrary (Right b) = coarbitrary b

instance arbitraryList :: Arbitrary a => Arbitrary (List a) where
  arbitrary = sized \n -> chooseInt zero n >>= flip listOf arbitrary

instance coarbList :: Coarbitrary a => Coarbitrary (List a) where
  coarbitrary = foldl (\f x -> f <<< coarbitrary x) identity

instance arbitraryIdentity :: Arbitrary a => Arbitrary (Identity a) where
  arbitrary = Identity <$> arbitrary

instance coarbIdentity :: Coarbitrary a => Coarbitrary (Identity a) where
  coarbitrary (Identity a) = coarbitrary a

instance arbitraryLazy :: Arbitrary a => Arbitrary (Lazy a) where
  arbitrary = arbitrary >>= pure <<< defer <<< const

instance coarbLazy :: Coarbitrary a => Coarbitrary (Lazy a) where
  coarbitrary a = coarbitrary (force a)

instance arbNonEmpty :: (Arbitrary (f a), Arbitrary a) => Arbitrary (NonEmpty f a) where
  arbitrary = NonEmpty <$> arbitrary <*> arbitrary

instance coarbNonEmpty :: (Coarbitrary (f a), Coarbitrary a) => Coarbitrary (NonEmpty f a) where
  coarbitrary (NonEmpty head tail) = coarbitrary head >>> coarbitrary tail

instance arbNonEmptyList :: Arbitrary a => Arbitrary (NonEmptyList a) where
  arbitrary = NonEmptyList <$> arbitrary

instance coarbNonEmptyList :: Coarbitrary a => Coarbitrary (NonEmptyList a) where
  coarbitrary (NonEmptyList nel) = coarbitrary nel

instance arbitraryNoArguments :: Arbitrary NoArguments where
  arbitrary = pure NoArguments

instance coarbitraryNoArguments :: Coarbitrary NoArguments where
  coarbitrary NoArguments = identity

-- | To be able to evenly distribute over chains of Sum types we build up
-- | a collection of generators and choose between.  Each right component
-- | of a Sum is either a Constructor or another Sum.
class ArbitraryGenericSum t where
  arbitraryGenericSum :: Array (Gen t)

instance arbGenSumSum :: (Arbitrary l, ArbitraryGenericSum r) => ArbitraryGenericSum (Sum l r) where
  arbitraryGenericSum = [Inl <$> arbitrary] <> (map Inr <$> arbitraryGenericSum)

instance arbGenSumConstructor :: Arbitrary a => ArbitraryGenericSum (Constructor s a) where
  arbitraryGenericSum = [arbitrary]

instance arbitrarySum :: (Arbitrary l, ArbitraryGenericSum r) => Arbitrary (Sum l r) where
  arbitrary = oneOf $ (Inl <$> arbitrary) :| (map Inr <$> arbitraryGenericSum)

instance coarbitrarySum :: (Coarbitrary l, Coarbitrary r) => Coarbitrary (Sum l r) where
  coarbitrary (Inl l) = coarbitrary l
  coarbitrary (Inr r) = coarbitrary r

instance arbitraryProduct :: (Arbitrary l, Arbitrary r) => Arbitrary (Product l r) where
  arbitrary = Product <$> arbitrary <*> arbitrary

instance coarbitraryProduct :: (Coarbitrary l, Coarbitrary r) => Coarbitrary (Product l r) where
  coarbitrary (Product a b) = coarbitrary a >>> coarbitrary b

instance arbitraryConstructor :: Arbitrary a => Arbitrary (Constructor s a) where
  arbitrary = Constructor <$> arbitrary

instance coarbitraryConstructor :: Coarbitrary a => Coarbitrary (Constructor s a) where
  coarbitrary (Constructor a) = coarbitrary a

instance arbitraryArgument :: Arbitrary a => Arbitrary (Argument a) where
  arbitrary = Argument <$> arbitrary

instance coarbitraryArgument :: Coarbitrary a => Coarbitrary (Argument a) where
  coarbitrary (Argument a) = coarbitrary a

-- | A `Generic` implementation of the `arbitrary` member from the `Arbitrary` type class.
genericArbitrary :: forall a rep. Generic a rep => Arbitrary rep => Gen a
genericArbitrary = to <$> (arbitrary :: Gen rep)

-- | A `Generic` implementation of the `coarbitrary` member from the `Coarbitrary` type class.
genericCoarbitrary :: forall a rep. Generic a rep => Coarbitrary rep => a -> Gen a -> Gen a
genericCoarbitrary x g = to <$> coarbitrary (from x) (from <$> g)

-- | A helper typeclass to implement `Arbitrary` for records.
class ArbitraryRowList :: RL.RowList Type -> Row Type -> Constraint
class ArbitraryRowList list row | list -> row where
  arbitraryRecord :: forall rlproxy. rlproxy list -> Gen (Record row)

instance arbitraryRowListNil :: ArbitraryRowList RL.Nil () where
  arbitraryRecord _ = pure {}

instance arbitraryRowListCons ::
  ( Arbitrary a
  , ArbitraryRowList listRest rowRest
  , Row.Lacks key rowRest
  , Row.Cons key a rowRest rowFull
  , RL.RowToList rowFull (RL.Cons key a listRest)
  , IsSymbol key
  ) => ArbitraryRowList (RL.Cons key a listRest) rowFull where
  arbitraryRecord _ = do
     value <- arbitrary
     previous <- arbitraryRecord (Proxy :: Proxy listRest)
     pure $ Record.insert (Proxy :: Proxy key) value previous

instance arbitraryRecordInstance ::
  ( RL.RowToList row list
  , ArbitraryRowList list row
  ) => Arbitrary (Record row) where
  arbitrary = arbitraryRecord (Proxy :: Proxy list)


Fix form parser example

Fix form parser example

module Examples.FormParser where

import Prelude
import Text.Smolder.HTML.Attributes as A
import Control.IxMonad ((:>>=), (:*>))
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Either (Either(Right, Left))
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(Nothing, Just))
import Data.MediaType.Common (textHTML)
import Data.String (length)
import Hyper.Form (parseForm, required)
import Hyper.Middleware.Class (getConn)
import Hyper.Node.Server (defaultOptionsWithLogging, runServer)
import Hyper.Response (closeHeaders, contentType, respond, writeStatus)
import Hyper.Status (statusBadRequest, statusMethodNotAllowed, statusOK)
import Node.HTTP (HTTP)
import Text.Smolder.HTML (button, form, input, label, p)
import Text.Smolder.Markup (text, (!))
import Text.Smolder.Renderer.String (render)

main :: forall e. Eff (http :: HTTP, console :: CONSOLE, err :: EXCEPTION, avar :: AVAR | e) Unit
main =
  let
    -- A view function that renders the name form.
    renderNameForm err = do
      form ! A.method "post" $ do
        formattedError
        formElements
      where
        formElements = do
          label ! A.for "firstName" $ text "Your Name:"
          p (input ! A.name "firstName" ! A.id "firstName")
          p (button (text "Send"))

        formattedError =
          case err of
            Just s -> p ! A.style "color: red;" $ text s
            Nothing -> pure unit

    htmlWithStatus status x =
      writeStatus status
      :*> contentType textHTML
      :*> closeHeaders
      :*> respond (render x)

    handlePost =
      parseForm :>>=
      case _ of
        Left err -> do
          liftEff (log err)
          :*> htmlWithStatus
              statusBadRequest
              (p (text "Bad request, invalid form."))
        Right form ->
          case required "firstName" form of
            Right name
              | length name > 0 ->
                htmlWithStatus
                statusOK
                (p (text ("Hi " <> name <> "!")))
              | otherwise ->
                htmlWithStatus
                statusBadRequest
                (renderNameForm (Just "Name cannot be empty."))
            Left err ->
              htmlWithStatus
              statusBadRequest
              (renderNameForm (Just err))

    -- Our (rather primitive) router.
    router =
      getConn :>>= \conn →
      case conn.request.method of
        Left GET ->
          htmlWithStatus
          statusOK
          (renderNameForm Nothing)
        Left POST ->
          handlePost
        method ->
          htmlWithStatus
          statusMethodNotAllowed
          (text ("Method not supported: " <> show method))

  -- Let's run it.
  in runServer defaultOptionsWithLogging {} router

module Examples.FormParser where

import Prelude
import Text.Smolder.HTML.Attributes as A
import Control.IxMonad ((:>>=), (:*>))
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (message, EXCEPTION)
import Data.Either (Either(Right, Left))
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(Nothing, Just))
import Data.MediaType.Common (textHTML)
import Data.String (length)
import Data.Tuple (lookup)
import Hyper.Form (Form(Form), parseForm)
import Hyper.Middleware.Class (getConn)
import Hyper.Node.Server (defaultOptionsWithLogging, runServer)
import Hyper.Response (closeHeaders, contentType, respond, writeStatus)
import Hyper.Status (statusBadRequest, statusMethodNotAllowed, statusOK)
import Node.HTTP (HTTP)
import Text.Smolder.HTML (button, form, input, label, p)
import Text.Smolder.Markup (text, (!))
import Text.Smolder.Renderer.String (render)

main :: forall e. Eff (http :: HTTP, console :: CONSOLE, err :: EXCEPTION, avar :: AVAR | e) Unit
main =
  let
    -- A view function that renders the name form.
    renderNameForm err = do
      form ! A.method "post" $ do
        formattedError
        formElements
      where
        formElements = do
          label ! A.for "firstName" $ text "Your Name:"
          p (input ! A.name "firstName" ! A.id "firstName")
          p (button (text "Send"))

        formattedError =
          case err of
            Just s -> p ! A.style "color: red;" $ text s
            Nothing -> pure unit

    htmlWithStatus status x =
      writeStatus status
      :*> contentType textHTML
      :*> closeHeaders
      :*> respond (render x)

    handlePost =
      parseForm :>>=
      case _ of
        Left err -> do
          liftEff (log (message err))
          :*> htmlWithStatus
              statusBadRequest
              (p (text "Bad request, invalid form."))
        Right (Form values) ->
          case lookup "firstName" values of
            Just name | length name > 0 ->
              htmlWithStatus
              statusOK
              (p (text ("Hi " <> name <> "!")))
            _ ->
              htmlWithStatus
              statusBadRequest
              (renderNameForm (Just "Name is missing."))

    -- Our (rather primitive) router.
    router =
      getConn :>>= \conn →
      case conn.request.method of
        Left GET ->
          htmlWithStatus
          statusOK
          (renderNameForm Nothing)
        Left POST ->
          handlePost
        method ->
          htmlWithStatus
          statusMethodNotAllowed
          (text ("Method not supported: " <> show method))

  -- Let's run it.
  in runServer defaultOptionsWithLogging {} router


Remove some unnecessary type assertions from the tests, and fix testFill

module Test.Node.Buffer.Mutable (test) where

import Prelude

import Control.Monad.ST as ST
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse)
import Effect (Effect)
import Effect.Console (log)
import Node.Buffer (BufferValueType(..))
import Node.Buffer as Buffer
import Node.Buffer.Mutable (class MutableBuffer, EffectBuffer, STBuffer, concat', copy, create, fill, freeze, fromArray, fromArrayBuffer, toArrayBuffer, fromString, getAtOffset, setAtOffset, read, readString, runST, thaw, toArray, toString, write, slice)
import Node.Encoding (Encoding(..))
import Test.Assert (assertEqual)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

test :: Effect Unit
test = do

  log "Testing Node.Buffer.Mutable [EffectBuffer] ..."
  testMutableBuffer (Proxy :: Proxy EffectBuffer) identity

  log "Testing Node.Buffer.Mutable [STBuffer] ..."
  testMutableBuffer (Proxy :: Proxy (STBuffer _)) (unsafeCoerce ST.run >>> pure)
  log " - runST"
  testRunSt

testMutableBuffer :: forall buf m. MutableBuffer buf m =>
  Proxy buf -> (forall a. m a -> Effect a) -> Effect Unit
testMutableBuffer _ run = do

  log " - create"
  testCreate

  log " - freeze"
  testFreeze

  log " - thaw"
  testThaw

  log " - Reading and writing"
  testReadWrite

  log " - fromArray"
  testFromArray

  log " - toArray"
  testToArray

  log " - fromString"
  testFromString

  log " - (to/from)ArrayBuffer"
  testToFromArrayBuffer

  log " - toString"
  testToString

  log " - readString"
  testReadString

  log " - slice"
  testSlice

  log " - copy"
  testCopy

  log " - fill"
  testFill

  log " - concat'"
  testConcat'

  log " - getAtOffset"
  testGetAtOffset

  where
    testCreate :: Effect Unit
    testCreate = do
      buf <- run (create 3 >>= toArray)
      assertEqual {expected: [0, 0, 0], actual: buf}

    testFreeze :: Effect Unit
    testFreeze = do
      buf <- Buffer.toArray <$> run (fromArray [1, 2, 3] >>= freeze)
      assertEqual {expected: [1, 2, 3], actual: buf}

    testThaw :: Effect Unit
    testThaw = do
      buf <- run (thaw (Buffer.fromArray [1, 2, 3]) >>= toArray)
      assertEqual {expected: [1, 2, 3], actual: buf}

    testReadWrite :: Effect Unit
    testReadWrite = do
      let val = 42
      readVal <- run do
        buf <- create 1
        write UInt8 val 0 buf
        read UInt8 0 buf

      assertEqual {expected: val, actual: readVal}

    testFromArray :: Effect Unit
    testFromArray = do
      readVal <- run do
        buf <- fromArray [1,2,3,4,5]
        read UInt8 2 buf

      assertEqual {expected: 3, actual: readVal}

    testToArray :: Effect Unit
    testToArray = do
      let val = [1,2,67,3,3,7,8,3,4,237]
      valOut <- run do
        buf <- fromArray val
        toArray buf

      assertEqual {expected: val, actual: valOut}

    testFromString :: Effect Unit
    testFromString = do
      let str = "hello, world"
      val <- run do
        buf <- fromString str ASCII
        read UInt8 6 buf

      assertEqual {expected: 32, actual: val} -- ASCII space

    testToFromArrayBuffer :: Effect Unit
    testToFromArrayBuffer = do
      buf <- run $
        fromArray [1, 2, 3]
        >>= toArrayBuffer
        >>= fromArrayBuffer
        >>= toArray
      assertEqual {expected: [1, 2, 3], actual: buf}

    testToString :: Effect Unit
    testToString = do
      let str = "hello, world"
      strOut <-run do
        buf <- fromString str ASCII
        toString ASCII buf

      assertEqual {expected: str, actual: strOut}

    testReadString :: Effect Unit
    testReadString = do
      let str = "hello, world"
      strOut <- run do
        buf <- fromString str ASCII
        readString ASCII 7 12 buf

      assertEqual {expected: "world", actual: strOut}

    testSlice :: Effect Unit
    testSlice = do
      {bufArr, bufSliceArr} <- run do
        buf <- fromArray [1, 2, 3, 4]
        let bufSlice = slice 1 3 buf
        setAtOffset 42 1 bufSlice
        bufArr <- toArray buf
        bufSliceArr <- toArray bufSlice
        pure {bufArr, bufSliceArr}

      assertEqual {expected: [1, 2, 42, 4], actual: bufArr}
      assertEqual {expected: [2, 42], actual: bufSliceArr}

    testCopy :: Effect Unit
    testCopy = do
      {copied, out} <- run do
        buf1 <- fromArray [1,2,3,4,5]
        buf2 <- fromArray [10,9,8,7,6]
        copied <- copy 0 3 buf1 2 buf2
        out <- toArray buf2
        pure {copied, out}

      assertEqual {expected: 3, actual: copied}
      assertEqual {expected: [10,9,1,2,3], actual: out}

    testFill :: Effect Unit
    testFill = do
      out <- run do
        buf <- fromArray [1,1,1,1,1]
        fill 42 2 4 buf
        toArray buf

      assertEqual {expected: [1,1,42,42,1], actual: out}

    testConcat' :: Effect Unit
    testConcat' = do
      out <- run do
        bufs <- traverse fromArray $ map (\x -> [x, x+1, x+2]) [0,3,6,9,12]
        buf  <- concat' bufs 15
        toArray buf

      assertEqual {expected: [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14], actual: out}

    testGetAtOffset :: Effect Unit
    testGetAtOffset = do
      {o1, o4, om1} <- run do
        buf <- fromArray [1, 2, 3, 4]
        o1 <- getAtOffset 1 buf
        o4 <- getAtOffset 4 buf
        om1 <- getAtOffset (-1) buf
        pure {o1, o4, om1}

      assertEqual {expected: Just 2, actual: o1}
      assertEqual {expected: Nothing, actual: o4}
      assertEqual {expected: Nothing, actual: om1}

testRunSt :: Effect Unit
testRunSt = do
  let buf = Buffer.toArray $ runST (create 3)
  assertEqual {expected: [0, 0, 0], actual: buf}

module Test.Node.Buffer.Mutable (test) where

import Prelude

import Control.Monad.ST as ST
import Data.Maybe (Maybe(..))
import Data.Traversable (traverse)
import Effect (Effect)
import Effect.Console (log)
import Node.Buffer (BufferValueType(..))
import Node.Buffer as Buffer
import Node.Buffer.Mutable (class MutableBuffer, EffectBuffer, STBuffer, concat', copy, create, fill, freeze, fromArray, fromArrayBuffer, toArrayBuffer, fromString, getAtOffset, setAtOffset, read, readString, runST, thaw, toArray, toString, write, slice)
import Node.Encoding (Encoding(..))
import Test.Assert (assertEqual)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

test :: Effect Unit
test = do

  log "Testing Node.Buffer.Mutable [EffectBuffer] ..."
  testMutableBuffer (Proxy :: Proxy EffectBuffer) identity

  log "Testing Node.Buffer.Mutable [STBuffer] ..."
  testMutableBuffer (Proxy :: Proxy (STBuffer _)) (unsafeCoerce ST.run >>> pure)
  log " - runST"
  testRunSt

testMutableBuffer :: forall buf m. MutableBuffer buf m =>
  Proxy buf -> (forall a. m a -> Effect a) -> Effect Unit
testMutableBuffer _ run = do

  log " - create"
  testCreate

  log " - freeze"
  testFreeze

  log " - thaw"
  testThaw

  log " - Reading and writing"
  testReadWrite

  log " - fromArray"
  testFromArray

  log " - toArray"
  testToArray

  log " - fromString"
  testFromString

  log " - (to/from)ArrayBuffer"
  testToFromArrayBuffer

  log " - toString"
  testToString

  log " - readString"
  testReadString

  log " - slice"
  testSlice

  log " - copy"
  testCopy

  log " - fill"
  testFill

  log " - concat'"
  testConcat'

  log " - getAtOffset"
  testGetAtOffset

  where
    testCreate :: Effect Unit
    testCreate = do
      buf <- run ((create 3 :: m buf) >>= toArray)
      assertEqual {expected: [0, 0, 0], actual: buf}

    testFreeze :: Effect Unit
    testFreeze = do
      buf <- Buffer.toArray <$> run ((fromArray [1, 2, 3] :: m buf) >>= freeze)
      assertEqual {expected: [1, 2, 3], actual: buf}

    testThaw :: Effect Unit
    testThaw = do
      buf <- run ((thaw (Buffer.fromArray [1, 2, 3]) :: m buf) >>= toArray)
      assertEqual {expected: [1, 2, 3], actual: buf}

    testReadWrite :: Effect Unit
    testReadWrite = do
      let val = 42
      readVal <- run do
        buf <- create 1 :: m buf
        write UInt8 val 0 buf
        read UInt8 0 buf

      assertEqual {expected: val, actual: readVal}

    testFromArray :: Effect Unit
    testFromArray = do
      readVal <- run do
        buf <- fromArray [1,2,3,4,5] :: m buf
        read UInt8 2 buf

      assertEqual {expected: 3, actual: readVal}

    testToArray :: Effect Unit
    testToArray = do
      let val = [1,2,67,3,3,7,8,3,4,237]
      valOut <- run do
        buf <- fromArray val :: m buf
        toArray buf

      assertEqual {expected: val, actual: valOut}

    testFromString :: Effect Unit
    testFromString = do
      let str = "hello, world"
      val <- run do
        buf <- fromString str ASCII :: m buf
        read UInt8 6 buf

      assertEqual {expected: 32, actual: val} -- ASCII space

    testToFromArrayBuffer :: Effect Unit
    testToFromArrayBuffer = do
      buf <- run $
        fromArray [1, 2, 3]
        >>= toArrayBuffer
        >>= fromArrayBuffer
        >>= toArray
      assertEqual {expected: [1, 2, 3], actual: buf}

    testToString :: Effect Unit
    testToString = do
      let str = "hello, world"
      strOut <-run do
        buf <- fromString str ASCII :: m buf
        toString ASCII buf

      assertEqual {expected: str, actual: strOut}

    testReadString :: Effect Unit
    testReadString = do
      let str = "hello, world"
      strOut <- run do
        buf <- fromString str ASCII :: m buf
        readString ASCII 7 12 buf

      assertEqual {expected: "world", actual: strOut}

    testSlice :: Effect Unit
    testSlice = do
      {bufArr, bufSliceArr} <- run do
        buf <- fromArray [1, 2, 3, 4] :: m buf
        let bufSlice = slice 1 3 buf :: buf
        setAtOffset 42 1 bufSlice
        bufArr <- toArray buf
        bufSliceArr <- toArray bufSlice
        pure {bufArr, bufSliceArr}

      assertEqual {expected: [1, 2, 42, 4], actual: bufArr}
      assertEqual {expected: [2, 42], actual: bufSliceArr}

    testCopy :: Effect Unit
    testCopy = do
      {copied, out} <- run do
        buf1 <- fromArray [1,2,3,4,5] :: m buf
        buf2 <- fromArray [10,9,8,7,6]
        copied <- copy 0 3 buf1 2 buf2
        out <- toArray buf2
        pure {copied, out}

      assertEqual {expected: 3, actual: copied}
      assertEqual {expected: [10,9,1,2,3], actual: out}

    testFill :: Effect Unit
    testFill = do
      let out = ST.run do
            buf <- fromArray [1,1,1,1,1]
            fill 42 2 4 buf
            toArray buf

      assertEqual {expected: [1,1,42,42,1], actual: out}

    testConcat' :: Effect Unit
    testConcat' = do
      out <- run do
        bufs <- traverse fromArray $ map (\x -> [x, x+1, x+2]) [0,3,6,9,12]
        buf  <- concat' bufs 15 :: m buf
        toArray buf

      assertEqual {expected: [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14], actual: out}

    testGetAtOffset :: Effect Unit
    testGetAtOffset = do
      {o1, o4, om1} <- run do
        buf <- fromArray [1, 2, 3, 4] :: m buf
        o1 <- getAtOffset 1 buf
        o4 <- getAtOffset 4 buf
        om1 <- getAtOffset (-1) buf
        pure {o1, o4, om1}

      assertEqual {expected: Just 2, actual: o1}
      assertEqual {expected: Nothing, actual: o4}
      assertEqual {expected: Nothing, actual: om1}

testRunSt :: Effect Unit
testRunSt = do
  let buf = Buffer.toArray $ runST (create 3)
  assertEqual {expected: [0, 0, 0], actual: buf}