Use the optimizer in CodeGen rather than `id`

module Language.PureScript.CodeGen.JS
  ( ModuleType(..)
  , declToJs
  , moduleToJs
  ) where

import Control.Apply
import Control.Monad (replicateM)
import Data.Array
import Data.Either
import Data.Function (on)
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import Data.Tuple
import Data.Tuple3
import Data.Tuple5
import Data.Traversable (for, traverse)
import qualified Data.Map as M

import Language.PureScript.CodeGen.Common
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Declarations
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Names
import Language.PureScript.Options
import Language.PureScript.Optimizer
import Language.PureScript.Supply
import Language.PureScript.Traversals (sndM)
import Language.PureScript.Types

-- |
-- Different types of modules which are supported
--
data ModuleType = CommonJS | Globals

-- |
-- Generate code in the simplified Javascript intermediate representation for all declarations in a
-- module.
--
moduleToJs :: forall m. (Monad m) => ModuleType -> Options -> Module -> Environment -> SupplyT m [JS]
moduleToJs mt opts@(Options o) (Module name decls (Just exps)) env = do
  let jsImports = map (importToJs mt opts) $ (\x -> x \\ [name]) $ nub $ concatMap imports decls
  jsDecls <- traverse (\decl -> declToJs opts name decl env) decls
  let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls
  let isModuleEmpty = null optimized
  let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized
  let moduleExports = JSObjectLiteral $ concatMap exportToJs exps
  return $ case mt of
    CommonJS -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]
    Globals | not isModuleEmpty ->
      [ JSVariableIntroduction (fromJust o.browserNamespace)
                               (Just (JSBinary Or (JSVar (fromJust o.browserNamespace)) (JSObjectLiteral [])) )
      , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar (fromJust o.browserNamespace)))
                     (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])
      ]
    _ -> []
moduleToJs _ _ _ _ = theImpossibleHappened "Exports should have been elaborated in name desugaring"

importToJs :: ModuleType -> Options -> ModuleName -> JS
importToJs mt (Options opts) mn = JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
  where
  moduleBody = case mt of
    CommonJS -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
    Globals -> JSAccessor (moduleNameToJs mn) (JSVar (fromJust opts.browserNamespace))

imports :: Declaration -> [ModuleName]
imports =
  case everythingOnValues (++) (const []) collect (const []) (const []) (const []) of
    Tuple5 f _ _ _ _ -> f
  where
  collect :: Value -> [ModuleName]
  collect (Var (Qualified (Just mn) _)) = [mn]
  collect (Constructor (Qualified (Just mn) _)) = [mn]
  collect _ = []

-- |
-- Generate code in the simplified Javascript intermediate representation for a declaration
--
declToJs :: forall m. (Monad m) => Options -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])
declToJs opts mp (ValueDeclaration ident _ _ _ val) e = do
  js <- valueToJs opts mp e val
  return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]
declToJs opts mp (BindingGroupDeclaration vals) e = do
  jss <- for vals $ \(Tuple3 ident _ val) -> do
    js <- valueToJs opts mp e val
    return $ JSVariableIntroduction (identToJs ident) (Just js)
  return $ Just jss
declToJs _ mp (DataDeclaration _ _ ctors) _ = do
  return $ Just $ flip concatMap ctors $ \(Tuple pn@(ProperName ctor) tys) ->
    [JSVariableIntroduction ctor (Just (go pn 0 tys []))]
    where
    go :: ProperName -> Number -> [Type] -> [JS] -> JS
    go pn _ [] values =
      JSObjectLiteral [ Tuple "ctor" (JSStringLiteral $ show $ Qualified (Just mp) pn)
                      , Tuple "values" (JSArrayLiteral $ reverse values) ]
    go pn index (_ : tys') values =
      JSFunction Nothing ["value" ++ show index]
        (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])
declToJs opts mp (DataBindingGroupDeclaration ds) e = do
  jss <- traverse (\decl -> declToJs opts mp decl e) ds
  return $ Just $ concat $ catMaybes jss
declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = return $ Just [js]
declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e
declToJs _ _ _ _ = return Nothing

-- |
-- Generate key//value pairs for an object literal exporting values from a module.
--
exportToJs :: DeclarationRef -> [Tuple String JS]
exportToJs (TypeRef _ (Just dctors)) = map (\(ProperName n) -> Tuple n (var (Ident n))) dctors
exportToJs (ValueRef name) = [Tuple (runIdent name) (var name)]
exportToJs (TypeInstanceRef name) = [Tuple (runIdent name) (var name)]
exportToJs _ = []

-- |
-- Generate code in the simplified Javascript intermediate representation for a variable based on a
-- PureScript identifier.
--
var :: Ident -> JS
var = JSVar <<< identToJs

-- |
-- Generate code in the simplified Javascript intermediate representation for an accessor based on
-- a PureScript identifier. If the name is not valid in Javascript (symbol based, reserved name) an
-- indexer is returned.
--
accessor :: Ident -> JS -> JS
accessor (Ident prop) = accessorString prop
accessor (Op op) = JSIndexer (JSStringLiteral op)

accessorString :: String -> JS -> JS
accessorString prop | isIdent prop = JSAccessor prop
accessorString prop                = JSIndexer (JSStringLiteral prop)

-- |
-- Generate code in the simplified Javascript intermediate representation for a value or expression.
--
valueToJs :: forall m. (Monad m) => Options -> ModuleName -> Environment -> Value -> SupplyT m JS
valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n
valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s
valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b
valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral <$> traverse (valueToJs opts m e) xs
valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral <$> traverse (sndM (valueToJs opts m e)) ps
valueToJs opts m e (ObjectUpdate o ps) = do
  obj <- valueToJs opts m e o
  sts <- traverse (sndM (valueToJs opts m e)) ps
  extendObj obj sts
valueToJs _ m _ (Constructor name) = return $ qualifiedToJS m (Ident <<< runProperName) name
valueToJs opts m e (Case values binders) = do
  vals <- traverse (valueToJs opts m e) values
  bindersToJs opts m e binders vals
valueToJs opts m e (IfThenElse cond th el) = JSConditional <$> valueToJs opts m e cond <*> valueToJs opts m e th <*> valueToJs opts m e el
valueToJs opts m e (Accessor prop val) = accessorString prop <$> valueToJs opts m e val
valueToJs opts m e (App val arg) = JSApp <$> valueToJs opts m e val <*> (return <$> valueToJs opts m e arg)
valueToJs opts m e (Let ds val) = do
  decls <- concat <<< catMaybes <$> traverse (flip (declToJs opts m) e) ds
  ret <- valueToJs opts m e val
  return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []
valueToJs opts m e (Abs (Left arg) val) = do
  ret <- valueToJs opts m e val
  return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
valueToJs opts@(Options o) m e (TypedValue _ (Abs (Left arg) val) ty) | o.performRuntimeTypeChecks = do
  let arg' = identToJs arg
  ret <- valueToJs opts m e val
  return $ JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn ret])
valueToJs _ m _ (Var ident) = return $ varToJs m ident
valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val
valueToJs _ _ _ (TypeClassDictionary _ _ _) = theImpossibleHappened "Type class dictionary was not replaced"
valueToJs _ _ _ _ = theImpossibleHappened "Invalid argument to valueToJs"

-- |
-- Shallow copy an object.
--
extendObj :: forall m. (Monad m) => JS -> [Tuple String JS] -> SupplyT m JS
extendObj obj sts = do
  newObj <- freshName
  key <- freshName
  let
    jsKey = JSVar key
    jsNewObj = JSVar newObj
    block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
    objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
    copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
    cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
    assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
    stToAssign (Tuple s js) = JSAssignment (JSAccessor s jsNewObj) js
    extend = map stToAssign sts
  return $ JSApp (JSFunction Nothing [] block) []

