Fix: Replace function arguments in application

module Evaluator
  ( Path(..)
  , Env()
  , evalPath1
  , defsToEnv
  ) where

import Data.Array    (head, mapMaybe, (!!), updateAt)
import Data.StrMap   (StrMap(), empty, lookup, insert)
import Data.Tuple
import Data.Maybe
import Data.Foldable (foldl)

import Control.Apply ((*>))
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Trans

import AST

data Path = Start Path | Nth Number Path | Fst Path | Snd Path | End

select :: Path -> (Expr -> Maybe Expr) -> Expr -> Maybe Expr
select (Start p) eval expr = select p eval expr
select End       eval expr = eval expr

select (Fst p) eval expr = case expr of
  Binary op e1 e2 -> Binary op <$> (select p eval e1) <*> Just e2
  Unary op e      -> Unary op <$> select p eval e
  SectL e op      -> SectL <$> (select p eval e) <*> Just op
  SectR op e      -> SectR op <$> (select p eval) e
  App e es        -> App <$> (select p eval e) <*> Just es
  _               -> Nothing
select (Snd p) eval expr = case expr of
  Binary op e1 e2 -> Binary op e1 <$> select p eval e2
  _               -> Nothing
select (Nth n p) eval expr = case expr of
  List es  -> List <$> mapMIndex n (select p eval) es
  App e es -> App e <$> mapMIndex n (select p eval) es
  _        -> Nothing

mapMIndex :: forall m a. Number -> (a -> Maybe a) -> [a] -> Maybe [a]
mapMIndex i f as = do
  a <- (as !! i) >>= f
  return $ updateAt i a as

evalPath1 :: Env -> Path -> Expr -> Maybe Expr
evalPath1 env path expr = select path (eval1 env) expr

type Env = StrMap [Tuple [Binding] Expr]

defsToEnv :: [Definition] -> Env
defsToEnv = foldl insertDef empty

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case lookup name env of
  Nothing   -> insert name [Tuple bindings body] env
  Just defs -> insert name (defs ++ [Tuple bindings body]) env

eval1 :: Env -> Expr -> Maybe Expr
eval1 env expr = case expr of
  (Binary op e1 e2)             -> binary op e1 e2
  (Unary op e)                  -> unary op e
  (App (SectL e1 op) [e2])      -> binary op e1 e2
  (App (SectR op e2) [e1])      -> binary op e1 e2
  (App (Atom (Name name)) args) -> apply env name args
  _                 -> Nothing