-- |
-- Generate code in the simplified Javascript intermediate representation for runtime type checks.
--
runtimeTypeChecks :: String -> Type -> [JS]
runtimeTypeChecks arg ty =
  let
    argTy = getFunctionArgumentType ty
  in
    maybe [] (argumentCheck (JSVar arg)) argTy
  where
  getFunctionArgumentType :: Type -> Maybe Type
  getFunctionArgumentType (TypeApp (TypeApp t funArg) _) | t == tyFunction = Just funArg
  getFunctionArgumentType (ForAll _ ty' _) = getFunctionArgumentType ty'
  getFunctionArgumentType _ = Nothing
  argumentCheck :: JS -> Type -> [JS]
  argumentCheck val t | t == tyNumber = [typeCheck val "number"]
  argumentCheck val t | t == tyString = [typeCheck val "string"]
  argumentCheck val t | t == tyBoolean = [typeCheck val "boolean"]
  argumentCheck val (TypeApp t _) | t == tyArray = [arrayCheck val]
  argumentCheck val (TypeApp t row) | t == tyObject =
    case rowToList row of
      Tuple pairs _ -> typeCheck val "object" : concatMap (\(Tuple prop ty') -> argumentCheck (accessorString prop val) ty') pairs
  argumentCheck val (TypeApp (TypeApp t _) _) | t == tyFunction = [typeCheck val "function"]
  argumentCheck val (ForAll _ ty' _) = argumentCheck val ty'
  argumentCheck _ _ = []
  typeCheck :: JS -> String -> JS
  typeCheck js ty' = JSIfElse (JSBinary NotEqualTo (JSTypeOf js) (JSStringLiteral ty')) (JSBlock [JSThrow (JSStringLiteral $ ty' ++ " expected")]) Nothing
  arrayCheck :: JS -> JS
  arrayCheck js = JSIfElse (JSUnary Not (JSApp (JSAccessor "isArray" (JSVar "Array")) [js])) (JSBlock [JSThrow (JSStringLiteral "Array expected")]) Nothing

-- |
-- Generate code in the simplified Javascript intermediate representation for a reference to a
-- variable.
--
varToJs :: ModuleName -> Qualified Ident -> JS
varToJs _ (Qualified Nothing ident) = var ident
varToJs m qual = qualifiedToJS m id qual

-- |
-- Generate code in the simplified Javascript intermediate representation for a reference to a
-- variable that may have a qualified name.
--
qualifiedToJS :: forall a. ModuleName -> (a -> Ident) -> Qualified a -> JS
qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSVar (moduleNameToJs m'))
qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)

-- |
-- Generate code in the simplified Javascript intermediate representation for pattern match binders
-- and guards.
--
bindersToJs :: forall m. (Monad m) => Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS
bindersToJs opts m e binders vals = do
  valNames <- replicateM (length vals) freshName
  let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
  jss <- for binders $ \(CaseAlternative { binders = bs, guard = grd, result = result }) -> do
    ret <- valueToJs opts m e result
    go valNames [JSReturn ret] bs grd
  return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
                 []
  where
    go :: forall m. (Monad m) => [String] -> [JS] -> [Binder] -> Maybe Guard -> SupplyT m [JS]
    go _ done [] Nothing = return done
    go _ done [] (Just cond) = do
      cond' <- valueToJs opts m e cond
      return [JSIfElse cond' (JSBlock done) Nothing]
    go (v:vs) done' (b:bs) grd = do
      done'' <- go vs done' bs grd
      binderToJs m e v done'' b
    go _ _ _ _ = theImpossibleHappened "Invalid arguments to bindersToJs"

-- |
-- Generate code in the simplified Javascript intermediate representation for a pattern match
-- binder.
--
binderToJs :: forall m. (Monad m) => ModuleName -> Environment -> String -> [JS] -> Binder -> SupplyT m [JS]
binderToJs _ _ _ done NullBinder = return done
binderToJs _ _ varName done (StringBinder str) =
  return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
binderToJs _ _ varName done (NumberBinder num) =
  return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
binderToJs _ _ varName done (BooleanBinder true) =
  return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
binderToJs _ _ varName done (BooleanBinder false) =
  return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
binderToJs _ _ varName done (VarBinder ident) =
  return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
binderToJs m e varName done (ConstructorBinder ctor bs) = do
  js <- go 0 done bs
  return
    if isOnlyConstructor e ctor
    then js
    else [ JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName))
                                      (JSStringLiteral (show ctor)))
                    (JSBlock js)
                    Nothing
         ]
  where
  go :: forall m. (Monad m) => Number -> [JS] -> [Binder] -> SupplyT m [JS]
  go _ done' [] = return done'
  go index done' (binder:bs') = do
    argVar <- freshName
    done'' <- go (index + 1) done' bs'
    js <- binderToJs m e argVar done'' binder
    return (JSVariableIntroduction argVar (Just (JSIndexer (JSNumericLiteral index) (JSAccessor "values" (JSVar varName)))) : js)
binderToJs m e varName done (ObjectBinder bs) = go done bs
  where
  go :: forall m. (Monad m) => [JS] -> [Tuple String Binder] -> SupplyT m [JS]
  go done' [] = return done'
  go done' ((Tuple prop binder):bs') = do
    propVar <- freshName
    done'' <- go done' bs'
    js <- binderToJs m e propVar done'' binder
    return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
binderToJs m e varName done (ArrayBinder bs) = do
  js <- go done 0 bs
  return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (length bs))) (JSBlock js) Nothing]
  where
  go :: forall m. (Monad m) => [JS] -> Number -> [Binder] -> SupplyT m [JS]
  go done' _ [] = return done'
  go done' index (binder:bs') = do
    elVar <- freshName
    done'' <- go done' (index + 1) bs'
    js <- binderToJs m e elVar done'' binder
    return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral index) (JSVar varName))) : js)
binderToJs m e varName done (ConsBinder headBinder tailBinder) = do
  headVar <- freshName
  tailVar <- freshName
  js1 <- binderToJs m e headVar done headBinder
  js2 <- binderToJs m e tailVar js1 tailBinder
  return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar varName)) (JSNumericLiteral 0)) (JSBlock
    ( JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral 0) (JSVar varName))) :
      JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral 1])) :
      js2
    )) Nothing]
binderToJs m e varName done (NamedBinder ident binder) = do
  js <- binderToJs m e varName done binder
  return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
binderToJs m e varName done (PositionedBinder _ binder) =
  binderToJs m e varName done binder

-- |
-- Checks whether a data constructor is the only constructor for that type, used to simplify the
-- check when generating code for binders.
--
isOnlyConstructor :: Environment -> Qualified ProperName -> Boolean
isOnlyConstructor (Environment e) ctor =
  let ty = maybe (theImpossibleHappened "Data constructor not found") id $ ctor `M.lookup` e.dataConstructors
  in numConstructors (Tuple ctor ty) == 1
  where
  numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ e.dataConstructors
  typeConstructor (Tuple (Qualified (Just moduleName) _) (Tuple tyCtor _)) = Tuple moduleName tyCtor
  typeConstructor _ = theImpossibleHappened "Invalid argument to isOnlyConstructor"

module Language.PureScript.CodeGen.JS
  ( ModuleType(..)
  , declToJs
  , moduleToJs
  ) where

import Control.Apply
import Control.Monad (replicateM)
import Data.Array
import Data.Either
import Data.Function (on)
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import Data.Tuple
import Data.Tuple3
import Data.Tuple5
import Data.Traversable (for, traverse)
import qualified Data.Map as M

import Language.PureScript.CodeGen.Common
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Declarations
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Names
import Language.PureScript.Options
-- import Language.PureScript.Optimizer
import Language.PureScript.Supply
import Language.PureScript.Traversals (sndM)
import Language.PureScript.Types

-- TODO: not this, once Language.PureScript.Optimizer is in place
optimize :: Options -> JS -> JS
optimize _ js = js

-- |
-- Different types of modules which are supported
--
data ModuleType = CommonJS | Globals

-- |
-- Generate code in the simplified Javascript intermediate representation for all declarations in a
-- module.
--
moduleToJs :: forall m. (Monad m) => ModuleType -> Options -> Module -> Environment -> SupplyT m [JS]
moduleToJs mt opts@(Options o) (Module name decls (Just exps)) env = do
  let jsImports = map (importToJs mt opts) $ (\x -> x \\ [name]) $ nub $ concatMap imports decls
  jsDecls <- traverse (\decl -> declToJs opts name decl env) decls
  let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls
  let isModuleEmpty = null optimized
  let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized
  let moduleExports = JSObjectLiteral $ concatMap exportToJs exps
  return $ case mt of
    CommonJS -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]
    Globals | not isModuleEmpty ->
      [ JSVariableIntroduction (fromJust o.browserNamespace)
                               (Just (JSBinary Or (JSVar (fromJust o.browserNamespace)) (JSObjectLiteral [])) )
      , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar (fromJust o.browserNamespace)))
                     (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])
      ]
    _ -> []
moduleToJs _ _ _ _ = theImpossibleHappened "Exports should have been elaborated in name desugaring"

importToJs :: ModuleType -> Options -> ModuleName -> JS
importToJs mt (Options opts) mn = JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
  where
  moduleBody = case mt of
    CommonJS -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
    Globals -> JSAccessor (moduleNameToJs mn) (JSVar (fromJust opts.browserNamespace))

imports :: Declaration -> [ModuleName]
imports =
  case everythingOnValues (++) (const []) collect (const []) (const []) (const []) of
    Tuple5 f _ _ _ _ -> f
  where
  collect :: Value -> [ModuleName]
  collect (Var (Qualified (Just mn) _)) = [mn]
  collect (Constructor (Qualified (Just mn) _)) = [mn]
  collect _ = []

-- |
-- Generate code in the simplified Javascript intermediate representation for a declaration
--
declToJs :: forall m. (Monad m) => Options -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])
declToJs opts mp (ValueDeclaration ident _ _ _ val) e = do
  js <- valueToJs opts mp e val
  return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]
declToJs opts mp (BindingGroupDeclaration vals) e = do
  jss <- for vals $ \(Tuple3 ident _ val) -> do
    js <- valueToJs opts mp e val
    return $ JSVariableIntroduction (identToJs ident) (Just js)
  return $ Just jss
declToJs _ mp (DataDeclaration _ _ ctors) _ = do
  return $ Just $ flip concatMap ctors $ \(Tuple pn@(ProperName ctor) tys) ->
    [JSVariableIntroduction ctor (Just (go pn 0 tys []))]
    where
    go :: ProperName -> Number -> [Type] -> [JS] -> JS
    go pn _ [] values =
      JSObjectLiteral [ Tuple "ctor" (JSStringLiteral $ show $ Qualified (Just mp) pn)
                      , Tuple "values" (JSArrayLiteral $ reverse values) ]
    go pn index (_ : tys') values =
      JSFunction Nothing ["value" ++ show index]
        (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])
declToJs opts mp (DataBindingGroupDeclaration ds) e = do
  jss <- traverse (\decl -> declToJs opts mp decl e) ds
  return $ Just $ concat $ catMaybes jss
declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = return $ Just [js]
declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e
declToJs _ _ _ _ = return Nothing

-- |
-- Generate key//value pairs for an object literal exporting values from a module.
--
exportToJs :: DeclarationRef -> [Tuple String JS]
exportToJs (TypeRef _ (Just dctors)) = map (\(ProperName n) -> Tuple n (var (Ident n))) dctors
exportToJs (ValueRef name) = [Tuple (runIdent name) (var name)]
exportToJs (TypeInstanceRef name) = [Tuple (runIdent name) (var name)]
exportToJs _ = []

-- |
-- Generate code in the simplified Javascript intermediate representation for a variable based on a
-- PureScript identifier.
--
var :: Ident -> JS
var = JSVar <<< identToJs

-- |
-- Generate code in the simplified Javascript intermediate representation for an accessor based on
-- a PureScript identifier. If the name is not valid in Javascript (symbol based, reserved name) an
-- indexer is returned.
--
accessor :: Ident -> JS -> JS
accessor (Ident prop) = accessorString prop
accessor (Op op) = JSIndexer (JSStringLiteral op)

accessorString :: String -> JS -> JS
accessorString prop | isIdent prop = JSAccessor prop
accessorString prop                = JSIndexer (JSStringLiteral prop)

-- |
-- Generate code in the simplified Javascript intermediate representation for a value or expression.
--
valueToJs :: forall m. (Monad m) => Options -> ModuleName -> Environment -> Value -> SupplyT m JS
valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n
valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s
valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b
valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral <$> traverse (valueToJs opts m e) xs
valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral <$> traverse (sndM (valueToJs opts m e)) ps
valueToJs opts m e (ObjectUpdate o ps) = do
  obj <- valueToJs opts m e o
  sts <- traverse (sndM (valueToJs opts m e)) ps
  extendObj obj sts
valueToJs _ m _ (Constructor name) = return $ qualifiedToJS m (Ident <<< runProperName) name
valueToJs opts m e (Case values binders) = do
  vals <- traverse (valueToJs opts m e) values
  bindersToJs opts m e binders vals
valueToJs opts m e (IfThenElse cond th el) = JSConditional <$> valueToJs opts m e cond <*> valueToJs opts m e th <*> valueToJs opts m e el
valueToJs opts m e (Accessor prop val) = accessorString prop <$> valueToJs opts m e val
valueToJs opts m e (App val arg) = JSApp <$> valueToJs opts m e val <*> (return <$> valueToJs opts m e arg)
valueToJs opts m e (Let ds val) = do
  decls <- concat <<< catMaybes <$> traverse (flip (declToJs opts m) e) ds
  ret <- valueToJs opts m e val
  return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []
valueToJs opts m e (Abs (Left arg) val) = do
  ret <- valueToJs opts m e val
  return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
valueToJs opts@(Options o) m e (TypedValue _ (Abs (Left arg) val) ty) | o.performRuntimeTypeChecks = do
  let arg' = identToJs arg
  ret <- valueToJs opts m e val
  return $ JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn ret])
valueToJs _ m _ (Var ident) = return $ varToJs m ident
valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val
valueToJs _ _ _ (TypeClassDictionary _ _ _) = theImpossibleHappened "Type class dictionary was not replaced"
valueToJs _ _ _ _ = theImpossibleHappened "Invalid argument to valueToJs"

-- |
-- Shallow copy an object.
--
extendObj :: forall m. (Monad m) => JS -> [Tuple String JS] -> SupplyT m JS
extendObj obj sts = do
  newObj <- freshName
  key <- freshName
  let
    jsKey = JSVar key
    jsNewObj = JSVar newObj
    block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
    objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
    copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
    cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
    assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
    stToAssign (Tuple s js) = JSAssignment (JSAccessor s jsNewObj) js
    extend = map stToAssign sts
  return $ JSApp (JSFunction Nothing [] block) []

-- |
-- Generate code in the simplified Javascript intermediate representation for runtime type checks.
--
runtimeTypeChecks :: String -> Type -> [JS]
runtimeTypeChecks arg ty =
  let
    argTy = getFunctionArgumentType ty
  in
    maybe [] (argumentCheck (JSVar arg)) argTy
  where
  getFunctionArgumentType :: Type -> Maybe Type
  getFunctionArgumentType (TypeApp (TypeApp t funArg) _) | t == tyFunction = Just funArg
  getFunctionArgumentType (ForAll _ ty' _) = getFunctionArgumentType ty'
  getFunctionArgumentType _ = Nothing
  argumentCheck :: JS -> Type -> [JS]
  argumentCheck val t | t == tyNumber = [typeCheck val "number"]
  argumentCheck val t | t == tyString = [typeCheck val "string"]
  argumentCheck val t | t == tyBoolean = [typeCheck val "boolean"]
  argumentCheck val (TypeApp t _) | t == tyArray = [arrayCheck val]
  argumentCheck val (TypeApp t row) | t == tyObject =
    case rowToList row of
      Tuple pairs _ -> typeCheck val "object" : concatMap (\(Tuple prop ty') -> argumentCheck (accessorString prop val) ty') pairs
  argumentCheck val (TypeApp (TypeApp t _) _) | t == tyFunction = [typeCheck val "function"]
  argumentCheck val (ForAll _ ty' _) = argumentCheck val ty'
  argumentCheck _ _ = []
  typeCheck :: JS -> String -> JS
  typeCheck js ty' = JSIfElse (JSBinary NotEqualTo (JSTypeOf js) (JSStringLiteral ty')) (JSBlock [JSThrow (JSStringLiteral $ ty' ++ " expected")]) Nothing
  arrayCheck :: JS -> JS
  arrayCheck js = JSIfElse (JSUnary Not (JSApp (JSAccessor "isArray" (JSVar "Array")) [js])) (JSBlock [JSThrow (JSStringLiteral "Array expected")]) Nothing

-- |
-- Generate code in the simplified Javascript intermediate representation for a reference to a
-- variable.
--
varToJs :: ModuleName -> Qualified Ident -> JS
varToJs _ (Qualified Nothing ident) = var ident
varToJs m qual = qualifiedToJS m id qual

-- |
-- Generate code in the simplified Javascript intermediate representation for a reference to a
-- variable that may have a qualified name.
--
qualifiedToJS :: forall a. ModuleName -> (a -> Ident) -> Qualified a -> JS
qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSVar (moduleNameToJs m'))
qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)

-- |
-- Generate code in the simplified Javascript intermediate representation for pattern match binders
-- and guards.
--
bindersToJs :: forall m. (Monad m) => Options -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS
bindersToJs opts m e binders vals = do
  valNames <- replicateM (length vals) freshName
  let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
  jss <- for binders $ \(CaseAlternative { binders = bs, guard = grd, result = result }) -> do
    ret <- valueToJs opts m e result
    go valNames [JSReturn ret] bs grd
  return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))
                 []
  where
    go :: forall m. (Monad m) => [String] -> [JS] -> [Binder] -> Maybe Guard -> SupplyT m [JS]
    go _ done [] Nothing = return done
    go _ done [] (Just cond) = do
      cond' <- valueToJs opts m e cond
      return [JSIfElse cond' (JSBlock done) Nothing]
    go (v:vs) done' (b:bs) grd = do
      done'' <- go vs done' bs grd
      binderToJs m e v done'' b
    go _ _ _ _ = theImpossibleHappened "Invalid arguments to bindersToJs"

-- |
-- Generate code in the simplified Javascript intermediate representation for a pattern match
-- binder.
--
binderToJs :: forall m. (Monad m) => ModuleName -> Environment -> String -> [JS] -> Binder -> SupplyT m [JS]
binderToJs _ _ _ done NullBinder = return done
binderToJs _ _ varName done (StringBinder str) =
  return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
binderToJs _ _ varName done (NumberBinder num) =
  return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
binderToJs _ _ varName done (BooleanBinder true) =
  return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
binderToJs _ _ varName done (BooleanBinder false) =
  return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
binderToJs _ _ varName done (VarBinder ident) =
  return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
binderToJs m e varName done (ConstructorBinder ctor bs) = do
  js <- go 0 done bs
  return
    if isOnlyConstructor e ctor
    then js
    else [ JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName))
                                      (JSStringLiteral (show ctor)))
                    (JSBlock js)
                    Nothing
         ]
  where
  go :: forall m. (Monad m) => Number -> [JS] -> [Binder] -> SupplyT m [JS]
  go _ done' [] = return done'
  go index done' (binder:bs') = do
    argVar <- freshName
    done'' <- go (index + 1) done' bs'
    js <- binderToJs m e argVar done'' binder
    return (JSVariableIntroduction argVar (Just (JSIndexer (JSNumericLiteral index) (JSAccessor "values" (JSVar varName)))) : js)
binderToJs m e varName done (ObjectBinder bs) = go done bs
  where
  go :: forall m. (Monad m) => [JS] -> [Tuple String Binder] -> SupplyT m [JS]
  go done' [] = return done'
  go done' ((Tuple prop binder):bs') = do
    propVar <- freshName
    done'' <- go done' bs'
    js <- binderToJs m e propVar done'' binder
    return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
binderToJs m e varName done (ArrayBinder bs) = do
  js <- go done 0 bs
  return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (length bs))) (JSBlock js) Nothing]
  where
  go :: forall m. (Monad m) => [JS] -> Number -> [Binder] -> SupplyT m [JS]
  go done' _ [] = return done'
  go done' index (binder:bs') = do
    elVar <- freshName
    done'' <- go done' (index + 1) bs'
    js <- binderToJs m e elVar done'' binder
    return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral index) (JSVar varName))) : js)
binderToJs m e varName done (ConsBinder headBinder tailBinder) = do
  headVar <- freshName
  tailVar <- freshName
  js1 <- binderToJs m e headVar done headBinder
  js2 <- binderToJs m e tailVar js1 tailBinder
  return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar varName)) (JSNumericLiteral 0)) (JSBlock
    ( JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral 0) (JSVar varName))) :
      JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral 1])) :
      js2
    )) Nothing]
binderToJs m e varName done (NamedBinder ident binder) = do
  js <- binderToJs m e varName done binder
  return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
binderToJs m e varName done (PositionedBinder _ binder) =
  binderToJs m e varName done binder

-- |
-- Checks whether a data constructor is the only constructor for that type, used to simplify the
-- check when generating code for binders.
--
isOnlyConstructor :: Environment -> Qualified ProperName -> Boolean
isOnlyConstructor (Environment e) ctor =
  let ty = maybe (theImpossibleHappened "Data constructor not found") id $ ctor `M.lookup` e.dataConstructors
  in numConstructors (Tuple ctor ty) == 1
  where
  numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ e.dataConstructors
  typeConstructor (Tuple (Qualified (Just moduleName) _) (Tuple tyCtor _)) = Tuple moduleName tyCtor
  typeConstructor _ = theImpossibleHappened "Invalid argument to isOnlyConstructor"


cache tracks based on both canvas size and view width

module Genetics.Browser.Track.UI where

import Prelude

import Color (black)
import Control.Coroutine (Consumer, Producer, connect, runProcess)
import Control.Coroutine as Co
import Control.Monad.Aff (Aff, Fiber, Milliseconds, delay, forkAff, killFiber, launchAff, launchAff_)
import Control.Monad.Aff.AVar (AVar, makeEmptyVar, makeVar, putVar, readVar, takeVar, tryTakeVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Rec.Class (forever)
import DOM.Classy.ParentNode (toParentNode)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Foldable (class Foldable, foldMap, length, null, sum)
import Data.Foreign (Foreign, MultipleErrors, renderForeignError)
import Data.Generic.Rep (class Generic)
import Data.Lens (Iso', iso, re, to, (^.))
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype, over, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Profunctor.Star (Star(..))
import Data.Record.Extra (eqRecord)
import Data.Symbol (SProxy(..))
import Data.Traversable (for_, traverse, traverse_)
import Data.Tuple (Tuple(Tuple), uncurry)
import Data.Variant (Variant, case_, inj, on)
import Debug.Trace as Debug
import Genetics.Browser.Track.Backend (RenderedTrack, bumpFeatures, drawBrowser, negLog10, zipMapsWith)
import Genetics.Browser.Track.Demo (Annot, BedFeature, GWASFeature, annotLegendTest, filterSig, getAnnotations, getAnnotations', getGWAS, getGenes, produceAnnots, produceGWAS, produceGenes, renderAnnot, renderGWAS)
import Genetics.Browser.Track.UI.Canvas (BrowserCanvas, TrackPadding, _Dimensions, _Track, browserCanvas, browserOnClick, debugBrowserCanvas, dragScroll, renderBrowser, setBrowserCanvasSize, uiSlots, wheelZoom)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId))
import Genetics.Browser.Types.Coordinates (CoordSys, CoordSysView(..), _TotalSize, aroundPair, coordSys, normalizeView, pairSize, pairsOverlap, pixelsView, scaleViewBy, showViewScale, translateViewBy, viewScale)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point)
import Math as Math
import Partial.Unsafe (unsafePartial)
import Simple.JSON (read)