binary :: Op -> Expr -> Expr -> Maybe Expr
binary = go
  where
  go Add (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i + j
  go Sub (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i - j
  go Mul (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i * j
  go Div (Atom (Num i)) (Atom (Num 0)) = Nothing
  go Div (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ Math.floor (i / j)

  go And (Atom (Bool true))  b = Just b
  go And (Atom (Bool false)) _ = Just $ Atom $ Bool $ false
  go Or  (Atom (Bool true))  _ = Just $ Atom $ Bool $ true
  go Or  (Atom (Bool false)) b = Just b

  go Cons   e          (List es)  = Just $ List $ e:es
  go Append (List es1) (List es2) = Just $ List $ es1 ++ es2

  go _       _               _               = Nothing

unary :: Op -> Expr -> Maybe Expr
unary Sub (Atom (Num i)) = Just $ Atom $ Num (-i)
unary _   _              = Nothing

apply :: Env -> String -> [Expr] -> Maybe Expr
apply env name args = case lookup name env of
  Nothing    -> Nothing
  Just cases -> head $ mapMaybe app cases
    where
    app :: Tuple [Binding] Expr -> Maybe Expr
    app (Tuple binds body) = matchls binds args body

matchls :: [Binding] -> [Expr] -> Expr -> Maybe Expr
matchls []     []     expr = Just expr
matchls (b:bs) (e:es) expr = do
  expr' <- execStateT (match b e) expr
  matchls bs es expr'
matchls _ _ _ = Nothing

match :: Binding -> Expr -> StateT Expr Maybe Unit
match (Lit (Name x))   e                = modify (replace x e)
match (Lit (Num i))    (Atom (Num j))   | i == j  = return unit
match (Lit (Bool b))   (Atom (Bool b')) | b == b' = return unit
match (ConsLit b bs)   (List (e:es))    = match b e *> match bs (List es)
match (ListLit [])     (List [])        = return unit
match (ListLit (b:bs)) (List (e:es))    = match b e *> match (ListLit bs) (List es)
match _                _                = lift Nothing

replace :: String -> Expr -> Expr -> Expr
replace name value = go
  where
  go expr = case expr of
    a@(Atom (Name str)) -> if str == name then value else a
    (List exprs)        -> List (go <$> exprs)
    (Binary op e1 e2)   -> Binary op (go e1) (go e2)
    (Unary op e)        -> Unary op (go e)
    (SectL e op)        -> SectL (go e) op
    (SectR op e)        -> SectR op (go e)
    (App func exprs)    -> App (go func) (go <$> exprs)
    e                   -> e

module Evaluator
  ( Path(..)
  , Env()
  , evalPath1
  , defsToEnv
  ) where

import Data.Array    (head, mapMaybe, (!!), updateAt)
import Data.StrMap   (StrMap(), empty, lookup, insert)
import Data.Tuple
import Data.Maybe
import Data.Foldable (foldl)

import Control.Apply ((*>))
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Trans

import AST

data Path = Start Path | Nth Number Path | Fst Path | Snd Path | End

select :: Path -> (Expr -> Maybe Expr) -> Expr -> Maybe Expr
select (Start p) eval expr = select p eval expr
select End       eval expr = eval expr

select (Fst p) eval expr = case expr of
  Binary op e1 e2 -> Binary op <$> (select p eval e1) <*> Just e2
  Unary op e      -> Unary op <$> select p eval e
  SectL e op      -> SectL <$> (select p eval e) <*> Just op
  SectR op e      -> SectR op <$> (select p eval) e
  App e es        -> App <$> (select p eval e) <*> Just es
  _               -> Nothing
select (Snd p) eval expr = case expr of
  Binary op e1 e2 -> Binary op e1 <$> select p eval e2
  _               -> Nothing
select (Nth n p) eval expr = case expr of
  List es  -> List <$> mapMIndex n (select p eval) es
  App e es -> App e <$> mapMIndex n (select p eval) es
  _        -> Nothing

mapMIndex :: forall m a. Number -> (a -> Maybe a) -> [a] -> Maybe [a]
mapMIndex i f as = do
  a <- (as !! i) >>= f
  return $ updateAt i a as

evalPath1 :: Env -> Path -> Expr -> Maybe Expr
evalPath1 env path expr = select path (eval1 env) expr

type Env = StrMap [Tuple [Binding] Expr]

defsToEnv :: [Definition] -> Env
defsToEnv = foldl insertDef empty

insertDef :: Env -> Definition -> Env
insertDef env (Def name bindings body) = case lookup name env of
  Nothing   -> insert name [Tuple bindings body] env
  Just defs -> insert name (defs ++ [Tuple bindings body]) env

eval1 :: Env -> Expr -> Maybe Expr
eval1 env expr = case expr of
  (Binary op e1 e2)             -> binary op e1 e2
  (Unary op e)                  -> unary op e
  (App (SectL e1 op) [e2])      -> binary op e1 e2
  (App (SectR op e2) [e1])      -> binary op e1 e2
  (App (Atom (Name name)) args) -> apply env name args
  _                 -> Nothing

binary :: Op -> Expr -> Expr -> Maybe Expr
binary = go
  where
  go Add (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i + j
  go Sub (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i - j
  go Mul (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ i * j
  go Div (Atom (Num i)) (Atom (Num 0)) = Nothing
  go Div (Atom (Num i)) (Atom (Num j)) = Just $ Atom $ Num $ Math.floor (i / j)

  go And (Atom (Bool true))  b = Just b
  go And (Atom (Bool false)) _ = Just $ Atom $ Bool $ false
  go Or  (Atom (Bool true))  _ = Just $ Atom $ Bool $ true
  go Or  (Atom (Bool false)) b = Just b

  go Cons   e          (List es)  = Just $ List $ e:es
  go Append (List es1) (List es2) = Just $ List $ es1 ++ es2

  go _       _               _               = Nothing

unary :: Op -> Expr -> Maybe Expr
unary Sub (Atom (Num i)) = Just $ Atom $ Num (-i)
unary _   _              = Nothing

apply :: Env -> String -> [Expr] -> Maybe Expr
apply env name args = case lookup name env of
  Nothing    -> Nothing
  Just cases -> head $ mapMaybe app cases
    where
    app :: Tuple [Binding] Expr -> Maybe Expr
    app (Tuple binds body) = matchls binds args body

matchls :: [Binding] -> [Expr] -> Expr -> Maybe Expr
matchls []     []     expr = Just expr
matchls (b:bs) (e:es) expr = do
  expr' <- execStateT (match b e) expr
  matchls bs es expr'
matchls _ _ _ = Nothing

match :: Binding -> Expr -> StateT Expr Maybe Unit
match (Lit (Name x))   e                = modify (replace x e)
match (Lit (Num i))    (Atom (Num j))   | i == j  = return unit
match (Lit (Bool b))   (Atom (Bool b')) | b == b' = return unit
match (ConsLit b bs)   (List (e:es))    = match b e *> match bs (List es)
match (ListLit [])     (List [])        = return unit
match (ListLit (b:bs)) (List (e:es))    = match b e *> match (ListLit bs) (List es)
match _                _                = lift Nothing

replace :: String -> Expr -> Expr -> Expr
replace name value = go
  where
  go expr = case expr of
    a@(Atom (Name str)) -> if str == name then value else a
    (List exprs)        -> List (go <$> exprs)
    (Binary op e1 e2)   -> Binary op (go e1) (go e2)
    (Unary op e)        -> Unary op (go e)
    (SectL e op)        -> SectL (go e) op
    (SectR op e)        -> SectR op (go e)
    (App appName exprs) -> App appName (go <$> exprs)
    e                   -> e


Add pursIde info for typed hole errors

Add pursIde info for typed hole errors

module PscIde.Command where

import Prelude
import Control.Alt ((<|>))
import Data.Argonaut (JObject, getField)
import Data.Argonaut.Core (jsonEmptyObject, jsonSingletonObject, jsonNull, Json, toString)
import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.?))
import Data.Argonaut.Encode (class EncodeJson, encodeJson, (~>), (:=))
import Data.Argonaut.Parser (jsonParser)
import Data.Array (singleton)
import Data.Either (either, Either(..))
import Data.Maybe (Maybe(..), maybe)
import Data.String (joinWith)

data PursuitType = Package | Ident

instance showPursuitType :: Show PursuitType where
  show Package = "package"
  show Ident   = "completion"

instance encodePursuitType :: EncodeJson PursuitType where
  encodeJson = encodeJson <<< show

data Matcher =
  Flex String
  | Distance String Int

instance encodeMatcher :: EncodeJson Matcher where
  encodeJson (Flex q) =
    "matcher" := "flex"
    ~> "params" := (jsonSingletonObject' "search" q)
    ~> jsonEmptyObject
  encodeJson (Distance q maxDist) =
    "matcher" := "distance"
    ~> "params" := (
       "search" := q
       ~> "maximumDistance" := maxDist
       ~> jsonEmptyObject
      )
    ~> jsonEmptyObject

data Filter =
  ExactFilter String
  | PrefixFilter String
  | ModuleFilter (Array String)
  | DependencyFilter (Array String)

filterWrapper :: forall a. (EncodeJson a) => String -> a -> Json
filterWrapper f q =
  "filter" := f
  ~> ("params" := q)
  ~> jsonEmptyObject

jsonSingletonObject' :: forall a. (EncodeJson a) => String -> a -> Json
jsonSingletonObject' s o = jsonSingletonObject s (encodeJson o)

instance encodeFilter :: EncodeJson Filter where
  encodeJson (ExactFilter q) =
    filterWrapper "exact" (jsonSingletonObject' "search" q)
  encodeJson (PrefixFilter q) =
    filterWrapper "prefix" (jsonSingletonObject' "search" q)
  encodeJson (ModuleFilter modules) =
    filterWrapper "modules" (jsonSingletonObject' "modules" modules)
  encodeJson (DependencyFilter deps) =
    filterWrapper "dependencies" (jsonSingletonObject' "modules" deps)

newtype CompletionOptions = CompletionOptions {
  maxResults :: Maybe Int,
  groupReexports :: Boolean
}

instance encodeCompletionOptions :: EncodeJson CompletionOptions where
  encodeJson (CompletionOptions { maxResults, groupReexports }) =
   "maxResults" := encodeMaybeNull maxResults
    ~> "groupReexports" := encodeJson groupReexports
    ~> jsonEmptyObject

data Command =
  Cwd
  | Ls ListType
  | Quit
  | Reset
  | Load (Array String) (Array String)
  | Complete (Array Filter) (Maybe Matcher) (Maybe String) CompletionOptions
  | Pursuit PursuitType String
  | Type String (Array Filter) (Maybe String)
  | AddClause String Boolean
  | CaseSplit String Int Int Boolean String
  | ImportCmd FileName (Maybe FileName) (Array Filter) ImportCommand
  | RebuildCmd String (Maybe FileName)

data ListType = LoadedModules | Imports String | AvailableModules

type FileName = String
data ImportCommand = AddImplicitImport String | AddQualifiedImport String String | AddImport String (Maybe String)

commandWrapper :: forall a. (EncodeJson a) => String -> a -> Json
commandWrapper s o =
  "command" := s
  ~> ("params" := o)
  ~> jsonEmptyObject

instance encodeCommand :: EncodeJson Command where
  encodeJson Cwd = jsonSingletonObject' "command" "cwd"
  encodeJson (Ls LoadedModules) =
    commandWrapper "list" ("type" := "loadedModules" ~> jsonEmptyObject)
  encodeJson (Ls AvailableModules) =
    commandWrapper "list" ("type" := "availableModules" ~> jsonEmptyObject)
  encodeJson (Ls (Imports fp)) =
    commandWrapper "list" ("type" := "import" ~> "file" := fp ~> jsonEmptyObject)
  encodeJson Quit = jsonSingletonObject' "command" "quit"
  encodeJson Reset = jsonSingletonObject' "command" "reset"
  encodeJson (Load modules dependencies) =
    commandWrapper "load" (
      "modules" := (encodeJson modules)
      ~> "dependencies" := (encodeJson dependencies)
      ~> jsonEmptyObject
      )
  encodeJson (Complete filters matcher currentModule options) =
    commandWrapper "complete" (
      "filters" := (encodeJson filters)
      ~> "matcher" := (encodeMaybeNull matcher)
      ~> "currentModule" := (encodeMaybeNull currentModule)
      ~> "options" := (encodeJson options)
      ~> jsonEmptyObject
      )
  encodeJson (Pursuit psType q) =
    commandWrapper "pursuit" (
        "type" := (encodeJson psType)
        ~> "query" := q
        ~> jsonEmptyObject
      )
  encodeJson (Type text filters currentModule) =
    commandWrapper "type" (
        "search" := encodeJson text
        ~> "filters" := (encodeJson filters)
        ~> "currentModule" := (encodeMaybeNull currentModule)
        ~> jsonEmptyObject
      )
  encodeJson (AddClause line annotations) =
    commandWrapper "addClause" (
        "line" := encodeJson line
        ~> "annotations" := encodeJson annotations
        ~> jsonEmptyObject
      )
  encodeJson (CaseSplit line begin end annotations typ) =
    commandWrapper "caseSplit" (
        "line" := encodeJson line
        ~> "begin" := encodeJson begin
        ~> "end" := encodeJson end
        ~> "annotations" := encodeJson annotations
        ~> "type" := encodeJson typ
        ~> jsonEmptyObject
      )
  encodeJson (ImportCmd inFile outFile filters cmd) =
    commandWrapper "import" (
      "file" := encodeJson inFile
      ~> "outfile" := encodeMaybeNull outFile
      ~> "filters" := encodeJson filters
      ~> "importCommand" := encodeJson cmd
      ~> jsonEmptyObject
      )
  encodeJson (RebuildCmd file actualFile) =
    commandWrapper "rebuild" (
      "file" := encodeJson file
      ~> "actualFile" := encodeMaybeNull actualFile
      ~> jsonEmptyObject
      )

encodeMaybeNull :: forall a. (EncodeJson a) => Maybe a -> Json
encodeMaybeNull = maybe jsonNull encodeJson

instance encodeImportCommand :: EncodeJson ImportCommand where
  encodeJson (AddImplicitImport ident) =
    "importCommand" := "addImplicitImport"
    ~> "module" := encodeJson ident
    ~> jsonEmptyObject
  encodeJson (AddQualifiedImport mod qualifier) =
    "importCommand" := "addQualifiedImport"
    ~> "module" := encodeJson mod
    ~> "qualifier" := encodeJson qualifier
    ~> jsonEmptyObject
  encodeJson (AddImport mod qualifier) =
    "importCommand" := "addImport"
    ~> "identifier" := encodeJson mod
    ~> "qualifier" := encodeJson qualifier
    ~> jsonEmptyObject

type Result a = Either String a

type GenCompletion a = {
  type' :: String,
  identifier :: String,
  module' :: String
  | a
}

newtype TypePosition = TypePosition {
  name :: String,
  start :: Position,
  end :: Position
}

newtype TypeInfo = TypeInfo (GenCompletion (
  definedAt :: Maybe TypePosition,
  expandedType :: Maybe String,
  documentation :: Maybe String,
  exportedFrom :: Array String
))
newtype PursuitCompletion = PursuitCompletion {
  type' :: Maybe String,
  identifier :: String,
  module' :: String,
  package :: String,
  text :: String
  }

newtype ModuleList = ModuleList (Array String)
newtype Message = Message String
newtype ImportList = ImportList { moduleName :: Maybe String, imports :: Array Import }
newtype Import = Import
  {
    moduleName :: String,
    importType :: ImportType,
    qualifier  :: Maybe String
  }

type Position = {line :: Int, column :: Int}

newtype RebuildError =
  RebuildError
  { position :: Maybe Position
  , moduleName :: Maybe String
  , filename :: Maybe String
  , errorCode :: String
  , message :: String
  , pursIde :: Maybe PursIdeInfo
  }
newtype RebuildResult = RebuildResult (Array RebuildError)

newtype PursIdeInfo =
  PursIdeInfo
  { name :: String
  , completions :: Array TypeInfo
  }

data ImportType = Implicit | Explicit (Array String) | Hiding (Array String)

data ImportResult = SuccessFile Message | SuccessText (Array String) | MultipleResults (Array TypeInfo)

unwrapResponse :: forall a b. DecodeJson a => DecodeJson b => String -> Either String (Either a b)
unwrapResponse s = do
  json <- jsonParser s
  o <- decodeJson json
  resultType <- o .? "resultType"
  case resultType of
    "success" -> do
      result <- o .? "result"
      pure (Right result)
    _ -> do
      result <- o .? "result"
      pure (Left result)

instance decodeMessage :: DecodeJson Message where
  decodeJson json = maybe (Left "Message not string") (Right <<< Message) $ toString json

instance decodeModuleList :: DecodeJson ModuleList where
  decodeJson json = ModuleList <$> decodeJson json

instance decodeTypeInfo :: DecodeJson TypeInfo where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "identifier"
    type' <- o .? "type"
    module' <- o .? "module"
    definedAt <- o `getFieldMaybe` "definedAt"
    expandedType <- o `getFieldMaybe` "expandedType"
    documentation <- o `getFieldMaybe` "documentation"
    -- TODO: Handling both missing/incorrect exportedFrom. Remove this after 0.12
    exportedFrom <- Right $ either (const []) id $ getField o "exportedFrom"
    pure (TypeInfo { identifier, type', module', definedAt, expandedType, documentation, exportedFrom })
    where
    getFieldMaybe :: forall a. (DecodeJson a) => JObject -> String -> Either String (Maybe a)
    getFieldMaybe o f = Right $ either (const Nothing) Just $ getField o f

instance decodeTypePosition :: DecodeJson TypePosition where
  decodeJson json = do
    o <- decodeJson json
    name <- o .? "name"
    start <- o .? "start"
    end <- o .? "end"
    case start, end of
      [sl, sc], [el, ec] ->
        Right (TypePosition { name, start: { line: sl, column: sc }, end: { line: el, column: ec } })
      _, _ -> Left "Start/end should be arrays"

instance decodePursuitCompletion :: DecodeJson PursuitCompletion where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "ident"
    type' <- o .? "type"
    module' <- o .? "module"
    package <- o .? "package"
    text <- o .? "text"
    pure (PursuitCompletion {
      identifier: identifier,
      type': type',
      module': module',
      package: package,
      text: text
      })

instance decodeImportList :: DecodeJson ImportList where
  decodeJson json = decodeObject <|> decodeArray
    where
      decodeObject = do
        o <- decodeJson json
        moduleNameField <- o .? "moduleName"
        moduleName <- decodeModuleNameBug moduleNameField <|> decodeJson moduleNameField
        imports <- o .? "imports"
        pure (ImportList { moduleName: Just moduleName, imports })
      -- TODO: Working around a bug where module Foo.Bar is jsonified as ["Foo", "Bar"] instead of "Foo.Bar"
      decodeModuleNameBug moduleName = joinWith "." <$> decodeJson moduleName
      decodeArray = do
        imports <- decodeJson json
        pure (ImportList { moduleName: Nothing, imports })

instance decodeImport :: DecodeJson Import where
  decodeJson json = do
    o <- decodeJson json
    moduleName <- o .? "module"
    importType <- o .? "importType"
    q <- (Just <$> o .? "qualifier") <|> pure Nothing
    case importType of
      "implicit" -> do
        pure $ Import {moduleName: moduleName, importType: Implicit, qualifier: q}
      "explicit" -> do
        identifiers <- o .? "identifiers"
        pure $ Import {moduleName: moduleName, importType: Explicit identifiers, qualifier: q}
      "hiding"   -> do
        identifiers <- o .? "identifiers"
        pure $ Import {moduleName: moduleName, importType: Hiding identifiers, qualifier: q}
      _ -> Left "unknown importType"

instance decodeImportResult :: DecodeJson ImportResult where
  decodeJson json = do
    (SuccessText <$> decodeJson json)
    <|> (SuccessFile <$> decodeJson json)
    <|> (MultipleResults <$> decodeJson json)
    <|> (Left "Couldn't parse as ImportResult")

instance decodeRebuildError :: DecodeJson RebuildError where
  decodeJson json = do
    o <- decodeJson json
    message <- o .? "message"
    errorCode <- o .? "errorCode"
    moduleName <- o .? "moduleName"
    filename <- o .? "filename"
    position <- pure $ eitherToMaybe do
      p <- o .? "position"
      { line: _, column: _ } <$> p .? "startLine" <*> p .? "startColumn"
    pursIde <- pure $ eitherToMaybe do
      pio <- o .? "pursIde"
      name <- pio .? "name"
      completions <- pio .? "completions"
      pure $ PursIdeInfo { name, completions }
    pure (RebuildError { errorCode, moduleName, filename, message, position, pursIde })
    where
    eitherToMaybe :: forall a b. Either a b -> Maybe b
    eitherToMaybe = either (const Nothing) Just

instance decodeRebuildResult :: DecodeJson RebuildResult where
  decodeJson json = RebuildResult <$> (decodeJson json <|> (singleton <$> decodeJson json))

module PscIde.Command where

import Prelude
import Control.Alt ((<|>))
import Data.Argonaut (JObject, getField)
import Data.Argonaut.Core (jsonEmptyObject, jsonSingletonObject, jsonNull, Json, toString)
import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.?))
import Data.Argonaut.Encode (class EncodeJson, encodeJson, (~>), (:=))
import Data.Argonaut.Parser (jsonParser)
import Data.Array (singleton)
import Data.Either (either, Either(..))
import Data.Maybe (Maybe(..), maybe)
import Data.String (joinWith)

data PursuitType = Package | Ident

instance showPursuitType :: Show PursuitType where
  show Package = "package"
  show Ident   = "completion"

instance encodePursuitType :: EncodeJson PursuitType where
  encodeJson = encodeJson <<< show

data Matcher =
  Flex String
  | Distance String Int

instance encodeMatcher :: EncodeJson Matcher where
  encodeJson (Flex q) =
    "matcher" := "flex"
    ~> "params" := (jsonSingletonObject' "search" q)
    ~> jsonEmptyObject
  encodeJson (Distance q maxDist) =
    "matcher" := "distance"
    ~> "params" := (
       "search" := q
       ~> "maximumDistance" := maxDist
       ~> jsonEmptyObject
      )
    ~> jsonEmptyObject

data Filter =
  ExactFilter String
  | PrefixFilter String
  | ModuleFilter (Array String)
  | DependencyFilter (Array String)

filterWrapper :: forall a. (EncodeJson a) => String -> a -> Json
filterWrapper f q =
  "filter" := f
  ~> ("params" := q)
  ~> jsonEmptyObject

jsonSingletonObject' :: forall a. (EncodeJson a) => String -> a -> Json
jsonSingletonObject' s o = jsonSingletonObject s (encodeJson o)

instance encodeFilter :: EncodeJson Filter where
  encodeJson (ExactFilter q) =
    filterWrapper "exact" (jsonSingletonObject' "search" q)
  encodeJson (PrefixFilter q) =
    filterWrapper "prefix" (jsonSingletonObject' "search" q)
  encodeJson (ModuleFilter modules) =
    filterWrapper "modules" (jsonSingletonObject' "modules" modules)
  encodeJson (DependencyFilter deps) =
    filterWrapper "dependencies" (jsonSingletonObject' "modules" deps)

newtype CompletionOptions = CompletionOptions {
  maxResults :: Maybe Int,
  groupReexports :: Boolean
}

instance encodeCompletionOptions :: EncodeJson CompletionOptions where
  encodeJson (CompletionOptions { maxResults, groupReexports }) =
   "maxResults" := encodeMaybeNull maxResults
    ~> "groupReexports" := encodeJson groupReexports
    ~> jsonEmptyObject

data Command =
  Cwd
  | Ls ListType
  | Quit
  | Reset
  | Load (Array String) (Array String)
  | Complete (Array Filter) (Maybe Matcher) (Maybe String) CompletionOptions
  | Pursuit PursuitType String
  | Type String (Array Filter) (Maybe String)
  | AddClause String Boolean
  | CaseSplit String Int Int Boolean String
  | ImportCmd FileName (Maybe FileName) (Array Filter) ImportCommand
  | RebuildCmd String (Maybe FileName)

data ListType = LoadedModules | Imports String | AvailableModules

type FileName = String
data ImportCommand = AddImplicitImport String | AddQualifiedImport String String | AddImport String (Maybe String)

commandWrapper :: forall a. (EncodeJson a) => String -> a -> Json
commandWrapper s o =
  "command" := s
  ~> ("params" := o)
  ~> jsonEmptyObject

instance encodeCommand :: EncodeJson Command where
  encodeJson Cwd = jsonSingletonObject' "command" "cwd"
  encodeJson (Ls LoadedModules) =
    commandWrapper "list" ("type" := "loadedModules" ~> jsonEmptyObject)
  encodeJson (Ls AvailableModules) =
    commandWrapper "list" ("type" := "availableModules" ~> jsonEmptyObject)
  encodeJson (Ls (Imports fp)) =
    commandWrapper "list" ("type" := "import" ~> "file" := fp ~> jsonEmptyObject)
  encodeJson Quit = jsonSingletonObject' "command" "quit"
  encodeJson Reset = jsonSingletonObject' "command" "reset"
  encodeJson (Load modules dependencies) =
    commandWrapper "load" (
      "modules" := (encodeJson modules)
      ~> "dependencies" := (encodeJson dependencies)
      ~> jsonEmptyObject
      )
  encodeJson (Complete filters matcher currentModule options) =
    commandWrapper "complete" (
      "filters" := (encodeJson filters)
      ~> "matcher" := (encodeMaybeNull matcher)
      ~> "currentModule" := (encodeMaybeNull currentModule)
      ~> "options" := (encodeJson options)
      ~> jsonEmptyObject
      )
  encodeJson (Pursuit psType q) =
    commandWrapper "pursuit" (
        "type" := (encodeJson psType)
        ~> "query" := q
        ~> jsonEmptyObject
      )
  encodeJson (Type text filters currentModule) =
    commandWrapper "type" (
        "search" := encodeJson text
        ~> "filters" := (encodeJson filters)
        ~> "currentModule" := (encodeMaybeNull currentModule)
        ~> jsonEmptyObject
      )
  encodeJson (AddClause line annotations) =
    commandWrapper "addClause" (
        "line" := encodeJson line
        ~> "annotations" := encodeJson annotations
        ~> jsonEmptyObject
      )
  encodeJson (CaseSplit line begin end annotations typ) =
    commandWrapper "caseSplit" (
        "line" := encodeJson line
        ~> "begin" := encodeJson begin
        ~> "end" := encodeJson end
        ~> "annotations" := encodeJson annotations
        ~> "type" := encodeJson typ
        ~> jsonEmptyObject
      )
  encodeJson (ImportCmd inFile outFile filters cmd) =
    commandWrapper "import" (
      "file" := encodeJson inFile
      ~> "outfile" := encodeMaybeNull outFile
      ~> "filters" := encodeJson filters
      ~> "importCommand" := encodeJson cmd
      ~> jsonEmptyObject
      )
  encodeJson (RebuildCmd file actualFile) =
    commandWrapper "rebuild" (
      "file" := encodeJson file
      ~> "actualFile" := encodeMaybeNull actualFile
      ~> jsonEmptyObject
      )

encodeMaybeNull :: forall a. (EncodeJson a) => Maybe a -> Json
encodeMaybeNull = maybe jsonNull encodeJson

instance encodeImportCommand :: EncodeJson ImportCommand where
  encodeJson (AddImplicitImport ident) =
    "importCommand" := "addImplicitImport"
    ~> "module" := encodeJson ident
    ~> jsonEmptyObject
  encodeJson (AddQualifiedImport mod qualifier) =
    "importCommand" := "addQualifiedImport"
    ~> "module" := encodeJson mod
    ~> "qualifier" := encodeJson qualifier
    ~> jsonEmptyObject
  encodeJson (AddImport mod qualifier) =
    "importCommand" := "addImport"
    ~> "identifier" := encodeJson mod
    ~> "qualifier" := encodeJson qualifier
    ~> jsonEmptyObject

type Result a = Either String a

type GenCompletion a = {
  type' :: String,
  identifier :: String,
  module' :: String
  | a
}

newtype TypePosition = TypePosition {
  name :: String,
  start :: Position,
  end :: Position
}

newtype TypeInfo = TypeInfo (GenCompletion (
  definedAt :: Maybe TypePosition,
  expandedType :: Maybe String,
  documentation :: Maybe String,
  exportedFrom :: Array String
))
newtype PursuitCompletion = PursuitCompletion {
  type' :: Maybe String,
  identifier :: String,
  module' :: String,
  package :: String,
  text :: String
  }

newtype ModuleList = ModuleList (Array String)
newtype Message = Message String
newtype ImportList = ImportList { moduleName :: Maybe String, imports :: Array Import }
newtype Import = Import
  {
    moduleName :: String,
    importType :: ImportType,
    qualifier  :: Maybe String
  }

type Position = {line :: Int, column :: Int}

newtype RebuildError =
  RebuildError
  { position :: Maybe Position
  , moduleName :: Maybe String
  , filename :: Maybe String
  , errorCode :: String
  , message :: String
  }
newtype RebuildResult = RebuildResult (Array RebuildError)

data ImportType = Implicit | Explicit (Array String) | Hiding (Array String)

data ImportResult = SuccessFile Message | SuccessText (Array String) | MultipleResults (Array TypeInfo)

unwrapResponse :: forall a b. DecodeJson a => DecodeJson b => String -> Either String (Either a b)
unwrapResponse s = do
  json <- jsonParser s
  o <- decodeJson json
  resultType <- o .? "resultType"
  case resultType of
    "success" -> do
      result <- o .? "result"
      pure (Right result)
    _ -> do
      result <- o .? "result"
      pure (Left result)

instance decodeMessage :: DecodeJson Message where
  decodeJson json = maybe (Left "Message not string") (Right <<< Message) $ toString json

instance decodeModuleList :: DecodeJson ModuleList where
  decodeJson json = ModuleList <$> decodeJson json

instance decodeTypeInfo :: DecodeJson TypeInfo where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "identifier"
    type' <- o .? "type"
    module' <- o .? "module"
    definedAt <- o `getFieldMaybe` "definedAt"
    expandedType <- o `getFieldMaybe` "expandedType"
    documentation <- o `getFieldMaybe` "documentation"
    -- TODO: Handling both missing/incorrect exportedFrom. Remove this after 0.12
    exportedFrom <- Right $ either (const []) id $ getField o "exportedFrom"
    pure (TypeInfo { identifier, type', module', definedAt, expandedType, documentation, exportedFrom })
    where
    getFieldMaybe :: forall a. (DecodeJson a) => JObject -> String -> Either String (Maybe a)
    getFieldMaybe o f = Right $ either (const Nothing) Just $ getField o f

instance decodeTypePosition :: DecodeJson TypePosition where
  decodeJson json = do
    o <- decodeJson json
    name <- o .? "name"
    start <- o .? "start"
    end <- o .? "end"
    case start, end of
      [sl, sc], [el, ec] ->
        Right (TypePosition { name, start: { line: sl, column: sc }, end: { line: el, column: ec } })
      _, _ -> Left "Start/end should be arrays"

instance decodePursuitCompletion :: DecodeJson PursuitCompletion where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .? "ident"
    type' <- o .? "type"
    module' <- o .? "module"
    package <- o .? "package"
    text <- o .? "text"
    pure (PursuitCompletion {
      identifier: identifier,
      type': type',
      module': module',
      package: package,
      text: text
      })

instance decodeImportList :: DecodeJson ImportList where
  decodeJson json = decodeObject <|> decodeArray
    where
      decodeObject = do
        o <- decodeJson json
        moduleNameField <- o .? "moduleName"
        moduleName <- decodeModuleNameBug moduleNameField <|> decodeJson moduleNameField
        imports <- o .? "imports"
        pure (ImportList { moduleName: Just moduleName, imports })
      -- TODO: Working around a bug where module Foo.Bar is jsonified as ["Foo", "Bar"] instead of "Foo.Bar"
      decodeModuleNameBug moduleName = joinWith "." <$> decodeJson moduleName
      decodeArray = do
        imports <- decodeJson json
        pure (ImportList { moduleName: Nothing, imports })

instance decodeImport :: DecodeJson Import where
  decodeJson json = do
    o <- decodeJson json
    moduleName <- o .? "module"
    importType <- o .? "importType"
    q <- (Just <$> o .? "qualifier") <|> pure Nothing
    case importType of
      "implicit" -> do
        pure $ Import {moduleName: moduleName, importType: Implicit, qualifier: q}
      "explicit" -> do
        identifiers <- o .? "identifiers"
        pure $ Import {moduleName: moduleName, importType: Explicit identifiers, qualifier: q}
      "hiding"   -> do
        identifiers <- o .? "identifiers"
        pure $ Import {moduleName: moduleName, importType: Hiding identifiers, qualifier: q}
      _ -> Left "unknown importType"

instance decodeImportResult :: DecodeJson ImportResult where
  decodeJson json = do
    (SuccessText <$> decodeJson json)
    <|> (SuccessFile <$> decodeJson json)
    <|> (MultipleResults <$> decodeJson json)
    <|> (Left "Couldn't parse as ImportResult")

instance decodeRebuildError :: DecodeJson RebuildError where
  decodeJson json = do
    o <- decodeJson json
    message <- o .? "message"
    errorCode <- o .? "errorCode"
    moduleName <- o .? "moduleName"
    filename <- o .? "filename"
    position <- pure $ eitherToMaybe do
      p <- o .? "position"
      { line: _, column: _ } <$> p .? "startLine" <*> p .? "startColumn"
    pure (RebuildError { errorCode, moduleName, filename, message, position})
    where
      eitherToMaybe = either (const Nothing) Just

instance decodeRebuildResult :: DecodeJson RebuildResult where
  decodeJson json = RebuildResult <$> (decodeJson json <|> (singleton <$> decodeJson json))


Use single quotes in quoted JS

Use single quotes in quoted JS

module Graphics.D3.Selection
  ( Selection()
  , Update()
  , Enter()
  , Exit()
  , Transition()
  , Void()
  , AttrValue
  , Existing
  , Appendable
  , Clickable
  , rootSelect
  , rootSelectAll
  , select
  , selectAll
  , bind
  , enter
  , exit
  , transition
  , append
  , remove
  , attr
  , attr'
  , attr''
  , style
  , style'
  , style''
  , text
  , text'
  , text''
  , delay
  , delay'
  , delay''
  , duration
  , duration'
  , duration''
  , onClick
  , onDoubleClick
  ) where

import Graphics.D3.Base
import Control.Monad.Eff

import Data.Foreign
import Data.Foreign.EasyFFI

ffi = unsafeForeignFunction

-- The "selection-y" types, parameterized by the type of their bound data
foreign import data Selection :: * -> *
foreign import data Update :: * -> *
foreign import data Enter :: * -> *
foreign import data Transition :: * -> *

-- Exit selections have the same semantics as regular selections
type Exit d = Selection d

-- The (uninhabited) type of an unbound selection's data
data Void

-- The class of types which element attribute values can have (numbers and strings)
class AttrValue a

instance attrValNumber :: AttrValue Number
instance attrValString :: AttrValue String

rootSelect :: String -> D3Eff (Selection Void)
rootSelect = ffi ["selector", ""] "d3.select(selector)"

rootSelectAll :: String -> D3Eff (Selection Void)
rootSelectAll = ffi ["selector", ""] "d3.selectAll(selector)"

select :: forall d. String -> Selection d -> D3Eff (Selection d)
select = ffi ["selector", "selection", ""] "selection.select(selector)"

selectAll :: forall d. String -> Selection d -> D3Eff (Selection Void)
selectAll = ffi ["selector", "selection", ""] "selection.selectAll(selector)"

bind :: forall oldData newData. [newData] -> Selection oldData -> D3Eff (Update newData)
bind = ffi ["array", "selection", ""] "selection.data(array)"

enter :: forall d. Update d -> D3Eff (Enter d)
enter = ffi ["update", ""] "update.enter()"

exit :: forall d. Update d -> D3Eff (Exit d)
exit = ffi ["update", ""] "update.exit()"

transition :: forall s d. (Existing s) => s d -> D3Eff (Transition d)
transition = ffi ["selection", ""] "selection.transition()"

unsafeAppend :: forall x y. String -> x -> D3Eff y
unsafeAppend = ffi ["tag", "selection", ""] "selection.append(tag)"

unsafeRemove :: forall s. s -> D3Eff Unit
unsafeRemove = ffi ["selection", ""] "selection.remove()"

unsafeAttr :: forall d v s. (AttrValue v) => String -> v -> s -> D3Eff s
unsafeAttr = ffi ["key", "val", "selection", ""] "selection.attr(key, val)"

unsafeAttr' :: forall d v s. (AttrValue v) => String -> (d -> v) -> s -> D3Eff s
unsafeAttr' = ffi ["key", "val", "selection", ""] "selection.attr(key, val)"

unsafeAttr'' :: forall d v s. (AttrValue v) => String -> (d -> Number -> v) -> s -> D3Eff s
unsafeAttr'' = ffi
  ["key", "val", "selection", ""]
  "selection.attr(key, function (d, i) { return val(d)(i); })"

unsafeStyle :: forall d s. String -> String -> s -> D3Eff s
unsafeStyle = ffi ["key", "val", "selection", ""] "selection.style(key, val)"

unsafeStyle' :: forall d s. String -> (d -> String) -> s -> D3Eff s
unsafeStyle' = ffi ["key", "val", "selection", ""] "selection.style(key, val)"

unsafeStyle'' :: forall d s. String -> (d -> Number -> String) -> s -> D3Eff s
unsafeStyle'' = ffi
  ["key", "val", "selection", ""]
  "selection.style(key, function (d, i) { return val(d)(i); })"

unsafeText :: forall d s. String -> s -> D3Eff s
unsafeText = ffi ["text", "selection", ""] "selection.text(text)"

unsafeText' :: forall d s. (d -> String) -> s -> D3Eff s
unsafeText' = ffi ["text", "selection", ""] "selection.text(text)"

unsafeText'' :: forall d s. (d -> Number -> String) -> s -> D3Eff s
unsafeText'' = ffi
  ["text", "selection", ""]
  "selection.text(function (d, i) { return text(d)(i); })"

unsafeOnClick :: forall eff c i r. (Clickable c) => (i -> Eff eff r) -> c -> D3Eff c
unsafeOnClick = ffi ["callback", "clickable", ""] "clickable.on('click', callback)"

unsafeOnDoubleClick :: forall eff c i r. (Clickable c) => (i -> Eff eff r) -> c -> D3Eff c
unsafeOnDoubleClick = ffi ["callback", "clickable", ""] "clickable.on('dblclick', callback)"

-- Transition-only stuff
delay :: forall d. Number -> Transition d -> D3Eff (Transition d)
delay = ffi ["delay", "transition", ""] "transition.delay(delay)"

delay' :: forall d. (d -> Number) -> Transition d -> D3Eff (Transition d)
delay' = ffi ["delay", "transition", ""] "transition.delay(delay)"

delay'' :: forall d. (d -> Number -> Number) -> Transition d -> D3Eff (Transition d)
delay'' = ffi
  ["delay", "transition", ""]
  "transition.delay(function (d, i) { return delay(d)(i); })"

duration :: forall d. Number -> Transition d -> D3Eff (Transition d)
duration = ffi ["duration", "transition", ""] "transition.duration(duration)"

duration' :: forall d. (d -> Number) -> Transition d -> D3Eff (Transition d)
duration' = ffi ["duration", "transition", ""] "transition.duration(duration)"

duration'' :: forall d. (d -> Number -> Number) -> Transition d -> D3Eff (Transition d)
duration'' = ffi
  ["duration", "transition", ""]
  "transition.duration(function (d, i) { return duration(d)(i); })"

-- Selection-y things which can be appended to / inserted into
class Appendable s where
  append :: forall d. String -> s d -> D3Eff (Selection d)

instance appendableSelection  :: Appendable Selection where
  append = unsafeAppend

instance appendableUpdate     :: Appendable Update where
  append = unsafeAppend

instance appendableEnter      :: Appendable Enter where
  append = unsafeAppend

-- Selection-y things that contain existing DOM elements
class Existing s where
  attr :: forall d v. (AttrValue v) => String -> v -> s d -> D3Eff (s d)
  attr' :: forall d v. (AttrValue v) => String -> (d -> v) -> s d -> D3Eff (s d)
  attr'' :: forall d v. (AttrValue v) => String -> (d -> Number -> v) -> s d -> D3Eff (s d)
  style :: forall d. String -> String -> s d -> D3Eff (s d)
  style' :: forall d. String -> (d -> String) -> s d -> D3Eff (s d)
  style'' :: forall d. String -> (d -> Number -> String) -> s d -> D3Eff (s d)
  text :: forall d. String -> s d -> D3Eff (s d)
  text' :: forall d. (d -> String) -> s d -> D3Eff (s d)
  text'' :: forall d. (d -> Number -> String) -> s d -> D3Eff (s d)
  remove :: forall d. s d -> D3Eff Unit

instance existingSelection :: Existing Selection where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

instance existingUpdate :: Existing Update where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

instance existingTransition :: Existing Transition where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

class Clickable c where
  onClick :: forall eff r. (Foreign -> Eff eff r) -> c -> D3Eff c
  onDoubleClick :: forall eff r. (Foreign -> Eff eff r) -> c -> D3Eff c

instance clickableSelection :: Clickable (Selection a) where
  onClick = unsafeOnClick
  onDoubleClick = unsafeOnDoubleClick

module Graphics.D3.Selection
  ( Selection()
  , Update()
  , Enter()
  , Exit()
  , Transition()
  , Void()
  , AttrValue
  , Existing
  , Appendable
  , Clickable
  , rootSelect
  , rootSelectAll
  , select
  , selectAll
  , bind
  , enter
  , exit
  , transition
  , append
  , remove
  , attr
  , attr'
  , attr''
  , style
  , style'
  , style''
  , text
  , text'
  , text''
  , delay
  , delay'
  , delay''
  , duration
  , duration'
  , duration''
  , onClick
  , onDoubleClick
  ) where

import Graphics.D3.Base
import Control.Monad.Eff

import Data.Foreign
import Data.Foreign.EasyFFI

ffi = unsafeForeignFunction

-- The "selection-y" types, parameterized by the type of their bound data
foreign import data Selection :: * -> *
foreign import data Update :: * -> *
foreign import data Enter :: * -> *
foreign import data Transition :: * -> *

-- Exit selections have the same semantics as regular selections
type Exit d = Selection d

-- The (uninhabited) type of an unbound selection's data
data Void

-- The class of types which element attribute values can have (numbers and strings)
class AttrValue a

instance attrValNumber :: AttrValue Number
instance attrValString :: AttrValue String

rootSelect :: String -> D3Eff (Selection Void)
rootSelect = ffi ["selector", ""] "d3.select(selector)"

rootSelectAll :: String -> D3Eff (Selection Void)
rootSelectAll = ffi ["selector", ""] "d3.selectAll(selector)"

select :: forall d. String -> Selection d -> D3Eff (Selection d)
select = ffi ["selector", "selection", ""] "selection.select(selector)"

selectAll :: forall d. String -> Selection d -> D3Eff (Selection Void)
selectAll = ffi ["selector", "selection", ""] "selection.selectAll(selector)"

bind :: forall oldData newData. [newData] -> Selection oldData -> D3Eff (Update newData)
bind = ffi ["array", "selection", ""] "selection.data(array)"

enter :: forall d. Update d -> D3Eff (Enter d)
enter = ffi ["update", ""] "update.enter()"

exit :: forall d. Update d -> D3Eff (Exit d)
exit = ffi ["update", ""] "update.exit()"

transition :: forall s d. (Existing s) => s d -> D3Eff (Transition d)
transition = ffi ["selection", ""] "selection.transition()"

unsafeAppend :: forall x y. String -> x -> D3Eff y
unsafeAppend = ffi ["tag", "selection", ""] "selection.append(tag)"

unsafeRemove :: forall s. s -> D3Eff Unit
unsafeRemove = ffi ["selection", ""] "selection.remove()"

unsafeAttr :: forall d v s. (AttrValue v) => String -> v -> s -> D3Eff s
unsafeAttr = ffi ["key", "val", "selection", ""] "selection.attr(key, val)"

unsafeAttr' :: forall d v s. (AttrValue v) => String -> (d -> v) -> s -> D3Eff s
unsafeAttr' = ffi ["key", "val", "selection", ""] "selection.attr(key, val)"

unsafeAttr'' :: forall d v s. (AttrValue v) => String -> (d -> Number -> v) -> s -> D3Eff s
unsafeAttr'' = ffi
  ["key", "val", "selection", ""]
  "selection.attr(key, function (d, i) { return val(d)(i); })"

unsafeStyle :: forall d s. String -> String -> s -> D3Eff s
unsafeStyle = ffi ["key", "val", "selection", ""] "selection.style(key, val)"

unsafeStyle' :: forall d s. String -> (d -> String) -> s -> D3Eff s
unsafeStyle' = ffi ["key", "val", "selection", ""] "selection.style(key, val)"

unsafeStyle'' :: forall d s. String -> (d -> Number -> String) -> s -> D3Eff s
unsafeStyle'' = ffi
  ["key", "val", "selection", ""]
  "selection.style(key, function (d, i) { return val(d)(i); })"

unsafeText :: forall d s. String -> s -> D3Eff s
unsafeText = ffi ["text", "selection", ""] "selection.text(text)"

unsafeText' :: forall d s. (d -> String) -> s -> D3Eff s
unsafeText' = ffi ["text", "selection", ""] "selection.text(text)"

unsafeText'' :: forall d s. (d -> Number -> String) -> s -> D3Eff s
unsafeText'' = ffi
  ["text", "selection", ""]
  "selection.text(function (d, i) { return text(d)(i); })"

unsafeOnClick :: forall eff c i r. (Clickable c) => (i -> Eff eff r) -> c -> D3Eff c
unsafeOnClick = ffi ["callback", "clickable", ""] "clickable.on(\"click\", callback)"

unsafeOnDoubleClick :: forall eff c i r. (Clickable c) => (i -> Eff eff r) -> c -> D3Eff c
unsafeOnDoubleClick = ffi ["callback", "clickable", ""] "clickable.on(\"dblclick\", callback)"

-- Transition-only stuff
delay :: forall d. Number -> Transition d -> D3Eff (Transition d)
delay = ffi ["delay", "transition", ""] "transition.delay(delay)"

delay' :: forall d. (d -> Number) -> Transition d -> D3Eff (Transition d)
delay' = ffi ["delay", "transition", ""] "transition.delay(delay)"

delay'' :: forall d. (d -> Number -> Number) -> Transition d -> D3Eff (Transition d)
delay'' = ffi
  ["delay", "transition", ""]
  "transition.delay(function (d, i) { return delay(d)(i); })"

duration :: forall d. Number -> Transition d -> D3Eff (Transition d)
duration = ffi ["duration", "transition", ""] "transition.duration(duration)"

duration' :: forall d. (d -> Number) -> Transition d -> D3Eff (Transition d)
duration' = ffi ["duration", "transition", ""] "transition.duration(duration)"

duration'' :: forall d. (d -> Number -> Number) -> Transition d -> D3Eff (Transition d)
duration'' = ffi
  ["duration", "transition", ""]
  "transition.duration(function (d, i) { return duration(d)(i); })"

-- Selection-y things which can be appended to / inserted into
class Appendable s where
  append :: forall d. String -> s d -> D3Eff (Selection d)

instance appendableSelection  :: Appendable Selection where
  append = unsafeAppend

instance appendableUpdate     :: Appendable Update where
  append = unsafeAppend

instance appendableEnter      :: Appendable Enter where
  append = unsafeAppend

-- Selection-y things that contain existing DOM elements
class Existing s where
  attr :: forall d v. (AttrValue v) => String -> v -> s d -> D3Eff (s d)
  attr' :: forall d v. (AttrValue v) => String -> (d -> v) -> s d -> D3Eff (s d)
  attr'' :: forall d v. (AttrValue v) => String -> (d -> Number -> v) -> s d -> D3Eff (s d)
  style :: forall d. String -> String -> s d -> D3Eff (s d)
  style' :: forall d. String -> (d -> String) -> s d -> D3Eff (s d)
  style'' :: forall d. String -> (d -> Number -> String) -> s d -> D3Eff (s d)
  text :: forall d. String -> s d -> D3Eff (s d)
  text' :: forall d. (d -> String) -> s d -> D3Eff (s d)
  text'' :: forall d. (d -> Number -> String) -> s d -> D3Eff (s d)
  remove :: forall d. s d -> D3Eff Unit

instance existingSelection :: Existing Selection where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

instance existingUpdate :: Existing Update where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

instance existingTransition :: Existing Transition where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

class Clickable c where
  onClick :: forall eff r. (Foreign -> Eff eff r) -> c -> D3Eff c
  onDoubleClick :: forall eff r. (Foreign -> Eff eff r) -> c -> D3Eff c

instance clickableSelection :: Clickable (Selection a) where
  onClick = unsafeOnClick
  onDoubleClick = unsafeOnDoubleClick


don't show empty message if errored

don't show empty message if errored

module SlamData.Workspace.Deck.Dialog.Unshare.Component where

import SlamData.Prelude

import Control.UI.Browser (select)
import Control.UI.ZClipboard as Z

import Data.Array as Arr
import Data.Foldable as F
import Data.Lens (LensP, lens, (.~), (%~), (?~))
import Data.Lens.Index (ix)
import Data.Set as Set
import Data.Map as Map
import Data.StrMap as SM
import Data.Path.Pathy as Pt

import DOM.HTML.Types (HTMLElement, htmlElementToElement)

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.Themes.Bootstrap3 as B
import Halogen.CustomProps as Cp

import Quasar.Advanced.Types as QTA

import SlamData.Effects (Slam)
import SlamData.Render.Common (glyph)
import SlamData.Quasar.Security as Q
import SlamData.Workspace.Deck.Dialog.Share.Model (ShareResume(..), printShareResume)
import SlamData.Workspace.Deck.Dialog.Share.Model as Model

import Utils.Path (DirPath, parseFilePath)

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Slam

type PermissionId = Set.Set QTA.PermissionId

data PermissionState
  = Unsharing
  | Modifying
  | RevokeError
  | ModifyError

derive instance permissionStateEq ∷ Eq PermissionState

type Permission =
  { resume ∷ ShareResume
  , actions ∷ Map.Map QTA.PermissionId QTA.ActionR
  , state ∷ Maybe PermissionState
  }

data Modifyable = User | Group

type TokenPermission =
  { name ∷ Maybe String
  , secret ∷ String
  , resume ∷ ShareResume
  , tokenId ∷ QTA.TokenId
  , state ∷ Maybe PermissionState
  }

_resume ∷ ∀ a r. LensP {resume ∷ a|r} a
_resume = lens (_.resume) (_{resume = _})

_tokenId ∷ ∀ a r. LensP {tokenId ∷ a|r} a
_tokenId = lens (_.tokenId) (_{tokenId = _})

_secret ∷ ∀ a r. LensP {secret ∷ a|r} a
_secret = lens (_.secret) (_{secret = _})

-- :( `ix` doesn't work without `Maybe PermissionState`
_state ∷ ∀ r. LensP {state ∷ (Maybe PermissionState)|r} (Maybe PermissionState)
_state = lens (_.state) (_{state = _})

_actions
  ∷ ∀ r
  . LensP
      {actions ∷ Map.Map QTA.PermissionId QTA.ActionR|r}
      (Map.Map QTA.PermissionId QTA.ActionR)
_actions = lens (_.actions) (_{actions = _})

type State =
  { userPermissions ∷ SM.StrMap Permission
  , tokenPermissions ∷ Array TokenPermission
  , groupPermissions ∷ SM.StrMap Permission
  , loading ∷ Boolean
  , errored ∷ Boolean
  , deckPath ∷ DirPath
  }

initialState ∷ DirPath → State
initialState deckPath =
  { userPermissions: SM.empty
  , tokenPermissions: [ ]
  , groupPermissions: SM.empty
  , loading: true
  , errored: false
  , deckPath
  }

_userPermissions ∷ ∀ a r. LensP {userPermissions ∷ a|r} a
_userPermissions = lens (_.userPermissions) (_{userPermissions = _})

_groupPermissions ∷ ∀ a r. LensP {groupPermissions ∷ a |r} a
_groupPermissions = lens (_.groupPermissions) (_{groupPermissions = _})

_tokenPermissions ∷ ∀ a r. LensP {tokenPermissions ∷ a|r} a
_tokenPermissions = lens (_.tokenPermissions) (_{tokenPermissions = _})

_loading ∷ ∀ a r. LensP {loading ∷ a|r} a
_loading = lens (_.loading) (_{loading = _})

_errored ∷ ∀ a r. LensP {errored ∷ a|r} a
_errored = lens (_.errored) (_{errored = _})

data Query a
  = Dismiss a
  | InitZClipboard String (Maybe HTMLElement) a
  | Init a
  | SelectElement HTMLElement a
  | PermissionResumeChanged String String a
  | Unshare String a
  | UnshareToken QTA.TokenId  a

comp ∷ H.Component State Query Slam
comp =
  H.lifecycleComponent
    { render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }

render ∷ State → HTML
render state =
  HH.div [ HP.classes [ HH.className "deck-dialog-unshare" ] ]
    [ HH.h4_ [ HH.text "Unshare deck" ]
    , HH.div
        [ HP.classes
            $ [ B.alert, B.alertInfo, HH.className "share-loading" ]
            ⊕ if state.loading then [ ] else [ B.hidden ]
        ]
        [ HH.img [ HP.src "img/blue-spin.svg" ]
        , HH.text "Loading"
        ]

    , HH.div
        [ HP.classes
            $ [ HH.className "deck-dialog-body" ]
            ⊕ (if state.loading then [ B.hidden ] else [ ])
        ]
        [ HH.form
            [ Cp.nonSubmit ]
            $ (if SM.isEmpty state.userPermissions
                 then [ ]
                 else
                 [ HH.label
                     [ HP.classes [ HH.className "subject-label" ] ]
                     [ HH.text "Users" ]
                 ]
                 ⊕ (foldMap renderUserOrGroup $ SM.toList state.userPermissions)
              )
            ⊕ (if SM.isEmpty state.groupPermissions
                 then [ ]
                 else
                 [ HH.label
                    [ HP.classes [ HH.className "subject-label" ] ]
                    [ HH.text "Groups" ]
                 ]
                 ⊕ (foldMap renderUserOrGroup $ SM.toList state.groupPermissions)
              )
            ⊕ (if Arr.null state.tokenPermissions
                 then [ ]
                 else
                   [ HH.label
                       [ HP.classes [ HH.className "subject-label" ] ]
                       [ HH.text "Tokens" ]
                   ]
                   ⊕ map renderToken state.tokenPermissions
              )
            ⊕ (if SM.isEmpty state.userPermissions
                  ∧ SM.isEmpty state.groupPermissions
                  ∧ Arr.null state.tokenPermissions
                  ∧ not state.errored
                 then
                   [ HH.p_ [ HH.text "This deck hasn't been shared with anyone." ] ]
                 else [ ]
              )
        ]
    , let
        states =
          (foldMap (\x → [x.state]) state.userPermissions)
          ⊕ (foldMap (\x → [x.state]) state.groupPermissions)
          ⊕ (foldMap (\x → [x.state]) state.tokenPermissions)
        somethingErrored =
          F.any (\x → x ≡ Just ModifyError ∨ x ≡ Just RevokeError) states
        somethingHappening =
          F.any (\x → x ≡ Just Unsharing ∨ x ≡ Just Modifying) states
      in
       HH.div
        [ HP.classes
            $ [ HH.className "deck-dialog-footer" ]
            ⊕ (if state.loading then [ B.hidden ] else [ ])
        ]
        [ HH.div
            [ HP.classes
                $ [ B.alert, B.alertDanger ]
                ⊕ (if state.errored ∨ somethingErrored then [ ] else [ B.hidden ])
            ]
            [ HH.text
                $ if state.errored
                  then
                    "Sharing information is unavailable. To access or change the "
                    ⊕ "sharing information for this deck please check your network connection "
                    ⊕ "and try again."

                  else
                    "This action couldn't be performed. "
                    ⊕ "Please check your network connection and try again."

            ]

        , HH.button
            [ HE.onClick (HE.input_ Dismiss)
            , HP.buttonType HP.ButtonButton
            , HP.classes [ B.btn, B.btnDefault ]
            , HP.disabled somethingHappening
            ]
            [ HH.text "Done" ]
        ]

    ]

renderUserOrGroup ∷ (String × Permission) → Array HTML
renderUserOrGroup (name × perm) =
  [ HH.div
    [ HP.classes [ B.row ] ]
    [ HH.div
        [ HP.classes [ B.colXs7 ] ]
        [ HH.text name ]
    , HH.div
        [ HP.classes
            $ [ B.colXs3 ]
            ⊕ if perm.state ≡ Just ModifyError then [ B.hasError ] else [ ]
        ]
        [ HH.select
            [ HP.classes [ B.formControl ]
            , HE.onValueChange (HE.input (PermissionResumeChanged name))
            , HP.disabled $ perm.state ≡ Just Modifying ∨ perm.state ≡ Just Unsharing
            ]
            [ HH.option
                [ HP.value "view"
                , HP.selected $ perm.resume ≡ View
                ]
                [ HH.text
                    $ "View"
                    ⊕ if perm.state ≡ Just Modifying
                        then "..."
                        else ""
                ]
            , HH.option
                [ HP.value "edit"
                , HP.selected $ perm.resume ≡ Edit
                ]
                [ HH.text
                    $ "Edit"
                    ⊕ if perm.state ≡ Just Modifying
                        then "..."
                        else ""
                ]
            ]
        ]
    , HH.div
        [ HP.classes
            $ [ B.colXs2 ]
            ⊕ if perm.state ≡ Just RevokeError then [ B.hasError ] else [ ]
        ]
        [ HH.button
            [ HP.classes [ B.btn, B.btnDefault, HH.className "unshare-button" ]
            , HE.onClick (HE.input_ (Unshare name))
            , HP.disabled $ perm.state ≡ Just Modifying ∨ perm.state ≡ Just Unsharing
            ]
            [ HH.text if perm.state ≡ Just Unsharing
                        then "Revoking..."
                        else "Unshare"
            ]
        ]
    ]
  ]

renderToken ∷ TokenPermission → HTML
renderToken token =
  HH.div
    [ HP.classes [ B.row ] ]
    [ HH.div
        [ HP.classes [ B.colXs4, HH.className "token-name-field" ] ]
        [ HH.text $ fromMaybe "Untitled token" token.name ]
    , HH.div
        [ HP.classes [ B.colXs1 ] ]
        [ HH.text $ printShareResume token.resume ]
    , HH.div
        [ HP.classes [ B.colXs5 ] ]
        [ HH.div
            [ HP.classes
                $ [ B.inputGroup ]
                ⊕ if token.state ≡ Just ModifyError then [ B.hasError ] else [ ]
            ]
            [ HH.input
                [ HP.classes [ B.formControl ]
                , HP.readonly true
                , HP.title "Token secret"
                , HP.value token.secret
                , HE.onClick $ HE.input (SelectElement ∘ _.target)
                , HP.disabled $ isJust token.state
            ]
            , HH.span
                [ HP.classes [ B.inputGroupBtn ] ]
                [ HH.button
                    [ HP.classes [ B.btn, B.btnDefault ]
                    , HP.ref (H.action ∘ InitZClipboard token.secret)
                    , HP.disabled $ token.state ≡ Just Modifying ∨ token.state ≡ Just Unsharing
                    ]
                    [ glyph B.glyphiconCopy ]
                ]
            ]
        ]
    , HH.div
        [ HP.classes
            $ [ B.colXs2 ]
            ⊕ if token.state ≡ Just RevokeError then [ B.hasError ] else [ ]
        ]
        [ HH.button
            [ HP.classes [ B.btn, B.btnDefault, HH.className "unshare-button" ]
            , HE.onClick (HE.input_ (UnshareToken token.tokenId))
            , HP.disabled $ token.state ≡ Just Modifying ∨ token.state ≡ Just Unsharing
            ]
            [ HH.text if token.state ≡ Just Unsharing
                        then "Revoking..."
                        else "Unshare"
            ]
        ]
    ]

eval ∷ Query ~> DSL
eval (Init next) = next <$ do
  tokensRes ← Q.tokenList
  deckPath ← H.gets _.deckPath
  case tokensRes of
    Left e → H.modify (_{errored = true})
    Right toks →
      let
        tokenPerms = prepareAndFilterTokens toks deckPath
      in
        H.modify (_{tokenPermissions = tokenPerms})

  permsRes ← Q.permissionList false
  case permsRes of
    Left e → H.modify (_{errored = true})
    Right ps →
      let
        adjusted = adjustPermissions ps deckPath
      in
        H.modify (_{ userPermissions = adjusted.users
                   , groupPermissions = adjusted.groups
                   })
  H.modify (_{ loading = false})
eval (InitZClipboard token mbEl next) =
  next <$ for_ mbEl \el → do
    H.fromEff $ Z.make (htmlElementToElement el)
      >>= Z.onCopy (Z.setData "text/plain" token)
eval (Dismiss next) = pure next
eval (SelectElement el next) =
  next <$ H.fromEff (select el)
eval (PermissionResumeChanged name string next) = next <$ do
  state ← H.get
  H.modify (_{errored = false})
  let
    mbUserPerms = SM.lookup name state.userPermissions
    mbGroupPerms = SM.lookup name state.groupPermissions

    newResume | string ≡ "view" = View
              | otherwise = Edit

    oldResume | string ≡ "view" = Edit
              | otherwise = View

  for_ mbUserPerms \perms → do
    H.modify
      $ (_userPermissions ∘ ix name ∘ _state ?~ Modifying)
      ∘ (_userPermissions ∘ ix name ∘ _resume .~ newResume)
    mbLeftPid ← changePermissionResumeForUser name state.deckPath newResume perms
    H.modify case mbLeftPid of
      Nothing →
        (_userPermissions ∘ ix name ∘ _state .~ Nothing)
      Just leftPids →
        (_userPermissions ∘ ix name ∘ _state ?~ ModifyError)
        ∘ (_userPermissions ∘ ix name ∘ _actions .~ leftPids)
        ∘ (_userPermissions ∘ ix name ∘ _resume .~ oldResume)

  for_ mbGroupPerms \perms → do
    H.modify
      $ (_groupPermissions ∘ ix name ∘ _state ?~ Modifying)
      ∘ (_groupPermissions ∘ ix name ∘ _resume .~ newResume)

    mbLeftPid ← changePermissionResumeForGroup name state.deckPath newResume perms
    H.modify case mbLeftPid of
      Nothing →
        (_groupPermissions ∘ ix name ∘ _state .~ Nothing)
      Just leftPids →
        (_groupPermissions ∘ ix name ∘ _state ?~ ModifyError)
        ∘ (_groupPermissions ∘ ix name ∘ _actions .~ leftPids)
        ∘ (_groupPermissions ∘ ix name ∘ _resume .~ oldResume)

eval (UnshareToken tokenId next) = next <$ do
  state ← H.get
  let
    mtix = Arr.findIndex (\x → x.tokenId ≡ tokenId) state.tokenPermissions

  for_ mtix \tix → do
    H.modify $ _tokenPermissions ∘ ix tix ∘ _state ?~ Unsharing

    Q.deleteToken tokenId >>= case _ of
      Left _ →
        H.modify
          $ (_tokenPermissions ∘ ix tix ∘ _state ?~ RevokeError)
          ∘ (_errored .~ false)

      Right _ →
        H.modify
          $ _tokenPermissions %~ Arr.filter (\x → x.tokenId ≠ tokenId)

eval (Unshare name next) = next <$ do
  state ← H.get
  H.modify (_{errored = false})
  let
    mbUserPerms = SM.lookup name state.userPermissions
    mbGroupPerms = SM.lookup name state.groupPermissions

  for_ mbUserPerms \userPerms → do
    H.modify $ _userPermissions ∘ ix name ∘ _state ?~ Unsharing
    leftPids ← deletePermission userPerms.actions
    H.modify
      if Map.isEmpty leftPids
        then
        (_userPermissions %~ SM.delete name)
        ∘ (_userPermissions ∘ ix name ∘ _state .~ Nothing)
        else
        (_userPermissions ∘ ix name ∘ _actions .~ leftPids)
        ∘ (_userPermissions ∘ ix name ∘ _state ?~ RevokeError)

  for_ mbGroupPerms \groupPerms → do
    H.modify $ _groupPermissions ∘ ix name ∘ _state ?~ Unsharing
    leftPids ← deletePermission groupPerms.actions
    H.modify
      if Map.isEmpty leftPids
        then
        (_groupPermissions ∘ ix name ∘ _state .~ Nothing)
        ∘ (_groupPermissions %~ SM.delete name)
        else
        (_groupPermissions ∘ ix name ∘ _actions .~ leftPids)
        ∘ (_groupPermissions ∘ ix name ∘ _state ?~ RevokeError)

changePermissionResumeForUser
  ∷ String
  → DirPath
  → ShareResume
  → Permission
  → DSL (Maybe (Map.Map QTA.PermissionId QTA.ActionR))
changePermissionResumeForUser name deckPath res perm = do
  leftPids ← deletePermission perm.actions
  if not $ Map.isEmpty leftPids
    then
    pure $ Just leftPids
    else do
    let
      actions = Model.sharingActions deckPath res
      shareRequest =
        { users: [ QTA.UserId name ]
        , groups: [ ]
        , actions
        }
    shareRes ← Q.sharePermission shareRequest
    case shareRes of
      Left _ → pure $ Just Map.empty
      Right _ → pure Nothing

changePermissionResumeForGroup
  ∷ String
  → DirPath
  → ShareResume
  → Permission
  → DSL (Maybe (Map.Map QTA.PermissionId QTA.ActionR))
changePermissionResumeForGroup name deckPath res perm =
  case parseFilePath name of
    Nothing → pure $ Just perm.actions
    Just groupPath → do
      leftPids ← deletePermission perm.actions
      if not $ Map.isEmpty leftPids
        then
        pure $ Just leftPids
        else do
        let
          actions = Model.sharingActions deckPath res
          shareRequest =
            { users: [ ]
            , groups: [ groupPath ]
            , actions
            }
        shareRes ← Q.sharePermission shareRequest
        case shareRes of
          Left _ → pure $ Just Map.empty
          Right _ → pure Nothing

deletePermission
  ∷ Map.Map QTA.PermissionId QTA.ActionR
  → DSL (Map.Map QTA.PermissionId QTA.ActionR)
deletePermission permissionMap = do
  results ←
    for (Map.toList permissionMap) \(pid × act) → do
      lmap (const (pid × act))
        <$> Q.deletePermission pid

  pure $ foldMap foldFn results

  where
  foldFn (Left (pid × act)) = Map.singleton pid act
  foldFn _ = Map.empty

type AdjustedPermissions =
  { users ∷ SM.StrMap Permission
  , groups ∷ SM.StrMap Permission
  }

adjustPermissions ∷ Array QTA.PermissionR → DirPath → AdjustedPermissions
adjustPermissions prs deckPath =
  let
    folded = foldl foldFn Map.empty prs
    foldFn mp pr =
      Map.alter (alterFn pr) pr.grantedTo mp

    alterFn pr Nothing = Just [ pr ]
    alterFn pr (Just arr) = Just $ Arr.cons pr arr

    sharingActionsEdit =
      Set.fromFoldable $ map QTA.Action $ Model.sharingActions deckPath Edit
    sharingActionsView =
      Set.fromFoldable $ map QTA.Action $ Model.sharingActions deckPath View

    obj = foldl objFoldFn { users: SM.empty, groups: SM.empty } $ Map.toList folded

    objFoldFn acc@{ users, groups } (key × arr) =
      let
        actions = foldMap (\a → Map.singleton a.id a.action) arr
        actionsSet = Set.fromFoldable $ map QTA.Action actions
        perm = { resume: View
               , actions
               , state: Nothing
               }
      in case key of
        QTA.TokenGranted _ → acc
        QTA.UserGranted (QTA.UserId uid) →
          let
            res
              | sharingActionsEdit ≡ actionsSet =
                acc{users = SM.insert uid perm{resume = Edit} users }
              | sharingActionsView ≡ actionsSet =
                acc{users = SM.insert uid perm users}
              | otherwise = acc
          in res
        QTA.GroupGranted pt →
          let
            gid = Pt.printPath pt
            res
              | sharingActionsEdit ≡ actionsSet =
                acc{groups = SM.insert gid perm{resume = Edit} groups }
              | sharingActionsView ≡ actionsSet =
                acc{groups = SM.insert gid perm groups}
              | otherwise = acc
          in res
  in obj

prepareAndFilterTokens ∷ Array QTA.TokenR → DirPath →  Array TokenPermission
prepareAndFilterTokens toks deckPath =
  foldMap foldFn toks
  where
  foldFn ∷ QTA.TokenR → Array TokenPermission
  foldFn tr =
    let
      sharingActionsEdit =
        Set.fromFoldable $ map QTA.Action $ Model.sharingActions deckPath Edit
      sharingActionsView =
        Set.fromFoldable $ map QTA.Action $ Model.sharingActions deckPath View
      actions =
        Set.fromFoldable $ map QTA.Action tr.actions
      preToken =
        { name: map QTA.runTokenName tr.name
        , secret: maybe "" QTA.runTokenHash tr.secret
        , tokenId: tr.id
        , state: Nothing
        , resume: View
        }
      res
        | sharingActionsEdit ≡ actions =
          [ preToken{resume = Edit} ]
        | sharingActionsView ≡ actions =
          [ preToken ]
        | otherwise =
            [ ]
    in
      res

module SlamData.Workspace.Deck.Dialog.Unshare.Component where

import SlamData.Prelude

import Control.UI.Browser (select)
import Control.UI.ZClipboard as Z

import Data.Array as Arr
import Data.Foldable as F
import Data.Lens (LensP, lens, (.~), (%~), (?~))
import Data.Lens.Index (ix)
import Data.Set as Set
import Data.Map as Map
import Data.StrMap as SM
import Data.Path.Pathy as Pt

import DOM.HTML.Types (HTMLElement, htmlElementToElement)

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.Themes.Bootstrap3 as B
import Halogen.CustomProps as Cp

import Quasar.Advanced.Types as QTA

import SlamData.Effects (Slam)
import SlamData.Render.Common (glyph)
import SlamData.Quasar.Security as Q
import SlamData.Workspace.Deck.Dialog.Share.Model (ShareResume(..), printShareResume)
import SlamData.Workspace.Deck.Dialog.Share.Model as Model

import Utils.Path (DirPath, parseFilePath)

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Slam

type PermissionId = Set.Set QTA.PermissionId

data PermissionState
  = Unsharing
  | Modifying
  | RevokeError
  | ModifyError

derive instance permissionStateEq ∷ Eq PermissionState

type Permission =
  { resume ∷ ShareResume
  , actions ∷ Map.Map QTA.PermissionId QTA.ActionR
  , state ∷ Maybe PermissionState
  }

data Modifyable = User | Group

type TokenPermission =
  { name ∷ Maybe String
  , secret ∷ String
  , resume ∷ ShareResume
  , tokenId ∷ QTA.TokenId
  , state ∷ Maybe PermissionState
  }

_resume ∷ ∀ a r. LensP {resume ∷ a|r} a
_resume = lens (_.resume) (_{resume = _})

_tokenId ∷ ∀ a r. LensP {tokenId ∷ a|r} a
_tokenId = lens (_.tokenId) (_{tokenId = _})

_secret ∷ ∀ a r. LensP {secret ∷ a|r} a
_secret = lens (_.secret) (_{secret = _})

-- :( `ix` doesn't work without `Maybe PermissionState`
_state ∷ ∀ r. LensP {state ∷ (Maybe PermissionState)|r} (Maybe PermissionState)
_state = lens (_.state) (_{state = _})

_actions
  ∷ ∀ r
  . LensP
      {actions ∷ Map.Map QTA.PermissionId QTA.ActionR|r}
      (Map.Map QTA.PermissionId QTA.ActionR)
_actions = lens (_.actions) (_{actions = _})

type State =
  { userPermissions ∷ SM.StrMap Permission
  , tokenPermissions ∷ Array TokenPermission
  , groupPermissions ∷ SM.StrMap Permission
  , loading ∷ Boolean
  , errored ∷ Boolean
  , deckPath ∷ DirPath
  }

initialState ∷ DirPath → State
initialState deckPath =
  { userPermissions: SM.empty
  , tokenPermissions: [ ]
  , groupPermissions: SM.empty
  , loading: true
  , errored: false
  , deckPath
  }

_userPermissions ∷ ∀ a r. LensP {userPermissions ∷ a|r} a
_userPermissions = lens (_.userPermissions) (_{userPermissions = _})

_groupPermissions ∷ ∀ a r. LensP {groupPermissions ∷ a |r} a
_groupPermissions = lens (_.groupPermissions) (_{groupPermissions = _})

_tokenPermissions ∷ ∀ a r. LensP {tokenPermissions ∷ a|r} a
_tokenPermissions = lens (_.tokenPermissions) (_{tokenPermissions = _})

_loading ∷ ∀ a r. LensP {loading ∷ a|r} a
_loading = lens (_.loading) (_{loading = _})

_errored ∷ ∀ a r. LensP {errored ∷ a|r} a
_errored = lens (_.errored) (_{errored = _})

data Query a
  = Dismiss a
  | InitZClipboard String (Maybe HTMLElement) a
  | Init a
  | SelectElement HTMLElement a
  | PermissionResumeChanged String String a
  | Unshare String a
  | UnshareToken QTA.TokenId  a

comp ∷ H.Component State Query Slam
comp =
  H.lifecycleComponent
    { render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }

render ∷ State → HTML
render state =
  HH.div [ HP.classes [ HH.className "deck-dialog-unshare" ] ]
    [ HH.h4_ [ HH.text "Unshare deck" ]
    , HH.div
        [ HP.classes
            $ [ B.alert, B.alertInfo, HH.className "share-loading" ]
            ⊕ if state.loading then [ ] else [ B.hidden ]
        ]
        [ HH.img [ HP.src "img/blue-spin.svg" ]
        , HH.text "Loading"
        ]

    , HH.div
        [ HP.classes
            $ [ HH.className "deck-dialog-body" ]
            ⊕ (if state.loading then [ B.hidden ] else [ ])
        ]
        [ HH.form
            [ Cp.nonSubmit ]
            $ (if SM.isEmpty state.userPermissions
                 then [ ]
                 else
                 [ HH.label
                     [ HP.classes [ HH.className "subject-label" ] ]
                     [ HH.text "Users" ]
                 ]
                 ⊕ (foldMap renderUserOrGroup $ SM.toList state.userPermissions)
              )
            ⊕ (if SM.isEmpty state.groupPermissions
                 then [ ]
                 else
                 [ HH.label
                    [ HP.classes [ HH.className "subject-label" ] ]
                    [ HH.text "Groups" ]
                 ]
                 ⊕ (foldMap renderUserOrGroup $ SM.toList state.groupPermissions)
              )
            ⊕ (if Arr.null state.tokenPermissions
                 then [ ]
                 else
                   [ HH.label
                       [ HP.classes [ HH.className "subject-label" ] ]
                       [ HH.text "Tokens" ]
                   ]
                   ⊕ map renderToken state.tokenPermissions
              )
            ⊕ (if SM.isEmpty state.userPermissions
                  ∧ SM.isEmpty state.groupPermissions
                  ∧ Arr.null state.tokenPermissions
                 then
                   [ HH.p_ [ HH.text "This deck hasn't been shared with anyone." ] ]
                 else [ ]
              )
        ]
    , let
        states =
          (foldMap (\x → [x.state]) state.userPermissions)
          ⊕ (foldMap (\x → [x.state]) state.groupPermissions)
          ⊕ (foldMap (\x → [x.state]) state.tokenPermissions)
        somethingErrored =
          F.any (\x → x ≡ Just ModifyError ∨ x ≡ Just RevokeError) states
        somethingHappening =
          F.any (\x → x ≡ Just Unsharing ∨ x ≡ Just Modifying) states
      in
       HH.div
        [ HP.classes
            $ [ HH.className "deck-dialog-footer" ]
            ⊕ (if state.loading then [ B.hidden ] else [ ])
        ]
        [ HH.div
            [ HP.classes
                $ [ B.alert, B.alertDanger ]
                ⊕ (if state.errored ∨ somethingErrored then [ ] else [ B.hidden ])
            ]
            [ HH.text
                $ if state.errored
                  then
                    "Sharing information is unavailable. To access or change the "
                    ⊕ "sharing information for this deck please check your network connection "
                    ⊕ "and try again."

                  else
                    "This action couldn't be performed. "
                    ⊕ "Please check your network connection and try again."

            ]

        , HH.button
            [ HE.onClick (HE.input_ Dismiss)
            , HP.buttonType HP.ButtonButton
            , HP.classes [ B.btn, B.btnDefault ]
            , HP.disabled somethingHappening
            ]
            [ HH.text "Done" ]
        ]

    ]

renderUserOrGroup ∷ (String × Permission) → Array HTML
renderUserOrGroup (name × perm) =
  [ HH.div
    [ HP.classes [ B.row ] ]
    [ HH.div
        [ HP.classes [ B.colXs7 ] ]
        [ HH.text name ]
    , HH.div
        [ HP.classes
            $ [ B.colXs3 ]
            ⊕ if perm.state ≡ Just ModifyError then [ B.hasError ] else [ ]
        ]
        [ HH.select
            [ HP.classes [ B.formControl ]
            , HE.onValueChange (HE.input (PermissionResumeChanged name))
            , HP.disabled $ perm.state ≡ Just Modifying ∨ perm.state ≡ Just Unsharing
            ]
            [ HH.option
                [ HP.value "view"
                , HP.selected $ perm.resume ≡ View
                ]
                [ HH.text
                    $ "View"
                    ⊕ if perm.state ≡ Just Modifying
                        then "..."
                        else ""
                ]
            , HH.option
                [ HP.value "edit"
                , HP.selected $ perm.resume ≡ Edit
                ]
                [ HH.text
                    $ "Edit"
                    ⊕ if perm.state ≡ Just Modifying
                        then "..."
                        else ""
                ]
            ]
        ]
    , HH.div
        [ HP.classes
            $ [ B.colXs2 ]
            ⊕ if perm.state ≡ Just RevokeError then [ B.hasError ] else [ ]
        ]
        [ HH.button
            [ HP.classes [ B.btn, B.btnDefault, HH.className "unshare-button" ]
            , HE.onClick (HE.input_ (Unshare name))
            , HP.disabled $ perm.state ≡ Just Modifying ∨ perm.state ≡ Just Unsharing
            ]
            [ HH.text if perm.state ≡ Just Unsharing
                        then "Revoking..."
                        else "Unshare"
            ]
        ]
    ]
  ]

renderToken ∷ TokenPermission → HTML
renderToken token =
  HH.div
    [ HP.classes [ B.row ] ]
    [ HH.div
        [ HP.classes [ B.colXs4, HH.className "token-name-field" ] ]
        [ HH.text $ fromMaybe "Untitled token" token.name ]
    , HH.div
        [ HP.classes [ B.colXs1 ] ]
        [ HH.text $ printShareResume token.resume ]
    , HH.div
        [ HP.classes [ B.colXs5 ] ]
        [ HH.div
            [ HP.classes
                $ [ B.inputGroup ]
                ⊕ if token.state ≡ Just ModifyError then [ B.hasError ] else [ ]
            ]
            [ HH.input
                [ HP.classes [ B.formControl ]
                , HP.readonly true
                , HP.title "Token secret"
                , HP.value token.secret
                , HE.onClick $ HE.input (SelectElement ∘ _.target)
                , HP.disabled $ isJust token.state
            ]
            , HH.span
                [ HP.classes [ B.inputGroupBtn ] ]
                [ HH.button
                    [ HP.classes [ B.btn, B.btnDefault ]
                    , HP.ref (H.action ∘ InitZClipboard token.secret)
                    , HP.disabled $ token.state ≡ Just Modifying ∨ token.state ≡ Just Unsharing
                    ]
                    [ glyph B.glyphiconCopy ]
                ]
            ]
        ]
    , HH.div
        [ HP.classes
            $ [ B.colXs2 ]
            ⊕ if token.state ≡ Just RevokeError then [ B.hasError ] else [ ]
        ]
        [ HH.button
            [ HP.classes [ B.btn, B.btnDefault, HH.className "unshare-button" ]
            , HE.onClick (HE.input_ (UnshareToken token.tokenId))
            , HP.disabled $ token.state ≡ Just Modifying ∨ token.state ≡ Just Unsharing
            ]
            [ HH.text if token.state ≡ Just Unsharing
                        then "Revoking..."
                        else "Unshare"
            ]
        ]
    ]

eval ∷ Query ~> DSL
eval (Init next) = next <$ do
  tokensRes ← Q.tokenList
  deckPath ← H.gets _.deckPath
  case tokensRes of
    Left e → H.modify (_{errored = true})
    Right toks →
      let
        tokenPerms = prepareAndFilterTokens toks deckPath
      in
        H.modify (_{tokenPermissions = tokenPerms})

  permsRes ← Q.permissionList false
  case permsRes of
    Left e → H.modify (_{errored = true})
    Right ps →
      let
        adjusted = adjustPermissions ps deckPath
      in
        H.modify (_{ userPermissions = adjusted.users
                   , groupPermissions = adjusted.groups
                   })
  H.modify (_{ loading = false})
eval (InitZClipboard token mbEl next) =
  next <$ for_ mbEl \el → do
    H.fromEff $ Z.make (htmlElementToElement el)
      >>= Z.onCopy (Z.setData "text/plain" token)
eval (Dismiss next) = pure next
eval (SelectElement el next) =
  next <$ H.fromEff (select el)
eval (PermissionResumeChanged name string next) = next <$ do
  state ← H.get
  H.modify (_{errored = false})
  let
    mbUserPerms = SM.lookup name state.userPermissions
    mbGroupPerms = SM.lookup name state.groupPermissions

    newResume | string ≡ "view" = View
              | otherwise = Edit

    oldResume | string ≡ "view" = Edit
              | otherwise = View

  for_ mbUserPerms \perms → do
    H.modify
      $ (_userPermissions ∘ ix name ∘ _state ?~ Modifying)
      ∘ (_userPermissions ∘ ix name ∘ _resume .~ newResume)
    mbLeftPid ← changePermissionResumeForUser name state.deckPath newResume perms
    H.modify case mbLeftPid of
      Nothing →
        (_userPermissions ∘ ix name ∘ _state .~ Nothing)
      Just leftPids →
        (_userPermissions ∘ ix name ∘ _state ?~ ModifyError)
        ∘ (_userPermissions ∘ ix name ∘ _actions .~ leftPids)
        ∘ (_userPermissions ∘ ix name ∘ _resume .~ oldResume)

  for_ mbGroupPerms \perms → do
    H.modify
      $ (_groupPermissions ∘ ix name ∘ _state ?~ Modifying)
      ∘ (_groupPermissions ∘ ix name ∘ _resume .~ newResume)

    mbLeftPid ← changePermissionResumeForGroup name state.deckPath newResume perms
    H.modify case mbLeftPid of
      Nothing →
        (_groupPermissions ∘ ix name ∘ _state .~ Nothing)
      Just leftPids →
        (_groupPermissions ∘ ix name ∘ _state ?~ ModifyError)
        ∘ (_groupPermissions ∘ ix name ∘ _actions .~ leftPids)
        ∘ (_groupPermissions ∘ ix name ∘ _resume .~ oldResume)

eval (UnshareToken tokenId next) = next <$ do
  state ← H.get
  let
    mtix = Arr.findIndex (\x → x.tokenId ≡ tokenId) state.tokenPermissions

  for_ mtix \tix → do
    H.modify $ _tokenPermissions ∘ ix tix ∘ _state ?~ Unsharing

    Q.deleteToken tokenId >>= case _ of
      Left _ →
        H.modify
          $ (_tokenPermissions ∘ ix tix ∘ _state ?~ RevokeError)
          ∘ (_errored .~ false)

      Right _ →
        H.modify
          $ _tokenPermissions %~ Arr.filter (\x → x.tokenId ≠ tokenId)

eval (Unshare name next) = next <$ do
  state ← H.get
  H.modify (_{errored = false})
  let
    mbUserPerms = SM.lookup name state.userPermissions
    mbGroupPerms = SM.lookup name state.groupPermissions

  for_ mbUserPerms \userPerms → do
    H.modify $ _userPermissions ∘ ix name ∘ _state ?~ Unsharing
    leftPids ← deletePermission userPerms.actions
    H.modify
      if Map.isEmpty leftPids
        then
        (_userPermissions %~ SM.delete name)
        ∘ (_userPermissions ∘ ix name ∘ _state .~ Nothing)
        else
        (_userPermissions ∘ ix name ∘ _actions .~ leftPids)
        ∘ (_userPermissions ∘ ix name ∘ _state ?~ RevokeError)

  for_ mbGroupPerms \groupPerms → do
    H.modify $ _groupPermissions ∘ ix name ∘ _state ?~ Unsharing
    leftPids ← deletePermission groupPerms.actions
    H.modify
      if Map.isEmpty leftPids
        then
        (_groupPermissions ∘ ix name ∘ _state .~ Nothing)
        ∘ (_groupPermissions %~ SM.delete name)
        else
        (_groupPermissions ∘ ix name ∘ _actions .~ leftPids)
        ∘ (_groupPermissions ∘ ix name ∘ _state ?~ RevokeError)

changePermissionResumeForUser
  ∷ String
  → DirPath
  → ShareResume
  → Permission
  → DSL (Maybe (Map.Map QTA.PermissionId QTA.ActionR))
changePermissionResumeForUser name deckPath res perm = do
  leftPids ← deletePermission perm.actions
  if not $ Map.isEmpty leftPids
    then
    pure $ Just leftPids
    else do
    let
      actions = Model.sharingActions deckPath res
      shareRequest =
        { users: [ QTA.UserId name ]
        , groups: [ ]
        , actions
        }
    shareRes ← Q.sharePermission shareRequest
    case shareRes of
      Left _ → pure $ Just Map.empty
      Right _ → pure Nothing

changePermissionResumeForGroup
  ∷ String
  → DirPath
  → ShareResume
  → Permission
  → DSL (Maybe (Map.Map QTA.PermissionId QTA.ActionR))
changePermissionResumeForGroup name deckPath res perm =
  case parseFilePath name of
    Nothing → pure $ Just perm.actions
    Just groupPath → do
      leftPids ← deletePermission perm.actions
      if not $ Map.isEmpty leftPids
        then
        pure $ Just leftPids
        else do
        let
          actions = Model.sharingActions deckPath res
          shareRequest =
            { users: [ ]
            , groups: [ groupPath ]
            , actions
            }
        shareRes ← Q.sharePermission shareRequest
        case shareRes of
          Left _ → pure $ Just Map.empty
          Right _ → pure Nothing

deletePermission
  ∷ Map.Map QTA.PermissionId QTA.ActionR
  → DSL (Map.Map QTA.PermissionId QTA.ActionR)
deletePermission permissionMap = do
  results ←
    for (Map.toList permissionMap) \(pid × act) → do
      lmap (const (pid × act))
        <$> Q.deletePermission pid

  pure $ foldMap foldFn results

  where
  foldFn (Left (pid × act)) = Map.singleton pid act
  foldFn _ = Map.empty

type AdjustedPermissions =
  { users ∷ SM.StrMap Permission
  , groups ∷ SM.StrMap Permission
  }

adjustPermissions ∷ Array QTA.PermissionR → DirPath → AdjustedPermissions
adjustPermissions prs deckPath =
  let
    folded = foldl foldFn Map.empty prs
    foldFn mp pr =
      Map.alter (alterFn pr) pr.grantedTo mp

    alterFn pr Nothing = Just [ pr ]
    alterFn pr (Just arr) = Just $ Arr.cons pr arr

    sharingActionsEdit =
      Set.fromFoldable $ map QTA.Action $ Model.sharingActions deckPath Edit
    sharingActionsView =
      Set.fromFoldable $ map QTA.Action $ Model.sharingActions deckPath View

    obj = foldl objFoldFn { users: SM.empty, groups: SM.empty } $ Map.toList folded

    objFoldFn acc@{ users, groups } (key × arr) =
      let
        actions = foldMap (\a → Map.singleton a.id a.action) arr
        actionsSet = Set.fromFoldable $ map QTA.Action actions
        perm = { resume: View
               , actions
               , state: Nothing
               }
      in case key of
        QTA.TokenGranted _ → acc
        QTA.UserGranted (QTA.UserId uid) →
          let
            res
              | sharingActionsEdit ≡ actionsSet =
                acc{users = SM.insert uid perm{resume = Edit} users }
              | sharingActionsView ≡ actionsSet =
                acc{users = SM.insert uid perm users}
              | otherwise = acc
          in res
        QTA.GroupGranted pt →
          let
            gid = Pt.printPath pt
            res
              | sharingActionsEdit ≡ actionsSet =
                acc{groups = SM.insert gid perm{resume = Edit} groups }
              | sharingActionsView ≡ actionsSet =
                acc{groups = SM.insert gid perm groups}
              | otherwise = acc
          in res
  in obj

prepareAndFilterTokens ∷ Array QTA.TokenR → DirPath →  Array TokenPermission
prepareAndFilterTokens toks deckPath =
  foldMap foldFn toks
  where
  foldFn ∷ QTA.TokenR → Array TokenPermission
  foldFn tr =
    let
      sharingActionsEdit =
        Set.fromFoldable $ map QTA.Action $ Model.sharingActions deckPath Edit
      sharingActionsView =
        Set.fromFoldable $ map QTA.Action $ Model.sharingActions deckPath View
      actions =
        Set.fromFoldable $ map QTA.Action tr.actions
      preToken =
        { name: map QTA.runTokenName tr.name
        , secret: maybe "" QTA.runTokenHash tr.secret
        , tokenId: tr.id
        , state: Nothing
        , resume: View
        }
      res
        | sharingActionsEdit ≡ actions =
          [ preToken{resume = Edit} ]
        | sharingActionsView ≡ actions =
          [ preToken ]
        | otherwise =
            [ ]
    in
      res