foreign import windowInnerSize :: ∀ e. Eff e Canvas.Dimensions

-- | Set an event to fire on the given button id
foreign import buttonEvent :: ∀ e.
                              String
                           -> Eff e Unit
                           -> Eff e Unit

-- | Set callback to run after the window has resized (see UI.js for
-- | time waited), providing it with the new window size.
foreign import resizeEvent :: ∀ e.
                              ({ width  :: Number
                               , height :: Number } -> Eff e Unit)
                           -> Eff e Unit

data UpdateView =
    ScrollView Number
  | ZoomView Number
  | ModView (Pair BigInt -> Pair BigInt)

instance showUpdateView :: Show UpdateView where
  show (ScrollView x) = "(Scroll by " <> show x <> ")"
  show (ZoomView s) = "(Zoom by " <> show s <> ")"
  show _ = "(ModView)"

    -- TODO idk if this instance makes sense??? whatevs
instance semigroupUpdateView :: Semigroup UpdateView where
  append (ScrollView x1) (ScrollView x2) = ScrollView (x1 + x2)
  append (ZoomView s1)   (ZoomView s2)   = ZoomView   (s1 * s2)
  append _ y = y

instance monoidUpdateView :: Monoid UpdateView where
  mempty = ModView id

updateViewFold :: UpdateView
               -> CoordSysView
               -> CoordSysView
updateViewFold uv iv = case uv of
  ZoomView   x -> iv `scaleViewBy`     x
  ScrollView x -> iv `translateViewBy` x
  ModView f    -> over CoordSysView f iv

queueCmd :: ∀ a. AVar a -> a -> Eff _ Unit
queueCmd av cmd = launchAff_ $ putVar cmd av

btnScroll :: Number -> AVar UpdateView -> Eff _ Unit
btnScroll x av = do
  buttonEvent "scrollLeft"  $ queueCmd av $ ScrollView (-x)
  buttonEvent "scrollRight" $ queueCmd av $ ScrollView   x

btnZoom :: Number -> AVar UpdateView -> Eff _ Unit
btnZoom x av = do
  buttonEvent "zoomOut" $ queueCmd av $ ZoomView $ 1.0 + x
  buttonEvent "zoomIn"  $ queueCmd av $ ZoomView $ 1.0 - x

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

-- runs console.time() with the provided string, returns the effect to stop the timer
foreign import timeEff :: ∀ eff. String -> Eff eff (Eff eff Unit)

type UICmdR = ( render :: Unit
              , docResize :: { width :: Number, height :: Number } )

_render = SProxy :: SProxy "render"
_docResize = SProxy :: SProxy "docResize"

type UIState e = { view         :: AVar CoordSysView
                 , viewCmd      :: AVar UpdateView
                 , uiCmd        :: AVar (Variant UICmdR)
                 , renderFiber  :: AVar (Fiber e Unit)
                 -- , cachedTracks :: AVar { cachedViewWidth :: BigInt
                 --                        , glyphs :: List (Array RenderedTrack) }
                 , lastOverlaps :: AVar (Number -> Point -> { gwas :: Array (GWASFeature ()) } )
                 }

diffView :: CoordSysView -> CoordSysView -> CoordSysView
diffView v1 v2 =
  let (Pair l1 r1) = unwrap v1
      (Pair l2 r2) = unwrap v2
  in wrap $ Pair (l2 - l1) (r2 - r1)

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

_PairRec :: ∀ a. Iso' (Pair a) { l :: a, r :: a }
_PairRec = iso (\(Pair l r) -> {l, r}) (\ {l, r} -> Pair l r)

debugView :: UIState _
          -> Eff _ { get :: _
                   , set :: _ }
debugView s = do
  let get name = launchAff_ do
         view <- AVar.tryReadVar s.view
         liftEff case view of
           Nothing -> do
             log "CoordSysView state empty"
             setWindow name unit
           Just (v :: _)  -> do
             log $ "CoordSysView: " <> showView v
             setWindow name $ unwrap v ^. _PairRec

  let set lr = launchAff_ do
         view <- AVar.tryTakeVar s.view
         case view of
           Nothing -> pure unit
           Just _  -> do
             let v' = wrap $ lr ^. re _PairRec
             _ <- AVar.tryPutVar (inj _render unit) s.uiCmd
             AVar.putVar v' s.view

  pure {get, set}

uiViewUpdate :: ∀ r.
                CoordSys _ BigInt
             -> Milliseconds
             -> { view :: AVar CoordSysView
                , viewCmd :: AVar UpdateView
                , uiCmd :: AVar (Variant UICmdR) | r }
                -- , viewReady :: AVar Unit | r }
             -> Aff _ Unit
uiViewUpdate cs timeout { view, viewCmd, uiCmd } = do
  curCmdVar <- makeVar (ModView id)

  let normView = normalizeView cs (BigInt.fromInt 200000)
      loop' updater = do
        cmd <- takeVar viewCmd

        killFiber (error "Resetting view update") updater
        liftEff $ log $ "forking view update"

        curCmd <- takeVar curCmdVar
        let cmd' = curCmd <> cmd
        putVar cmd' curCmdVar

        updater' <- forkAff do
            delay timeout
            liftEff $ log "Running view update"
            vr <- takeVar view

            let vr' = normView $ updateViewFold cmd' vr

            putVar vr' view

            putVar (inj _render unit) uiCmd
            takeVar curCmdVar *> putVar mempty curCmdVar

        loop' updater'

  loop' (pure unit)

                         -- This is Star (Aff e) a b!
-- newtype AffCache e a b = AffCache (a -> Aff e b)

affCacheStar :: ∀ e a b.
                (a -> a -> Boolean)
             -> (a -> b)
             -> Aff _ (Star (Aff _) a b)
affCacheStar diff f = do
  inVar  <- AVar.makeEmptyVar
  outVar <- AVar.makeEmptyVar

  let cache = \a -> do
        lastIn  <- AVar.tryTakeVar inVar
        lastOut <- AVar.tryTakeVar outVar
        let o = case lastIn, lastOut of
                  Just i, Just o -> if diff a i then f a else o
                  _, _ -> f a

        AVar.putVar a inVar
        AVar.putVar o outVar
        pure o

  pure $ Star cache

cachedStar :: ∀ a b. Star (Aff _) a b -> a -> Aff _ b
cachedStar = unwrap

-- newtype AffCache a b =
--   AffCache { diff :: a -> a -> Boolean
--            , cache :: ∀ e. a -> Aff (avar :: AVAR | e) b }

newtype AffCache e a b =
  AffCache { diff :: a -> a -> Boolean
           , cache :: a -> Aff e b }

derive instance newtypeAffCache :: Newtype (AffCache e a b) _
derive instance genericAffCache :: Generic (AffCache e a b) _

derive instance functorAffCache :: Functor (AffCache e a)

cacheFun :: ∀ e a b.
            (a -> a -> Boolean)
         -> (a -> b)
         -> Aff _ (AffCache _ a b)
cacheFun diff f = do
  inVar  <- AVar.makeEmptyVar
  outVar <- AVar.makeEmptyVar

  let cache = \a -> do
        lastIn  <- AVar.tryTakeVar inVar
        lastOut <- AVar.tryTakeVar outVar
        let o = case lastIn, lastOut of
                  Just i, Just o -> if diff a i then f a else o
                  _, _ -> f a

        AVar.putVar a inVar
        AVar.putVar o outVar
        pure o

  pure $ AffCache { diff, cache }

cached :: ∀ a b.
          AffCache _ a b
       -> a -> Aff _ b
cached = _.cache <<< unwrap

browserCache
  :: ∀ a b.
     (BrowserCanvas
      -> CoordSysView
      -> { tracks :: { gwas :: a
                     , annotations :: b }
         , relativeUI :: Drawing
         , fixedUI :: Drawing })
     -> Aff _ (BrowserCanvas
               -> CoordSysView
               -> Aff _ ({ tracks :: { gwas :: a
                                     , annotations :: b }
                         , relativeUI :: Drawing
                         , fixedUI :: Drawing }))
browserCache f = do
  bcDim <- AVar.makeEmptyVar
  viewSize <- AVar.makeEmptyVar

  lastPartial <- AVar.makeEmptyVar
  lastFinal <- AVar.makeEmptyVar

  pure \bc csv -> do

    let newBCDim = bc ^. _Dimensions
    oldBCDim <- AVar.tryTakeVar bcDim
    AVar.putVar newBCDim bcDim

    oldPartial <- AVar.tryTakeVar lastPartial

    partial <- case oldBCDim, oldPartial of
      Just d, Just o -> do
        let changed = not $ d `eqRecord` newBCDim
        liftEff $ log $ "BrowserCanvas changed? " <> (show changed)
        -- remove the cached final output value on canvas resize,
        -- since we need to recalculate everything
        when changed (void $ AVar.tryTakeVar lastFinal)
        pure $ if d `eqRecord` newBCDim then o else f bc

      _, _ -> do
        liftEff $ log "Cache was empty! Recalculating all"
        _ <- AVar.tryTakeVar lastFinal
        pure $ f bc

    AVar.putVar partial lastPartial

    let newViewSize = pairSize $ unwrap csv
    oldViewSize <- AVar.tryTakeVar viewSize
    AVar.putVar newViewSize viewSize

    oldFinal <- AVar.tryTakeVar lastFinal

    output <- case oldViewSize, oldFinal of
      Just vs, Just o -> do
        let changed = newViewSize /= vs
        liftEff $ log $ "CoordSysView changed? " <> (show changed)
        pure $ if not changed then o else partial csv

      _, _ -> do
        liftEff $ log "Cache was empty! Recalculating tracks"
        pure $ partial csv

    AVar.putVar output lastFinal

    pure output

renderLoop :: CoordSys _ _
           -> (BrowserCanvas
               -> CoordSysView
               -> Aff _ ({ tracks ::
                              { gwas :: RenderedTrack (GWASFeature ())
                              , annotations :: RenderedTrack (Annot (score :: Number)) }
                         , relativeUI :: Drawing
                         , fixedUI :: Drawing }))
           -> BrowserCanvas
           -> UIState _
           -> Aff _ Unit
renderLoop cSys drawCachedBrowser canvas state = forever do

  uiCmd <- takeVar state.uiCmd
  case_ # on _render (\_ -> pure unit)
        # on _docResize (\ {width} -> do
                let {height} = canvas ^. _Dimensions
                canvas' <- liftEff $ setBrowserCanvasSize {width, height} canvas
                putVar (inj _render unit) state.uiCmd
                renderLoop cSys drawCachedBrowser canvas' state)
        $ uiCmd

  -- if there's a rendering fiber running, we kill it
  traverse_ (killFiber (error "Resetting renderer"))
    =<< tryTakeVar state.renderFiber

  csView <- readVar state.view
  toRender <- drawCachedBrowser canvas csView

  let currentScale = viewScale (canvas ^. _Track <<< _Dimensions) csView
      (Pair offset _) = pixelsView currentScale csView

  _ <- AVar.tryTakeVar state.lastOverlaps
                    -- offset the click by the current canvas translation
  AVar.putVar (\n r -> let r' = {x: r.x + offset, y: r.y }
                       in { gwas: toRender.tracks.gwas.overlaps n r' }) state.lastOverlaps

  -- fork a new renderFiber
  renderFiber <- forkAff
                 $ renderBrowser (wrap 2.0) canvas offset toRender

  putVar renderFiber state.renderFiber

printSNPInfo :: ∀ r. Array (GWASFeature r) -> Eff _ Unit
printSNPInfo fs = do
  let n = length fs :: Int
      m = 5

      showSnp f = do
        log $ f.feature.name <> " - "
           <> unwrap f.feature.chrId <> " @ "
           <> show (map show f.position)

  log $ "showing " <> show n <> " clicked glyphs"
  for_ (Array.take m fs) showSnp

snpInfoHTML :: ∀ r. GWASFeature r -> String
snpInfoHTML { position, feature } =
    "
SNP: "   <> feature.name <> "
"
 <> "
Chr: "   <> show feature.chrId <> "
"
 <> "
Pos: "   <> show (Pair.fst position) <> "
"
 <> "
Score: " <> show feature.score <> "
"
 <> "
-log10: " <> show (negLog10 feature.score) <> "
"

snpInfoHTML' :: ∀ rA rS.
                (GWASFeature rS -> Maybe (Annot (score :: Number | rA)))
             -> GWASFeature rS
             -> String
snpInfoHTML' assocAnnot snp =
   snpInfoHTML snp <> case assocAnnot snp of
     Nothing -> "
No annotation found
"
     Just a  -> "
Annotation: " <> show a.feature.name <> "
"
             <> "
Annot. score: " <> show a.feature.score <> "
"
             <> "
Annot. -log10: " <> show (negLog10 a.feature.score) <> "
"

annotForSnp :: ∀ rA rS.
               Bp
            -> Map ChrId (Array (Annot rA))
            -> GWASFeature rS
            -> Maybe (Annot rA)
annotForSnp radius annotations {position, feature} = do
  chr <- Map.lookup feature.chrId annotations
  Array.find (\a -> ((radius `aroundPair` a.position) `pairsOverlap` position)) chr

foreign import setInfoBoxVisibility :: ∀ e. String -> Eff e Unit
foreign import setInfoBoxContents :: ∀ e. String -> Eff e Unit

foreign import initDebugDiv :: ∀ e. Number -> Eff e Unit

foreign import setDebugDivVisibility :: ∀ e. String -> Eff e Unit

foreign import setDebugDivPoint :: ∀ e. Point -> Eff e Unit

-- TODO configure UI widths
runBrowser :: Conf -> BrowserCanvas -> Eff _ _
runBrowser config bc = launchAff $ do

  let clickRadius = 1.0

  liftEff $ initDebugDiv clickRadius

  let cSys :: CoordSys ChrId BigInt
      cSys = coordSys mouseChrSizes

      bumpRadius = Bp 50000000.0

  trackData <- do
    genes <- traverse (getGenes cSys) config.urls.genes
    gwas  <- traverse (getGWAS  cSys) config.urls.gwas

    rawAnnotations <-
      traverse (uncurry $ getAnnotations' cSys) do
        snps <- filterSig config.score <$> gwas
        url <- config.urls.annotations
        pure $ Tuple snps url

    let annotations = zipMapsWith
                       (bumpFeatures (to _.feature.score)
                                      (SProxy :: SProxy "score")
                                      bumpRadius)
                       <$> gwas <*> rawAnnotations

    pure { genes, gwas, annotations }

  let initialView :: CoordSysView
      initialView = wrap $ Pair zero (cSys^._TotalSize)
      trackDims = bc ^. _Track <<< _Dimensions

  viewCmd <- makeEmptyVar

  liftEff do
    btnScroll 0.05 viewCmd
    btnZoom   0.10 viewCmd

    let dragCB {x,y} =
          when (Math.abs x >= one)
          $ queueCmd viewCmd $ ScrollView $ (-x) / trackDims.width
    dragScroll bc dragCB

    let scrollZoomScale = 0.06
        wheelCB dY =
          queueCmd viewCmd $ ZoomView $ 1.0 + scrollZoomScale * dY
    wheelZoom bc wheelCB

  uiCmd <- makeVar (inj _render unit)

  liftEff do
    resizeEvent \d ->
      queueCmd uiCmd (inj _docResize d)

  view <- makeVar initialView
  renderFiber <- makeEmptyVar
  lastOverlaps <- AVar.makeEmptyVar

  let initState :: UIState _
      initState = { view, viewCmd, uiCmd, renderFiber, lastOverlaps }

  let
      slots = uiSlots bc

      entries = foldMap annotLegendTest trackData.annotations
      legend = { width: slots.right.size.width
               , entries }

      s = config.score

      vscale = { width: slots.left.size.width
               , color: black
               , min: s.min, max: s.max, sig: s.sig }

      padding = { horizontal: config.trackPadding.left
                , vertical: config.trackPadding.top }

      mainBrowser :: _
      mainBrowser = drawBrowser cSys {legend, vscale}
                      { gwas: renderGWAS vscale
                      , annotations: renderAnnot vscale }
                      { gwas: fromMaybe mempty trackData.gwas
                      , annotations: fromMaybe mempty trackData.annotations }

      viewTimeout :: Milliseconds
      viewTimeout = wrap 100.0

  liftEff do
    setWindow "mainBrowser" mainBrowser

    let findAnnot = annotForSnp bumpRadius $ fromMaybe mempty trackData.annotations

    let glyphClick :: _
        glyphClick p = launchAff_ do
          AVar.tryReadVar lastOverlaps >>= case _ of
             Nothing -> liftEff do
               log "clicked no glyphs"
               setInfoBoxVisibility "hidden"

             Just gs -> liftEff do
               let clicked = (gs clickRadius p).gwas
               printSNPInfo clicked
               case Array.head clicked of
                 Nothing -> setInfoBoxVisibility "hidden"
                 Just g  -> do
                   setInfoBoxContents $ snpInfoHTML' findAnnot g
                   setInfoBoxVisibility "visible"

    let overlayDebug :: _
        overlayDebug p = do

          setDebugDivVisibility "visible"
          setDebugDivPoint p

    browserOnClick bc
      { overlay: \_ -> pure unit
      , track:   glyphClick }

  _ <- forkAff $ uiViewUpdate cSys viewTimeout initState

  cached <- browserCache mainBrowser

  _ <- forkAff $ renderLoop cSys cached bc initState

  pure unit

type DataURLs = { gwas        :: Maybe String
                , annotations :: Maybe String
                , genes       :: Maybe String
                }

type Conf = { browserHeight :: Number
            , trackPadding :: TrackPadding
            , score :: { min :: Number, max :: Number, sig :: Number }
            , urls :: DataURLs
            }

foreign import setWindow :: ∀ e a. String -> a -> Eff e Unit

initBrowser :: Foreign -> Eff _ _
initBrowser rawConfig = do

  el' <- do
    doc <- DOM.htmlDocumentToDocument
           <$> (DOM.document =<< DOM.window)
    DOM.querySelector (wrap "#browser") (toParentNode doc)

  case read rawConfig :: Either MultipleErrors Conf of
    Left errs -> traverse_ (log <<< renderForeignError) errs
    Right c   -> do
      case el' of
        Nothing -> log "Could not find element '#browser'"
        Just el -> do

          {width} <- windowInnerSize
          let dimensions = { width, height: c.browserHeight }
          bc <- browserCanvas dimensions c.trackPadding el

          debugBrowserCanvas "debugBC" bc

          log $ unsafeStringify c
          void $ runBrowser c bc

-- TODO this could almost certainly be done better
chunkConsumer :: ∀ m a.
                 Foldable m
              => Monoid (m a)
              => AVar (m a)
              -> Consumer (m a) (Aff _) Unit
chunkConsumer av = Co.consumer \m ->
  if null m
     then pure $ Just unit
     else do
       sofar <- takeVar av
       putVar (sofar <> m) av
       delay (wrap 20.0)
       pure Nothing

type TrackVar a = AVar (Map ChrId (Array a))
type TrackProducer eff a = Producer (Map ChrId (Array a)) (Aff eff) Unit

-- Feels like this one takes care of a bit too much...
fetchLoop1 :: ∀ a.
              (Maybe (Aff _ (TrackProducer _ a)))
           -> Aff _ (TrackVar a)
fetchLoop1 Nothing = AVar.makeEmptyVar
fetchLoop1 (Just startProd) = do
  prod <- startProd
  avar <- makeVar mempty
  _ <- forkAff $ runProcess $ prod `connect` chunkConsumer avar
  pure avar

-- | Starts threads that fetch & parse each of the provided tracks,
-- | filling an AVar over time per track, which can be used by other parts of the application
-- | (read only, should be a newtype)
fetchLoop :: CoordSys ChrId BigInt
          -> DataURLs
          -> Aff _
               { gwas :: TrackVar (GWASFeature ())
               , genes :: TrackVar BedFeature
               , annotations :: TrackVar (Annot ())
               }
fetchLoop cs urls = do
  gwas <-        fetchLoop1 $ produceGWAS   cs <$> urls.gwas
  annotations <- fetchLoop1 $ produceAnnots cs <$> urls.annotations
  genes <-       fetchLoop1 $ produceGenes  cs <$> urls.genes
  pure { gwas, genes, annotations }

module Genetics.Browser.Track.UI where

import Prelude

import Color (black)
import Control.Coroutine (Consumer, Producer, connect, runProcess)
import Control.Coroutine as Co
import Control.Monad.Aff (Aff, Fiber, Milliseconds, delay, forkAff, killFiber, launchAff, launchAff_)
import Control.Monad.Aff.AVar (AVar, makeEmptyVar, makeVar, putVar, readVar, takeVar, tryTakeVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Rec.Class (forever)
import DOM.Classy.ParentNode (toParentNode)
import DOM.HTML (window) as DOM
import DOM.HTML.Types (htmlDocumentToDocument) as DOM
import DOM.HTML.Window (document) as DOM
import DOM.Node.ParentNode (querySelector) as DOM
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Either (Either(Right, Left))
import Data.Foldable (class Foldable, foldMap, length, null, sum)
import Data.Foreign (Foreign, MultipleErrors, renderForeignError)
import Data.Generic.Rep (class Generic)
import Data.Lens (Iso', iso, re, to, (^.))
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype, over, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Pair as Pair
import Data.Profunctor.Star (Star(..))
import Data.Record.Extra (eqRecord)
import Data.Symbol (SProxy(..))
import Data.Traversable (for_, traverse, traverse_)
import Data.Tuple (Tuple(Tuple), uncurry)
import Data.Variant (Variant, case_, inj, on)
import Debug.Trace as Debug
import Genetics.Browser.Track.Backend (RenderedTrack, bumpFeatures, drawBrowser, negLog10, zipMapsWith)
import Genetics.Browser.Track.Demo (Annot, BedFeature, GWASFeature, annotLegendTest, filterSig, getAnnotations, getAnnotations', getGWAS, getGenes, produceAnnots, produceGWAS, produceGenes, renderAnnot, renderGWAS)
import Genetics.Browser.Track.UI.Canvas (BrowserCanvas, TrackPadding, _Dimensions, _Track, browserCanvas, browserOnClick, debugBrowserCanvas, dragScroll, renderBrowser, setBrowserCanvasSize, uiSlots, wheelZoom)
import Genetics.Browser.Types (Bp(Bp), ChrId(ChrId))
import Genetics.Browser.Types.Coordinates (CoordSys, CoordSysView(..), _TotalSize, aroundPair, coordSys, normalizeView, pairSize, pairsOverlap, pixelsView, scaleViewBy, showViewScale, translateViewBy, viewScale)
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point)
import Math as Math
import Partial.Unsafe (unsafePartial)
import Simple.JSON (read)

foreign import windowInnerSize :: ∀ e. Eff e Canvas.Dimensions

-- | Set an event to fire on the given button id
foreign import buttonEvent :: ∀ e.
                              String
                           -> Eff e Unit
                           -> Eff e Unit

-- | Set callback to run after the window has resized (see UI.js for
-- | time waited), providing it with the new window size.
foreign import resizeEvent :: ∀ e.
                              ({ width  :: Number
                               , height :: Number } -> Eff e Unit)
                           -> Eff e Unit

data UpdateView =
    ScrollView Number
  | ZoomView Number
  | ModView (Pair BigInt -> Pair BigInt)

instance showUpdateView :: Show UpdateView where
  show (ScrollView x) = "(Scroll by " <> show x <> ")"
  show (ZoomView s) = "(Zoom by " <> show s <> ")"
  show _ = "(ModView)"

    -- TODO idk if this instance makes sense??? whatevs
instance semigroupUpdateView :: Semigroup UpdateView where
  append (ScrollView x1) (ScrollView x2) = ScrollView (x1 + x2)
  append (ZoomView s1)   (ZoomView s2)   = ZoomView   (s1 * s2)
  append _ y = y

instance monoidUpdateView :: Monoid UpdateView where
  mempty = ModView id

updateViewFold :: UpdateView
               -> CoordSysView
               -> CoordSysView
updateViewFold uv iv = case uv of
  ZoomView   x -> iv `scaleViewBy`     x
  ScrollView x -> iv `translateViewBy` x
  ModView f    -> over CoordSysView f iv

queueCmd :: ∀ a. AVar a -> a -> Eff _ Unit
queueCmd av cmd = launchAff_ $ putVar cmd av

btnScroll :: Number -> AVar UpdateView -> Eff _ Unit
btnScroll x av = do
  buttonEvent "scrollLeft"  $ queueCmd av $ ScrollView (-x)
  buttonEvent "scrollRight" $ queueCmd av $ ScrollView   x

btnZoom :: Number -> AVar UpdateView -> Eff _ Unit
btnZoom x av = do
  buttonEvent "zoomOut" $ queueCmd av $ ZoomView $ 1.0 + x
  buttonEvent "zoomIn"  $ queueCmd av $ ZoomView $ 1.0 - x

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

-- runs console.time() with the provided string, returns the effect to stop the timer
foreign import timeEff :: ∀ eff. String -> Eff eff (Eff eff Unit)

type UICmdR = ( render :: Unit
              , docResize :: { width :: Number, height :: Number } )

_render = SProxy :: SProxy "render"
_docResize = SProxy :: SProxy "docResize"

type UIState e = { view         :: AVar CoordSysView
                 , viewCmd      :: AVar UpdateView
                 , uiCmd        :: AVar (Variant UICmdR)
                 , renderFiber  :: AVar (Fiber e Unit)
                 -- , cachedTracks :: AVar { cachedViewWidth :: BigInt
                 --                        , glyphs :: List (Array RenderedTrack) }
                 , lastOverlaps :: AVar (Number -> Point -> { gwas :: Array (GWASFeature ()) } )
                 }

diffView :: CoordSysView -> CoordSysView -> CoordSysView
diffView v1 v2 =
  let (Pair l1 r1) = unwrap v1
      (Pair l2 r2) = unwrap v2
  in wrap $ Pair (l2 - l1) (r2 - r1)

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

_PairRec :: ∀ a. Iso' (Pair a) { l :: a, r :: a }
_PairRec = iso (\(Pair l r) -> {l, r}) (\ {l, r} -> Pair l r)

debugView :: UIState _
          -> Eff _ { get :: _
                   , set :: _ }
debugView s = do
  let get name = launchAff_ do
         view <- AVar.tryReadVar s.view
         liftEff case view of
           Nothing -> do
             log "CoordSysView state empty"
             setWindow name unit
           Just (v :: _)  -> do
             log $ "CoordSysView: " <> showView v
             setWindow name $ unwrap v ^. _PairRec

  let set lr = launchAff_ do
         view <- AVar.tryTakeVar s.view
         case view of
           Nothing -> pure unit
           Just _  -> do
             let v' = wrap $ lr ^. re _PairRec
             _ <- AVar.tryPutVar (inj _render unit) s.uiCmd
             AVar.putVar v' s.view

  pure {get, set}

uiViewUpdate :: ∀ r.
                CoordSys _ BigInt
             -> Milliseconds
             -> { view :: AVar CoordSysView
                , viewCmd :: AVar UpdateView
                , uiCmd :: AVar (Variant UICmdR) | r }
                -- , viewReady :: AVar Unit | r }
             -> Aff _ Unit
uiViewUpdate cs timeout { view, viewCmd, uiCmd } = do
  curCmdVar <- makeVar (ModView id)

  let normView = normalizeView cs (BigInt.fromInt 200000)
      loop' updater = do
        cmd <- takeVar viewCmd

        killFiber (error "Resetting view update") updater
        liftEff $ log $ "forking view update"

        curCmd <- takeVar curCmdVar
        let cmd' = curCmd <> cmd
        putVar cmd' curCmdVar

        updater' <- forkAff do
            delay timeout
            liftEff $ log "Running view update"
            vr <- takeVar view

            let vr' = normView $ updateViewFold cmd' vr

            putVar vr' view

            putVar (inj _render unit) uiCmd
            takeVar curCmdVar *> putVar mempty curCmdVar

        loop' updater'

  loop' (pure unit)

                         -- This is Star (Aff e) a b!
-- newtype AffCache e a b = AffCache (a -> Aff e b)

affCacheStar :: ∀ e a b.
                (a -> a -> Boolean)
             -> (a -> b)
             -> Aff _ (Star (Aff _) a b)
affCacheStar diff f = do
  inVar  <- AVar.makeEmptyVar
  outVar <- AVar.makeEmptyVar

  let cache = \a -> do
        lastIn  <- AVar.tryTakeVar inVar
        lastOut <- AVar.tryTakeVar outVar
        let o = case lastIn, lastOut of
                  Just i, Just o -> if diff a i then f a else o
                  _, _ -> f a

        AVar.putVar a inVar
        AVar.putVar o outVar
        pure o

  pure $ Star cache

cachedStar :: ∀ a b. Star (Aff _) a b -> a -> Aff _ b
cachedStar = unwrap

-- newtype AffCache a b =
--   AffCache { diff :: a -> a -> Boolean
--            , cache :: ∀ e. a -> Aff (avar :: AVAR | e) b }

newtype AffCache e a b =
  AffCache { diff :: a -> a -> Boolean
           , cache :: a -> Aff e b }

derive instance newtypeAffCache :: Newtype (AffCache e a b) _
derive instance genericAffCache :: Generic (AffCache e a b) _

derive instance functorAffCache :: Functor (AffCache e a)

cacheFun :: ∀ e a b.
            (a -> a -> Boolean)
         -> (a -> b)
         -> Aff _ (AffCache _ a b)
cacheFun diff f = do
  inVar  <- AVar.makeEmptyVar
  outVar <- AVar.makeEmptyVar

  let cache = \a -> do
        lastIn  <- AVar.tryTakeVar inVar
        lastOut <- AVar.tryTakeVar outVar
        let o = case lastIn, lastOut of
                  Just i, Just o -> if diff a i then f a else o
                  _, _ -> f a

        AVar.putVar a inVar
        AVar.putVar o outVar
        pure o

  pure $ AffCache { diff, cache }

cached :: ∀ a b.
          AffCache _ a b
       -> a -> Aff _ b
cached = _.cache <<< unwrap

browserCache
  :: ∀ a b.
     (BrowserCanvas
      -> CoordSysView
      -> { tracks :: { gwas :: a
                     , annotations :: b }
         , relativeUI :: Drawing
         , fixedUI :: Drawing })
     -> Aff _ (BrowserCanvas
               -> Aff _ (CoordSysView
                         -> { tracks     :: { gwas :: a
                                            , annotations :: b }
                            , relativeUI :: Drawing
                            , fixedUI :: Drawing }))
browserCache f = do
  bcDim <- AVar.makeEmptyVar
  lastOut <- AVar.makeEmptyVar

  pure \bc -> do
    let newBCDim = bc ^. _Dimensions
    oldBCDim <- AVar.tryTakeVar bcDim
    AVar.putVar newBCDim bcDim

    oldOut <- AVar.tryTakeVar lastOut

    out' <- case oldBCDim, oldOut of
      Just d, Just o -> do
        let changed = not $ d `eqRecord` newBCDim
        liftEff $ log $ "Cache changed? " <> (show changed)
        pure $ if d `eqRecord` newBCDim then o else f bc

      _, _ -> do
        liftEff $ log "Cache was empty! Recalculating"
        pure $ f bc

    AVar.putVar out' lastOut
    pure out'

renderLoop :: CoordSys _ _
           -> (BrowserCanvas
               -> Aff _ (CoordSysView
                         -> { tracks     :: { gwas :: RenderedTrack (GWASFeature ())
                                            , annotations :: RenderedTrack (Annot (score :: Number)) }
                            , relativeUI :: Drawing
                            , fixedUI :: Drawing }))
           -> BrowserCanvas
           -> UIState _
           -> Aff _ Unit
renderLoop cSys drawCachedBrowser canvas state = forever do

  uiCmd <- takeVar state.uiCmd
  case_ # on _render (\_ -> pure unit)
        # on _docResize (\ {width} -> do
                let {height} = canvas ^. _Dimensions
                canvas' <- liftEff $ setBrowserCanvasSize {width, height} canvas
                putVar (inj _render unit) state.uiCmd
                renderLoop cSys drawCachedBrowser canvas' state)
        $ uiCmd

  -- if there's a rendering fiber running, we kill it
  traverse_ (killFiber (error "Resetting renderer"))
    =<< tryTakeVar state.renderFiber

  {-
  -- if the view scale is unchanged, use the cached glyphs
  tracks' <- do
    cache <- AVar.tryTakeVar state.cachedTracks
    case cache of
      Just ct
        | ct.cachedViewWidth == viewWidth -> do
            AVar.putVar ct state.cachedTracks
            pure ct.glyphs
      _ -> do
        let cachedViewWidth = viewWidth
            glyphs = browser.tracks csView

        AVar.putVar {cachedScale, glyphs} state.cachedTracks
        pure glyphs
  -}

  -- fork a new renderFiber

  csView <- readVar state.view

  toRender <- (_ $ csView) <$> drawCachedBrowser canvas

  let currentScale = viewScale (canvas ^. _Track <<< _Dimensions) csView
      (Pair offset _) = pixelsView currentScale csView

  _ <- AVar.tryTakeVar state.lastOverlaps
                    -- offset the click by the current canvas translation
  AVar.putVar (\n r -> let r' = {x: r.x + offset, y: r.y }
                       in { gwas: toRender.tracks.gwas.overlaps n r' }) state.lastOverlaps

  renderFiber <- forkAff
                 $ renderBrowser (wrap 2.0) canvas offset toRender

  putVar renderFiber state.renderFiber

printSNPInfo :: ∀ r. Array (GWASFeature r) -> Eff _ Unit
printSNPInfo fs = do
  let n = length fs :: Int
      m = 5

      showSnp f = do
        log $ f.feature.name <> " - "
           <> unwrap f.feature.chrId <> " @ "
           <> show (map show f.position)

  log $ "showing " <> show n <> " clicked glyphs"
  for_ (Array.take m fs) showSnp

snpInfoHTML :: ∀ r. GWASFeature r -> String
snpInfoHTML { position, feature } =
    "
SNP: "   <> feature.name <> "
"
 <> "
Chr: "   <> show feature.chrId <> "
"
 <> "
Pos: "   <> show (Pair.fst position) <> "
"
 <> "
Score: " <> show feature.score <> "
"
 <> "
-log10: " <> show (negLog10 feature.score) <> "
"

snpInfoHTML' :: ∀ rA rS.
                (GWASFeature rS -> Maybe (Annot (score :: Number | rA)))
             -> GWASFeature rS
             -> String
snpInfoHTML' assocAnnot snp =
   snpInfoHTML snp <> case assocAnnot snp of
     Nothing -> "
No annotation found
"
     Just a  -> "
Annotation: " <> show a.feature.name <> "
"
             <> "
Annot. score: " <> show a.feature.score <> "
"
             <> "
Annot. -log10: " <> show (negLog10 a.feature.score) <> "
"

annotForSnp :: ∀ rA rS.
               Bp
            -> Map ChrId (Array (Annot rA))
            -> GWASFeature rS
            -> Maybe (Annot rA)
annotForSnp radius annotations {position, feature} = do
  chr <- Map.lookup feature.chrId annotations
  Array.find (\a -> ((radius `aroundPair` a.position) `pairsOverlap` position)) chr

foreign import setInfoBoxVisibility :: ∀ e. String -> Eff e Unit
foreign import setInfoBoxContents :: ∀ e. String -> Eff e Unit

foreign import initDebugDiv :: ∀ e. Number -> Eff e Unit

foreign import setDebugDivVisibility :: ∀ e. String -> Eff e Unit

foreign import setDebugDivPoint :: ∀ e. Point -> Eff e Unit

-- TODO configure UI widths
runBrowser :: Conf -> BrowserCanvas -> Eff _ _
runBrowser config bc = launchAff $ do

  let clickRadius = 1.0

  liftEff $ initDebugDiv clickRadius

  let cSys :: CoordSys ChrId BigInt
      cSys = coordSys mouseChrSizes

      bumpRadius = Bp 50000000.0

  trackData <- do
    genes <- traverse (getGenes cSys) config.urls.genes
    gwas  <- traverse (getGWAS  cSys) config.urls.gwas

    rawAnnotations <-
      traverse (uncurry $ getAnnotations' cSys) do
        snps <- filterSig config.score <$> gwas
        url <- config.urls.annotations
        pure $ Tuple snps url

    let annotations = zipMapsWith
                       (bumpFeatures (to _.feature.score)
                                      (SProxy :: SProxy "score")
                                      bumpRadius)
                       <$> gwas <*> rawAnnotations

    pure { genes, gwas, annotations }

  let initialView :: CoordSysView
      initialView = wrap $ Pair zero (cSys^._TotalSize)
      trackDims = bc ^. _Track <<< _Dimensions

  viewCmd <- makeEmptyVar

  liftEff do
    btnScroll 0.05 viewCmd
    btnZoom   0.10 viewCmd

    let dragCB {x,y} =
          when (Math.abs x >= one)
          $ queueCmd viewCmd $ ScrollView $ (-x) / trackDims.width
    dragScroll bc dragCB

    let scrollZoomScale = 0.06
        wheelCB dY =
          queueCmd viewCmd $ ZoomView $ 1.0 + scrollZoomScale * dY
    wheelZoom bc wheelCB

  uiCmd <- makeVar (inj _render unit)

  liftEff do
    resizeEvent \d ->
      queueCmd uiCmd (inj _docResize d)

  view <- makeVar initialView
  renderFiber <- makeEmptyVar
  lastOverlaps <- AVar.makeEmptyVar

  let initState :: UIState _
      initState = { view, viewCmd, uiCmd, renderFiber, lastOverlaps }

  let
      slots = uiSlots bc

      entries = foldMap annotLegendTest trackData.annotations
      legend = { width: slots.right.size.width
               , entries }

      s = config.score

      vscale = { width: slots.left.size.width
               , color: black
               , min: s.min, max: s.max, sig: s.sig }

      padding = { horizontal: config.trackPadding.left
                , vertical: config.trackPadding.top }

      mainBrowser :: _
      mainBrowser = drawBrowser cSys {legend, vscale}
                      { gwas: renderGWAS vscale
                      , annotations: renderAnnot vscale }
                      { gwas: fromMaybe mempty trackData.gwas
                      , annotations: fromMaybe mempty trackData.annotations }

      viewTimeout :: Milliseconds
      viewTimeout = wrap 100.0

  liftEff do
    setWindow "mainBrowser" mainBrowser

    let findAnnot = annotForSnp bumpRadius $ fromMaybe mempty trackData.annotations

    let glyphClick :: _
        glyphClick p = launchAff_ do
          AVar.tryReadVar lastOverlaps >>= case _ of
             Nothing -> liftEff do
               log "clicked no glyphs"
               setInfoBoxVisibility "hidden"

             Just gs -> liftEff do
               let clicked = (gs clickRadius p).gwas
               printSNPInfo clicked
               case Array.head clicked of
                 Nothing -> setInfoBoxVisibility "hidden"
                 Just g  -> do
                   setInfoBoxContents $ snpInfoHTML' findAnnot g
                   setInfoBoxVisibility "visible"

    let overlayDebug :: _
        overlayDebug p = do

          setDebugDivVisibility "visible"
          setDebugDivPoint p

    browserOnClick bc
      { overlay: \_ -> pure unit
      , track:   glyphClick }

  _ <- forkAff $ uiViewUpdate cSys viewTimeout initState

  cached <- browserCache mainBrowser

  _ <- forkAff $ renderLoop cSys cached bc initState

  pure unit

type DataURLs = { gwas        :: Maybe String
                , annotations :: Maybe String
                , genes       :: Maybe String
                }

type Conf = { browserHeight :: Number
            , trackPadding :: TrackPadding
            , score :: { min :: Number, max :: Number, sig :: Number }
            , urls :: DataURLs
            }

foreign import setWindow :: ∀ e a. String -> a -> Eff e Unit

initBrowser :: Foreign -> Eff _ _
initBrowser rawConfig = do

  el' <- do
    doc <- DOM.htmlDocumentToDocument
           <$> (DOM.document =<< DOM.window)
    DOM.querySelector (wrap "#browser") (toParentNode doc)

  case read rawConfig :: Either MultipleErrors Conf of
    Left errs -> traverse_ (log <<< renderForeignError) errs
    Right c   -> do
      case el' of
        Nothing -> log "Could not find element '#browser'"
        Just el -> do

          {width} <- windowInnerSize
          let dimensions = { width, height: c.browserHeight }
          bc <- browserCanvas dimensions c.trackPadding el

          debugBrowserCanvas "debugBC" bc

          log $ unsafeStringify c
          void $ runBrowser c bc

-- TODO this could almost certainly be done better
chunkConsumer :: ∀ m a.
                 Foldable m
              => Monoid (m a)
              => AVar (m a)
              -> Consumer (m a) (Aff _) Unit
chunkConsumer av = Co.consumer \m ->
  if null m
     then pure $ Just unit
     else do
       sofar <- takeVar av
       putVar (sofar <> m) av
       delay (wrap 20.0)
       pure Nothing

type TrackVar a = AVar (Map ChrId (Array a))
type TrackProducer eff a = Producer (Map ChrId (Array a)) (Aff eff) Unit

-- Feels like this one takes care of a bit too much...
fetchLoop1 :: ∀ a.
              (Maybe (Aff _ (TrackProducer _ a)))
           -> Aff _ (TrackVar a)
fetchLoop1 Nothing = AVar.makeEmptyVar
fetchLoop1 (Just startProd) = do
  prod <- startProd
  avar <- makeVar mempty
  _ <- forkAff $ runProcess $ prod `connect` chunkConsumer avar
  pure avar

-- | Starts threads that fetch & parse each of the provided tracks,
-- | filling an AVar over time per track, which can be used by other parts of the application
-- | (read only, should be a newtype)
fetchLoop :: CoordSys ChrId BigInt
          -> DataURLs
          -> Aff _
               { gwas :: TrackVar (GWASFeature ())
               , genes :: TrackVar BedFeature
               , annotations :: TrackVar (Annot ())
               }
fetchLoop cs urls = do
  gwas <-        fetchLoop1 $ produceGWAS   cs <$> urls.gwas
  annotations <- fetchLoop1 $ produceAnnots cs <$> urls.annotations
  genes <-       fetchLoop1 $ produceGenes  cs <$> urls.genes
  pure { gwas, genes, annotations }


Added encode instances

Added encode instances

module OIDCCryptUtils.JSONWebKey (JSONWebKey()) where

import Prelude (pure, (<<<))
import Data.Argonaut.Core as JS
import Data.Argonaut.Decode as JSD
import Data.Argonaut.Encode as JSE

newtype JSONWebKey = JSONWebKey JS.Json

instance decodeJsonJSONWebKey :: JSD.DecodeJson JSONWebKey where
  decodeJson = pure <<< JSONWebKey

instance encodeJsonJSONWebKey :: JSE.EncodeJson JSONWebKey where
  encodeJson (JSONWebKey json) = JSE.encodeJson json

module OIDCCryptUtils.JSONWebKey (JSONWebKey()) where

import Prelude (pure, (<<<))
import Data.Argonaut.Core as JS
import Data.Argonaut.Decode as JSD

newtype JSONWebKey = JSONWebKey JS.Json

instance decodeJsonJSONWebKey :: JSD.DecodeJson JSONWebKey where
  decodeJson = pure <<< JSONWebKey


Add trivial shortcuts

Add trivial shortcuts

module Pux.Routing.Bob.Component where

import Prelude
import Pux.Routing.Bob as Pux.Routing.Bob
import Control.Monad.Eff (Eff)
import DOM (DOM)
import Data.Bifunctor (class Bifunctor)
import Data.Bifunctor.Clown (Clown(Clown), runClown)
import Data.Generic (class Generic)
import Data.Identity (Identity(Identity), runIdentity)
import Pux (EffModel)
import Pux.Html (Attribute, Html)
import Pux.Routing.Bob (RoutingAction(RouteRequest))
import Routing.Bob (Router)
import Signal (Signal)

data Action route action
  = RoutingAction (RoutingAction route)
  | RawAction action

-- shortcuts for views
routeRequest :: forall route action. route -> Action route action
routeRequest = RoutingAction <<< RouteRequest

action :: forall route action. action -> Action route action
action = RawAction

instance bifunctorAction :: Bifunctor Action where
  bimap f _ (RoutingAction r) = RoutingAction (f <$> r)
  bimap _ g (RawAction a) = RawAction (g a)

-- | I know that this type is a bit complicated. Here is why:
-- |
-- | * we need to call `toAbsoluteUrl router route` in views to produce links href values,
-- |
-- | * we want to change this value from parent component, as it should capture
-- |   other parts of application url
-- |
-- | * we have to postpone this evaluation and allow to map it's arguments
-- |
-- | I've decided to add callback argument which operates on `Bifunctor b`
-- | to allow whole action (`Action route action`) mapping and single
-- | `route` value mapping too inside `view`.
type View state route action =
    forall route' action'. (Generic route') =>
    Router route' ->
    (forall b. (Bifunctor b) => b route action -> b route' action') ->
    state ->
    Html (Action route' action')

-- | Little helper which allows mapping over naked `route` value
-- | with function over `(Bifunctor b) => b route action`.
mapRoute :: forall action action' route route'.
            (forall b. (Bifunctor b) => b route action -> b route' action') ->
            route ->
            route'
mapRoute k = runIdentity <<< runClown <<< k <<< Clown <<< Identity

link :: forall action route. (Generic route) =>
        Router route ->
        route ->
        Array (Attribute (Action route action)) ->
        Array (Html (Action route action)) ->
        Html (Action route action)
link router route attrs children =
  Pux.Routing.Bob.link router RoutingAction route attrs children

link' :: forall action action' route route'. (Generic route') =>
         (forall b. (Bifunctor b) => (b route action -> b route' action')) ->
         Router route' ->
         route ->
         Array (Attribute (Action route' action')) ->
         Array (Html (Action route' action')) ->
         Html (Action route' action')
link' mapAction router route =
  link router (mapRoute mapAction route)

-- | Shortcut which wraps result of base `update` function
-- | (which operates on `Pux.Routing.Bob.RoutingAction r` values)
-- | into final `Action r a` value.
update :: forall action eff route state. (Generic route) =>
          Router route ->
          (RoutingAction route) ->
          state ->
          EffModel state (Action route action) (dom :: DOM | eff)
update router action' state =
  let r = Pux.Routing.Bob.update router action' state
  in  r { effects = (RoutingAction <$> _) <$> r.effects }

-- | Ready to use signal which should be added to your app config `inputs`
sampleUrl :: forall action eff route. Eff ( dom :: DOM | eff ) (Signal (Action action route))
sampleUrl = Pux.Routing.Bob.sampleUrl' RoutingAction

module Pux.Routing.Bob.Component where

import Prelude
import Pux.Routing.Bob as Pux.Routing.Bob
import Control.Monad.Eff (Eff)
import DOM (DOM)
import Data.Bifunctor (class Bifunctor)
import Data.Bifunctor.Clown (Clown(Clown), runClown)
import Data.Generic (class Generic)
import Data.Identity (Identity(Identity), runIdentity)
import Pux (EffModel)
import Pux.Html (Attribute, Html)
import Pux.Routing.Bob (RoutingAction)
import Routing.Bob (Router)
import Signal (Signal)

data Action route action
  = RoutingAction (RoutingAction route)
  | RawAction action

instance bifunctorAction :: Bifunctor Action where
  bimap f _ (RoutingAction r) = RoutingAction (f <$> r)
  bimap _ g (RawAction a) = RawAction (g a)

-- | I know that this type is a bit complicated. Here is why:
-- |
-- | * we need to call `toAbsoluteUrl router route` in views to produce links href values,
-- |
-- | * we want to change this value from parent component, as it should capture
-- |   other parts of application url
-- |
-- | * we have to postpone this evaluation and allow to map it's arguments
-- |
-- | I've decided to add callback argument which operates on `Bifunctor b`
-- | to allow whole action (`Action route action`) mapping and single
-- | `route` value mapping too inside `view`.
type View state route action =
    forall route' action'. (Generic route') =>
    Router route' ->
    (forall b. (Bifunctor b) => b route action -> b route' action') ->
    state ->
    Html (Action route' action')

-- | Little helper which allows mapping over naked `route` value
-- | with function over `(Bifunctor b) => b route action`.
mapRoute :: forall action action' route route'.
            (forall b. (Bifunctor b) => b route action -> b route' action') ->
            route ->
            route'
mapRoute k = runIdentity <<< runClown <<< k <<< Clown <<< Identity

link :: forall action route. (Generic route) =>
        Router route ->
        route ->
        Array (Attribute (Action route action)) ->
        Array (Html (Action route action)) ->
        Html (Action route action)
link router route attrs children =
  Pux.Routing.Bob.link router RoutingAction route attrs children

link' :: forall action action' route route'. (Generic route') =>
         (forall b. (Bifunctor b) => (b route action -> b route' action')) ->
         Router route' ->
         route ->
         Array (Attribute (Action route' action')) ->
         Array (Html (Action route' action')) ->
         Html (Action route' action')
link' mapAction router route =
  link router (mapRoute mapAction route)

-- | Shortcut which wraps result of base `update` function
-- | (which operates on `Pux.Routing.Bob.RoutingAction r` values)
-- | into final `Action r a` value.
update :: forall action eff route state. (Generic route) =>
          Router route ->
          (RoutingAction route) ->
          state ->
          EffModel state (Action route action) (dom :: DOM | eff)
update router action state =
  let r = Pux.Routing.Bob.update router action state
  in  r { effects = (RoutingAction <$> _) <$> r.effects }

-- | Ready to use signal which should be added to your app config `inputs`
sampleUrl :: forall action eff route. Eff ( dom :: DOM | eff ) (Signal (Action action route))
sampleUrl = Pux.Routing.Bob.sampleUrl' RoutingAction