Added uniqueness

Added uniqueness

module Flag.App (Event, Country(..), shuffle, init, foldp, view) where

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM, random)
import Data.Argonaut (class DecodeJson, decodeJson, Json, (.?))
import Data.Array (drop, head, length, nub, replicate, sortBy, take, uncons, zip)
import Data.Either (Either, either)
import Data.Int (round, toNumber)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_, sequence)
import Data.Tuple (Tuple(..), snd)
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

type State = { all :: Countries, current :: Names, correct :: Int, incorrect :: Int }
type Countries = Array Country
type Names = Array String

data Event = RequestCountries | ReceiveCountries (Tuple Countries Names) | ReceiveAnswer String | ReceiveAnswers Names

newtype Country = Country { name :: String, flag :: String }

derive instance newtypeCountry :: Newtype Country _

instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

instance decodeJsonCountry :: DecodeJson Country where
  decodeJson json = do
    model <- decodeJson json
    name <- model .? "name"
    flag <- model .? "flag"
    pure $ Country { name, flag }

answerCount :: Int
answerCount = 4

init :: State
init = { all: [], current: [], correct: 0, incorrect: 0 }

decode :: forall r. { response :: Json | r } -> Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch :: forall e. Aff (ajax :: AJAX, random :: RANDOM | e) (Tuple Countries Names)
fetch = get "/countries.json"
  >>= pure <<< decode
  >>= liftEff <<< shuffle <<< either (const []) id
  >>= \countries -> pure <<< Tuple countries <=< liftEff <<< pick $ countries

shuffle :: forall e a. Array a -> Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

pick :: forall e. Countries -> Eff (random :: RANDOM | e) Names
pick xs = pure <=< shuffle <<< nub <<< (next <> _) <<< take (answerCount - 1) <=< shuffle $ _.name <<< unwrap <$> xs
  where next = _.name <<< unwrap <$> take 1 xs

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX, random :: RANDOM)
foldp (ReceiveAnswer name) state = {
  state: case (_ == name) <<< maybe mempty (_.name <<< unwrap) $ head state.all of
           true -> state { all = drop 1 state.all, correct = state.correct + 1 }
           _    -> state { all = drop 1 state.all, incorrect = state.incorrect + 1 },
  effects: [pure <<< Just <<< ReceiveAnswers <=< liftEff <<< pick <<< drop 1 $ state.all]
}
foldp (ReceiveAnswers current) state = noEffects state { current = current }
foldp (ReceiveCountries (Tuple all current)) state = noEffects state { all = all, current = current }
foldp (RequestCountries) state = {
  state: state { correct = 0, incorrect = 0 },
  effects: [Just <<< ReceiveCountries <$> fetch]
}

view :: State -> HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.all)
    div ! className "correct" $ text $ show state.correct
    div ! className "incorrect" $ text $ show state.incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.all), (state.correct + state.incorrect) of
    Just { head }, _ -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ state.current $ \name -> li #! onClick (const $ ReceiveAnswer name) $ text name
    Nothing, 0 -> div $ text mempty
    Nothing, _ -> do
      section ! className "results" $ do
        div ! className "percentage" $ text $ (show percentage) <> "%"
        div ! className "score" $ text $ "You scored " <> (show state.correct) <> " out of " <> (show total) <> "."
        a #! onClick (const RequestCountries) $ text "Play Again"
      where total = state.correct + state.incorrect
            percentage = round $ toNumber state.correct / (toNumber $ state.correct + state.incorrect) * 100.0

module Flag.App (Event, Country(..), shuffle, init, foldp, view) where

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM, random)
import Data.Argonaut (class DecodeJson, decodeJson, Json, (.?))
import Data.Array (drop, head, length, replicate, sortBy, take, uncons, zip)
import Data.Either (Either, either)
import Data.Int (round, toNumber)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_, sequence)
import Data.Tuple (Tuple(..), snd)
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

type State = { all :: Countries, current :: Names, correct :: Int, incorrect :: Int }
type Countries = Array Country
type Names = Array String

data Event = RequestCountries | ReceiveCountries (Tuple Countries Names) | ReceiveAnswer String | ReceiveAnswers Names

newtype Country = Country { name :: String, flag :: String }

derive instance newtypeCountry :: Newtype Country _

instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

instance decodeJsonCountry :: DecodeJson Country where
  decodeJson json = do
    model <- decodeJson json
    name <- model .? "name"
    flag <- model .? "flag"
    pure $ Country { name, flag }

answerCount :: Int
answerCount = 4

init :: State
init = { all: [], current: [], correct: 0, incorrect: 0 }

decode :: forall r. { response :: Json | r } -> Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch :: forall e. Aff (ajax :: AJAX, random :: RANDOM | e) (Tuple Countries Names)
fetch = get "/countries.json"
  >>= pure <<< decode
  >>= liftEff <<< shuffle <<< either (const []) id
  >>= \countries -> pure <<< Tuple countries <=< liftEff <<< pick $ countries

shuffle :: forall e a. Array a -> Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

pick :: forall e. Countries -> Eff (random :: RANDOM | e) Names
pick xs = pure <=< shuffle <<< (next <> _) <<< take (answerCount - 1) <=< shuffle $ _.name <<< unwrap <$> xs
  where next = _.name <<< unwrap <$> take 1 xs

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX, random :: RANDOM)
foldp (ReceiveAnswer name) state = {
  state: case (_ == name) <<< maybe mempty (_.name <<< unwrap) $ head state.all of
           true -> state { all = drop 1 state.all, correct = state.correct + 1 }
           _    -> state { all = drop 1 state.all, incorrect = state.incorrect + 1 },
  effects: [pure <<< Just <<< ReceiveAnswers <=< liftEff <<< pick <<< drop 1 $ state.all]
}
foldp (ReceiveAnswers current) state = noEffects state { current = current }
foldp (ReceiveCountries (Tuple all current)) state = noEffects state { all = all, current = current }
foldp (RequestCountries) state = {
  state: state { correct = 0, incorrect = 0 },
  effects: [Just <<< ReceiveCountries <$> fetch]
}

view :: State -> HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.all)
    div ! className "correct" $ text $ show state.correct
    div ! className "incorrect" $ text $ show state.incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.all), (state.correct + state.incorrect) of
    Just { head }, _ -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ state.current $ \name -> li #! onClick (const $ ReceiveAnswer name) $ text name
    Nothing, 0 -> div $ text mempty
    Nothing, _ -> do
      section ! className "results" $ do
        div ! className "percentage" $ text $ (show percentage) <> "%"
        div ! className "score" $ text $ "You scored " <> (show state.correct) <> " out of " <> (show total) <> "."
        a #! onClick (const RequestCountries) $ text "Play Again"
      where total = state.correct + state.incorrect
            percentage = round $ toNumber state.correct / (toNumber $ state.correct + state.incorrect) * 100.0


basic style for accept invitation

basic style for accept invitation

module Gonimo.UI.AcceptInvitation where

import Gonimo.UI.Html
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Types as Gonimo
import Gonimo.WebAPI.Types as WebAPI
import Pux.Html.Attributes as A
import Pux.Html.Events as E
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.IO (IO)
import Control.Monad.Reader.Class (ask)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (get, put)
import Data.Bifunctor (lmap)
import Data.Either (Either(Right, Left))
import Data.Generic (gShow)
import Data.Lens (_Just)
import Data.Maybe (fromMaybe, isJust, isNothing, Maybe(..))
import Data.Tuple (Tuple(Tuple))
import Gonimo.Client.Types (GonimoError(UnexpectedAction), Gonimo, Settings, class ReportErrorAction)
import Gonimo.Pux (Component, makeChildData, liftChild, noEffects, onlyModify, Update, ToChild, runGonimo, ComponentType, class MonadComponent)
import Gonimo.Server.DbEntities (Invitation(Invitation))
import Gonimo.Server.Types (InvitationDelivery(EmailInvitation), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Key(Key), Secret(Secret))
import Gonimo.Util (fromMaybeM)
import Gonimo.WebAPI (deleteInvitationsByInvitationSecret, putInvitationsInfoByInvitationSecret, postFamilies, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (InvitationReply(InvitationReject, InvitationAccept), InvitationReply(InvitationReject, InvitationAccept), InvitationInfo(InvitationInfo), AuthData(AuthData))
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (br, em, button, input, p, h3, i, text, span, Html, img, div)
import Pux.Html.Attributes (offset)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Signal (constant, Signal)
import Prelude hiding (div)

type Props ps = { settings :: Settings | ps }

type State = Maybe StateImpl

type StateImpl = { invitationInfo :: InvitationInfo
                 , invitationSecret :: Secret
                 , accepted :: Maybe Boolean
                 }

init :: State
init = Nothing

data Action = LoadInvitation Secret
            | Init (Tuple Secret InvitationInfo)
            | Accept
            | Decline
            | SetAccepted Boolean
            | ReportError GonimoError
            | Nop

instance reportErrorActionAction :: ReportErrorAction Action where
  reportError = ReportError

update :: forall ps m. Action -> Component (Props ps) State (Array (IO Action))
update action = do
   r <- liftChild toJust (updateJust action)
   case r of
     Nothing -> updateNothing action
     Just v -> pure v
   -- myFromMaybeM (updateNothing action)
   -- $ liftChild toJust (updateJust action)

toJust :: forall ps. ToChild (Props ps) State (Props ps) StateImpl
toJust = do
  props <- ask
  pure $ makeChildData _Just props

updateNothing :: forall ps. Update (Props ps) State Action
updateNothing action = case action of
  LoadInvitation secret   -> runGonimo $ loadInvitation secret
  Init (Tuple secret inv) -> put ( Just { invitationInfo : inv, invitationSecret : secret, accepted : (Nothing :: Maybe Boolean) } ) *> pure []
  Nop                     -> noEffects
  ReportError err         -> noEffects
  _                       -> pure [ pure (ReportError $ UnexpectedAction "Received some Action but State is Nothing!") ]

updateJust :: forall ps. Update (Props ps) StateImpl Action
updateJust action = case action of
  LoadInvitation secret   -> runGonimo $ loadInvitation secret
  Init (Tuple secret inv) -> onlyModify $ _ { invitationInfo = inv, invitationSecret = secret, accepted = (Nothing :: Maybe Boolean)}
  Accept                  -> answerInvitation InvitationAccept
  Decline                 -> answerInvitation InvitationReject
  SetAccepted accepted'   -> onlyModify $ _ { accepted = Just accepted' }
  Nop                     -> noEffects
  ReportError err         -> noEffects

loadInvitation :: Secret -> Gonimo Action
loadInvitation secret = Init <<< Tuple secret <$> putInvitationsInfoByInvitationSecret secret

answerInvitation :: forall ps. InvitationReply -> ComponentType (Props ps) StateImpl Action
answerInvitation reply = do
  state <- get
  runGonimo $ do
    deleteInvitationsByInvitationSecret reply state.invitationSecret
    pure $ SetAccepted $ case reply of
      InvitationAccept  -> true
      InvitationReject  -> false

    --------------------------------------------------------------------------------

view :: State -> Html Action
view Nothing = viewLoading "Loading your invitation - stay tight ..."
view (Just state) = case state.accepted of
  Nothing    ->  viewAskUser state.invitationInfo
  Just true  ->  viewAccepted state.invitationInfo
  Just false ->  viewDeclined state.invitationInfo

viewAskUser :: InvitationInfo -> Html Action
viewAskUser (InvitationInfo invitation) =
    div []
        [ h3 [] [ text "Gonimo Family Invitation!"]
        , div [A.className "jumbotron"]
          [ div [A.className "container"]
            [ text $ "You received an invitation to join family: "
            , em [] [ text invitation.invitationInfoFamily ]
            , text "!"
            , br [] []
            , text $ "You got invited by a device answering to the name: "
            , em [] [ text invitation.invitationInfoSendingDevice ]
            , text "."
            ]
          ]

        , div [ E.onKeyUp handleEnter ]
          [ p [] [ text $ "Do you really want to join the family \""
                <> invitation.invitationInfoFamily <> "\"?"
                 ]
          , p []
              [ text $ "Pick wisely! Gonimo is the most awesome baby monitor on the planet, but only with the right family!"
              ]
          , div [ A.className "btn-group btn-group-justified"
                , A.role "group"]
            [ div [ A.className "btn-group"
                  , A.role "group"]
              [ button [ A.className "btn btn-block btn-danger"
                       , A.type_ "button"
                       , E.onClick $ const $ Decline
                       ] [ text "Decline "
                         , i [A.className "fa fa-fw fa-times"] []
                         ]
              ]
            , div [ A.className "btn-group"
                  , A.role "group"]
              [ button [ A.title "Hello my dear family!"
                       , E.onClick $ const $ Accept
                       , A.className "btn btn-block btn-success"
                       , A.type_ "button"
                       ] [ text "Accept "
                         , span [A.className "hidden-xs"] [text "this generous offer "]
                         , i [A.className "fa fa-fw fa-check"] []
                         ]
              ]
            ]
          ]
        ]
  where
    handleEnter :: E.KeyboardEvent -> Action
    handleEnter ev = if ev.keyCode == 13 then Accept else Nop

viewAccepted :: InvitationInfo -> Html Action
viewAccepted (InvitationInfo invitation) = viewLogo
                          $ span [ A.title "You chose wisely!" ]
                                 [ text $ "Your device <deviceName> is now a member of family: "
                                   <> invitation.invitationInfoFamily <> "!"
                                 ]

viewDeclined :: InvitationInfo -> Html Action
viewDeclined (InvitationInfo invitation) = viewLogo
                          $ span [ A.title "You chose wisely!" ]
                                 [ text $ "You did not join the stalker family: "
                                 , em [] [ text invitation.invitationInfoFamily ]
                                 , text "!"
                                 ]

module Gonimo.UI.AcceptInvitation where

import Gonimo.UI.Html
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Types as Gonimo
import Gonimo.WebAPI.Types as WebAPI
import Pux.Html.Attributes as A
import Pux.Html.Events as E
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.IO (IO)
import Control.Monad.Reader.Class (ask)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (get, put)
import Data.Bifunctor (lmap)
import Data.Either (Either(Right, Left))
import Data.Generic (gShow)
import Data.Lens (_Just)
import Data.Maybe (fromMaybe, isJust, isNothing, Maybe(..))
import Data.Tuple (Tuple(Tuple))
import Gonimo.Client.Types (GonimoError(UnexpectedAction), Gonimo, Settings, class ReportErrorAction)
import Gonimo.Pux (Component, makeChildData, liftChild, noEffects, onlyModify, Update, ToChild, runGonimo, ComponentType, class MonadComponent)
import Gonimo.Server.DbEntities (Invitation(Invitation))
import Gonimo.Server.Types (InvitationDelivery(EmailInvitation), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Key(Key), Secret(Secret))
import Gonimo.Util (fromMaybeM)
import Gonimo.WebAPI (deleteInvitationsByInvitationSecret, putInvitationsInfoByInvitationSecret, postFamilies, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (InvitationReply(InvitationReject, InvitationAccept), InvitationReply(InvitationReject, InvitationAccept), InvitationInfo(InvitationInfo), AuthData(AuthData))
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (em, button, input, p, h1, text, span, Html, img, div)
import Pux.Html.Attributes (offset)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Signal (constant, Signal)
import Prelude hiding (div)

type Props ps = { settings :: Settings | ps }

type State = Maybe StateImpl

type StateImpl = { invitationInfo :: InvitationInfo
                 , invitationSecret :: Secret
                 , accepted :: Maybe Boolean
                 }

init :: State
init = Nothing

data Action = LoadInvitation Secret
            | Init (Tuple Secret InvitationInfo)
            | Accept
            | Decline
            | SetAccepted Boolean
            | ReportError GonimoError
            | Nop

instance reportErrorActionAction :: ReportErrorAction Action where
  reportError = ReportError

update :: forall ps m. Action -> Component (Props ps) State (Array (IO Action))
update action = do
   r <- liftChild toJust (updateJust action)
   case r of
     Nothing -> updateNothing action
     Just v -> pure v
   -- myFromMaybeM (updateNothing action)
   -- $ liftChild toJust (updateJust action)

toJust :: forall ps. ToChild (Props ps) State (Props ps) StateImpl
toJust = do
  props <- ask
  pure $ makeChildData _Just props

updateNothing :: forall ps. Update (Props ps) State Action
updateNothing action = case action of
  LoadInvitation secret   -> runGonimo $ loadInvitation secret
  Init (Tuple secret inv) -> put ( Just { invitationInfo : inv, invitationSecret : secret, accepted : (Nothing :: Maybe Boolean) } ) *> pure []
  Nop                     -> noEffects
  ReportError err         -> noEffects
  _                       -> pure [ pure (ReportError $ UnexpectedAction "Received some Action but State is Nothing!") ]

updateJust :: forall ps. Update (Props ps) StateImpl Action
updateJust action = case action of
  LoadInvitation secret   -> runGonimo $ loadInvitation secret
  Init (Tuple secret inv) -> onlyModify $ _ { invitationInfo = inv, invitationSecret = secret, accepted = (Nothing :: Maybe Boolean)}
  Accept                  -> answerInvitation InvitationAccept
  Decline                 -> answerInvitation InvitationReject
  SetAccepted accepted'   -> onlyModify $ _ { accepted = Just accepted' }
  Nop                     -> noEffects
  ReportError err         -> noEffects

loadInvitation :: Secret -> Gonimo Action
loadInvitation secret = Init <<< Tuple secret <$> putInvitationsInfoByInvitationSecret secret

answerInvitation :: forall ps. InvitationReply -> ComponentType (Props ps) StateImpl Action
answerInvitation reply = do
  state <- get
  runGonimo $ do
    deleteInvitationsByInvitationSecret reply state.invitationSecret
    pure $ SetAccepted $ case reply of
      InvitationAccept  -> true
      InvitationReject  -> false

    --------------------------------------------------------------------------------

view :: State -> Html Action
view Nothing = viewLoading "Loading your invitation - stay tight ..."
view (Just state) = case state.accepted of
  Nothing    ->  viewAskUser state.invitationInfo
  Just true  ->  viewAccepted state.invitationInfo
  Just false ->  viewDeclined state.invitationInfo

viewAskUser :: InvitationInfo -> Html Action
viewAskUser (InvitationInfo invitation) =
    div []
        [ h1 []
             [ text "Gonimo Family Invitation!"]
        , p []
            [ text $ "You received an invitation to join family: "
            , em [] [ text invitation.invitationInfoFamily ]
            , text "!"
            ]
        , p []
            [ text $ "You got invited by a device answering to the name: "
            , em [] [ text invitation.invitationInfoSendingDevice ]
            , text "."
            ]

        , div [ E.onKeyUp handleEnter ]
              [ p []
                  [ text $ "Do you really want to join the almighty family \""
                    <> invitation.invitationInfoFamily <> "\"?"
                  ]
              , p []
                  [ text $ "Pick wisely! Gonimo is the most awesome baby monitor on the planet, but only with the right family!"
                  ]
              , p []
                [ button [ A.title "Hello my dear family!"
                          , E.onClick $ const $ Accept
                          ]
                          [ text "Accept" ]
                ]
              , p []
                  [ button [ A.title "... of this bloody stalker!"
                          , E.onClick $ const $ Decline
                          ]
                          [ text "Decline this generous offer"]
                  ]
              ]
          ]
  where
    handleEnter :: E.KeyboardEvent -> Action
    handleEnter ev = if ev.keyCode == 13 then Accept else Nop

viewAccepted :: InvitationInfo -> Html Action
viewAccepted (InvitationInfo invitation) = viewLogo
                          $ span [ A.title "You chose wisely!" ]
                                 [ text $ "Your device <deviceName> is now a member of family: "
                                   <> invitation.invitationInfoFamily <> "!"
                                 ]

viewDeclined :: InvitationInfo -> Html Action
viewDeclined (InvitationInfo invitation) = viewLogo
                          $ span [ A.title "You chose wisely!" ]
                                 [ text $ "You did not join the stalker family: "
                                 , em [] [ text invitation.invitationInfoFamily ]
                                 , text "!"
                                 ]


Fix tooltips for explicit imports

Fix tooltips for explicit imports

module IdePurescript.Modules (
    Module
  , initialModulesState
  , State
  , getMainModule
  , getModulesForFile
  , getUnqualActiveModules
  , getAllActiveModules
  , getQualModule
  , findImportInsertPos
  , addModuleImport
  , addExplicitImport
  , ImportResult(..)
  ) where

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Data.Array ((:), findLastIndex, filter, singleton, concatMap)
import Data.Either (either, Either(..))
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.String (split)
import Data.String.Regex as R
import Data.Foldable (elem)
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.FS.Aff as FS
import Node.Path (sep)
import Prelude
import PscIde as P
import PscIde.Command as C

data Module = Implicit String | Explicit String (Array String) | Qualified String String

derive instance moduleEq :: Eq Module

getModuleName :: Module -> String
getModuleName (Qualified _ m) = m
getModuleName (Implicit m) = m
getModuleName (Explicit m _) = m

type State =
  { main :: Maybe String
  , modules :: Array Module
  , identifiers :: Array String
  }

type Path = String

getMainModule :: String -> Maybe String
getMainModule text =
  case R.match regex text of
    Just [_, Just m] -> Just m
    _ -> Nothing
  where
  regex = R.regex """module\s+([\w.]+)""" $ R.noFlags { multiline = true }

getModulesForFile :: forall eff. Path -> String -> Aff (net :: P.NET | eff) State
getModulesForFile file fullText = do
  imports <- P.listImports file
  let modules = either (const []) (\(C.ImportList l) -> map mod l) imports
      main = getMainModule fullText
      identifiers = concatMap idents modules
  pure { main, modules, identifiers }
  where
  mod (C.Import { moduleName, qualifier: Nothing, importType: C.Explicit identifiers }) =
    Explicit moduleName identifiers
  mod (C.Import { moduleName, qualifier: Nothing }) = Implicit moduleName
  mod (C.Import { moduleName, qualifier: Just qual }) = Qualified qual moduleName

  idents (Explicit _ x) = x
  idents _ = []

getUnqualActiveModules :: State -> Maybe String -> Array String
getUnqualActiveModules {modules, main} ident =
  map getModuleName $ maybe [] (singleton <<< Implicit) main ++ filter include modules
  where
  include (Qualified _ _) = false
  include (Explicit _ idents) = maybe false (_ `elem` idents) ident
  include (Implicit _) = true

getAllActiveModules  :: State -> Array String
getAllActiveModules {modules, main} =
  map getModuleName $ maybe [] (singleton <<< Implicit) main ++ modules

getQualModule :: String -> State -> Array String
getQualModule qualifier {modules} =
  map getModuleName $ filter (qual qualifier) modules
  where
  qual q (Qualified q' _) = q == q'
  qual _ _ = false

initialModulesState :: State
initialModulesState =  { main: Nothing, modules: [], identifiers: [] }

findImportInsertPos :: String -> Int
findImportInsertPos text =
  let regex = R.regex """^(module|import) [A-Z][^(]*($|\([^()]*\))""" R.noFlags
      lines = split "\n" text
      res = fromMaybe 0 $ findLastIndex (R.test regex) lines
  in res+1

foreign import tmpDir :: forall eff. Eff (fs :: FS | eff) String

data ImportResult = UpdatedImports String | AmbiguousImport (Array C.Completion) | FailedImport

withTempFile :: forall eff. String -> String -> (String -> Aff (net :: P.NET, fs :: FS | eff) (Either String C.ImportResult))
  -> Aff (net :: P.NET, fs :: FS | eff) ImportResult
withTempFile fileName text action = do
  dir <- liftEff tmpDir
  let name = R.replace (R.regex "[\\/\\\\]" (R.noFlags { global = true })) "-" fileName
      tmpFile = dir ++ sep ++ "ide-purescript." ++ name ++ ".purs"
  FS.writeTextFile UTF8 tmpFile text
  res <- action tmpFile
  answer <- case res of
    Right (C.SuccessFile _) -> UpdatedImports <$> FS.readTextFile UTF8 tmpFile
    Right (C.MultipleResults a) -> pure $ AmbiguousImport a
    _ -> pure FailedImport
  FS.unlink tmpFile
  pure answer

addModuleImport :: forall eff. State -> String -> String -> String
  -> Aff (net :: P.NET, fs :: FS | eff) (Maybe { state :: State, result :: String })
addModuleImport state fileName text moduleName =
  case shouldAdd of
    false -> pure Nothing
    true -> do
      res <- withTempFile fileName text addImport
      pure $ case res of
        UpdatedImports result -> Just { state, result }
        _ -> Nothing
  where
  addImport tmpFile = P.implicitImport tmpFile (Just tmpFile) [] moduleName
  shouldAdd =
    state.main /= Just moduleName && Implicit moduleName `elem` state.modules

addExplicitImport :: forall eff. State -> String -> String -> (Maybe String) -> String
  -> Aff (net :: P.NET, fs :: FS | eff) { state :: State, result :: ImportResult }
addExplicitImport state fileName text moduleName identifier =
  case shouldAdd of
    false -> pure { state, result: FailedImport }
    true -> do
      result <- withTempFile fileName text addImport
      let state' = case result of
            UpdatedImports _ -> state { identifiers = identifier : state.identifiers }
            _ -> state
      pure { result, state: state' }
  where
    addImport tmpFile = P.explicitImport tmpFile (Just tmpFile) filters identifier
    filters = case moduleName of
                Nothing -> []
                Just mn -> [C.ModuleFilter [mn]]
    isThisModule = case moduleName of
      Just _ -> moduleName == state.main
      _ -> false

    shouldAdd = not isThisModule
      && not (identifier `elem` state.identifiers)
      && isIdent identifier
      && maybe true (\mn -> not $ Implicit mn `elem` state.modules) moduleName
    isIdent = R.test (R.regex """^[a-z_]\S*$""" R.noFlags)

module IdePurescript.Modules (
    Module
  , initialModulesState
  , State
  , getMainModule
  , getModulesForFile
  , getUnqualActiveModules
  , getAllActiveModules
  , getQualModule
  , findImportInsertPos
  , addModuleImport
  , addExplicitImport
  , ImportResult(..)
  ) where

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Data.Array (elemIndex, concatMap, filter, singleton, findLastIndex, (:))
import Data.Either (either, Either(..))
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.String (split)
import Data.String.Regex as R
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.FS.Aff as FS
import Node.Path (sep)
import Prelude
import PscIde as P
import PscIde.Command as C

data Module = Implicit String | Explicit String (Array String) | Qualified String String

derive instance moduleEq :: Eq Module

getModuleName :: Module -> String
getModuleName (Qualified _ m) = m
getModuleName (Implicit m) = m
getModuleName (Explicit m _) = m

type State =
  { main :: Maybe String
  , modules :: Array Module
  , identifiers :: Array String
  }

type Path = String

getMainModule :: String -> Maybe String
getMainModule text =
  case R.match regex text of
    Just [_, Just m] -> Just m
    _ -> Nothing
  where
  regex = R.regex """module\s+([\w.]+)""" $ R.noFlags { multiline = true }

getModulesForFile :: forall eff. Path -> String -> Aff (net :: P.NET | eff) State
getModulesForFile file fullText = do
  imports <- P.listImports file
  let modules = either (const []) (\(C.ImportList l) -> map mod l) imports
      main = getMainModule fullText
      identifiers = concatMap idents modules
  pure { main, modules, identifiers }
  where
  mod (C.Import { moduleName, qualifier: Nothing, importType: C.Explicit identifiers }) =
    Explicit moduleName identifiers
  mod (C.Import { moduleName, qualifier: Nothing }) = Implicit moduleName
  mod (C.Import { moduleName, qualifier: Just qual }) = Qualified qual moduleName

  idents (Explicit _ x) = x
  idents _ = []

getUnqualActiveModules :: State -> Array String
getUnqualActiveModules {modules, main} =
  map getModuleName $ maybe [] (singleton <<< Implicit) main ++ filter (not <<< isQualified) modules
  where
  isQualified (Qualified _ _) = true
  isQualified _ = false

getAllActiveModules  :: State -> Array String
getAllActiveModules {modules, main} =
  map getModuleName $ maybe [] (singleton <<< Implicit) main ++ modules

getQualModule :: String -> State -> Array String
getQualModule qualifier {modules} =
  map getModuleName $ filter (qual qualifier) modules
  where
  qual q (Qualified q' _) = q == q'
  qual _ _ = false

initialModulesState :: State
initialModulesState =  { main: Nothing, modules: [], identifiers: [] }

findImportInsertPos :: String -> Int
findImportInsertPos text =
  let regex = R.regex """^(module|import) [A-Z][^(]*($|\([^()]*\))""" R.noFlags
      lines = split "\n" text
      res = fromMaybe 0 $ findLastIndex (R.test regex) lines
  in res+1

foreign import tmpDir :: forall eff. Eff (fs :: FS | eff) String

data ImportResult = UpdatedImports String | AmbiguousImport (Array C.Completion) | FailedImport

withTempFile :: forall eff. String -> String -> (String -> Aff (net :: P.NET, fs :: FS | eff) (Either String C.ImportResult))
  -> Aff (net :: P.NET, fs :: FS | eff) ImportResult
withTempFile fileName text action = do
  dir <- liftEff tmpDir
  let name = R.replace (R.regex "[\\/\\\\]" (R.noFlags { global = true })) "-" fileName
      tmpFile = dir ++ sep ++ "ide-purescript." ++ name ++ ".purs"
  FS.writeTextFile UTF8 tmpFile text
  res <- action tmpFile
  answer <- case res of
    Right (C.SuccessFile _) -> UpdatedImports <$> FS.readTextFile UTF8 tmpFile
    Right (C.MultipleResults a) -> pure $ AmbiguousImport a
    _ -> pure FailedImport
  FS.unlink tmpFile
  pure answer

addModuleImport :: forall eff. State -> String -> String -> String
  -> Aff (net :: P.NET, fs :: FS | eff) (Maybe { state :: State, result :: String })
addModuleImport state fileName text moduleName =
  case shouldAdd of
    false -> pure Nothing
    true -> do
      res <- withTempFile fileName text addImport
      pure $ case res of
        UpdatedImports result -> Just { state, result }
        _ -> Nothing
  where
  addImport tmpFile = P.implicitImport tmpFile (Just tmpFile) [] moduleName
  shouldAdd =
    state.main /= Just moduleName && Implicit moduleName `elem` state.modules

elem x l = elemIndex x l /= Nothing

addExplicitImport :: forall eff. State -> String -> String -> (Maybe String) -> String
  -> Aff (net :: P.NET, fs :: FS | eff) { state :: State, result :: ImportResult }
addExplicitImport state fileName text moduleName identifier =
  case shouldAdd of
    false -> pure { state, result: FailedImport }
    true -> do
      result <- withTempFile fileName text addImport
      let state' = case result of
            UpdatedImports _ -> state { identifiers = identifier : state.identifiers }
            _ -> state
      pure { result, state: state' }
  where
    addImport tmpFile = P.explicitImport tmpFile (Just tmpFile) filters identifier
    filters = case moduleName of
                Nothing -> []
                Just mn -> [C.ModuleFilter [mn]]
    isThisModule = case moduleName of
      Just _ -> moduleName == state.main
      _ -> false

    shouldAdd = not isThisModule
      && not (identifier `elem` state.identifiers)
      && isIdent identifier
      && maybe true (\mn -> not $ Implicit mn `elem` state.modules) moduleName
    isIdent = R.test (R.regex """^[a-z_]\S*$""" R.noFlags)


Doesn't do what it says on the tin

Doesn't do what it says on the tin

-- http://www.w3.org/TR/html5
module DOM.HTML.Types where

import Prelude

import DOM.Event.Types
import DOM.Node.Types

import qualified Unsafe.Coerce as U

foreign import data Window :: *

windowToEventTarget :: Window -> EventTarget
windowToEventTarget = U.unsafeCoerce

foreign import data HTMLDocument :: *

htmlDocumentToDocument :: HTMLDocument -> Document
htmlDocumentToDocument = U.unsafeCoerce

htmlDocumentToEventTarget :: HTMLDocument -> EventTarget
htmlDocumentToEventTarget = U.unsafeCoerce

foreign import data HTMLElement :: *

htmlElementToElement :: HTMLElement -> Element
htmlElementToElement = U.unsafeCoerce

htmlElementToParentNode :: HTMLElement -> ParentNode
htmlElementToParentNode = U.unsafeCoerce

htmlElementToNonDocumentTypeChildNode :: HTMLElement -> NonDocumentTypeChildNode
htmlElementToNonDocumentTypeChildNode = U.unsafeCoerce

htmlElementToNode :: HTMLElement -> Node
htmlElementToNode = U.unsafeCoerce

htmlElementToEventTarget :: HTMLElement -> EventTarget
htmlElementToEventTarget = U.unsafeCoerce

-- http://www.w3.org/TR/html5
module DOM.HTML.Types where

import Prelude

import DOM.Event.Types
import DOM.Node.Types

import qualified Unsafe.Coerce as U

foreign import data Window :: *

windowToEventTarget :: Window -> EventTarget
windowToEventTarget = U.unsafeCoerce

foreign import data HTMLDocument :: *

htmlDocumentToDocument :: HTMLDocument -> Document
htmlDocumentToDocument = U.unsafeCoerce

htmlDocumentToEventTarget :: HTMLDocument -> EventTarget
htmlDocumentToEventTarget = U.unsafeCoerce

foreign import data HTMLElement :: *

htmlElementToElement :: HTMLElement -> Element
htmlElementToElement = U.unsafeCoerce

htmlElementToParentNode :: Element -> ParentNode
htmlElementToParentNode = U.unsafeCoerce

htmlElementToNonDocumentTypeChildNode :: Element -> NonDocumentTypeChildNode
htmlElementToNonDocumentTypeChildNode = U.unsafeCoerce

htmlElementToNode :: HTMLElement -> Node
htmlElementToNode = U.unsafeCoerce

htmlElementToEventTarget :: HTMLElement -> EventTarget
htmlElementToEventTarget = U.unsafeCoerce


Avoid Maybe encoding issue

Avoid Maybe encoding issue

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

data ListType = LoadedModules | Imports String | AvailableModules

type FileName = String
data ImportCommand = AddImplicitImport String | AddImport 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) =
    commandWrapper "rebuild" (
      "file" := encodeJson file
      ~> 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 (AddImport mod) =
    "importCommand" := "addImport"
    ~> "identifier" := encodeJson mod
    ~> 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))

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" := encodeJson 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

data ListType = LoadedModules | Imports String | AvailableModules

type FileName = String
data ImportCommand = AddImplicitImport String | AddImport 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) =
    commandWrapper "rebuild" (
      "file" := encodeJson file
      ~> 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 (AddImport mod) =
    "importCommand" := "addImport"
    ~> "identifier" := encodeJson mod
    ~> 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))


fix lag in deploy

fix lag in deploy

-- | File component main handler
module Controller.File (
  handler,
  getDirectories,
  selectThis,
  rename,
  checkRename,
  renameItemClicked
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Exception
import Control.Monad.Error.Class
import Control.Monad.Eff.Random
import Control.Monad.Aff.Class
import Control.Monad.Trans
import Control.Plus (empty)

import DOM
import Data.Maybe
import Data.Tuple
import Data.Either
import Data.Foldable
import Data.Traversable
import Control.Apply

import Data.DOM.Simple.Types
import Data.DOM.Simple.Document
import Data.DOM.Simple.Window
import Data.DOM.Simple.Element
import EffectTypes

import qualified Utils as U
import qualified Utils.Event as Ue
import qualified Utils.File as Uf
import qualified Data.Array as A
import qualified Halogen as Hl
import qualified Control.Timer as Tm
import qualified Config as Config
import qualified Control.Monad.Aff as Aff
import qualified Text.SlamSearch as S
import qualified Routing.Hash as Rh
import qualified Data.String as Str
import qualified Driver.File as Cd
import qualified Network.HTTP.Affjax as Af

import qualified Data.String.Regex as Rgx
import qualified Model.File as M
import qualified Model.Item as Mi
import qualified Model.Notebook as Mn
import qualified Model.Resource as Mr
import qualified Api.Fs as Api
import qualified Control.UI.ZClipboard as Z

import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import qualified Halogen.HTML.Events.Types as Et

handler :: forall e. M.Request -> E.Event (FileAppEff e) M.Input
handler r =
  case r of
    M.Delete item -> E.async $ do
      Api.deleteItem item
      pure $ M.Remove item

    M.CreateNotebook state -> do
      let name = getNewName Config.newNotebookName state
      path <- liftEff $ Cd.getPath <$> Rh.getHash
      let notebook = Mi.initNotebook{root = path, name = name, phantom = true}
      -- immidiately updating state and then
      (pure $ M.ItemAdd notebook) `E.andThen` \_ -> do
        f <- liftAff $ Aff.attempt $ Api.makeNotebook notebook Mn.newNotebook
        (pure $ M.Remove notebook) `E.andThen` \_ ->  do
          case f of
            Left _ -> empty
            Right _ -> do
              liftEff $ open notebook{phantom = false} false
              -- and add real notebook to list
              pure $ M.ItemAdd notebook{phantom = false}

    M.FileListChanged node state -> do
      fileArr <- Uf.fileListToArray <$> (liftAff $ Uf.files node)
      liftEff $ U.clearValue node
      case A.head fileArr of
        Nothing ->
          let err :: Aff.Aff (FileAppEff e) M.Input
              err = throwError $ error "empty filelist"
          in liftAff err
        Just file -> do
          let newReader :: Eff (FileAppEff e) _
              newReader = Uf.newReaderEff

              readAsBinaryString :: _ -> _ -> Aff.Aff (FileAppEff e) _
              readAsBinaryString = Uf.readAsBinaryString

          path <- liftEff (Cd.getPath <$> Rh.getHash)
          name <- flip getNewName state <$> (liftEff $ Uf.name file)
          let fileItem = Mi.initFile{root = path, name = name, phantom = true}

          reader <- liftEff newReader
          content <- liftAff $ readAsBinaryString file reader

          (pure $ M.ItemAdd fileItem) `E.andThen` \_ -> do
            f <- liftAff $ Aff.attempt $ Api.makeFile fileItem content
            (pure $ M.Remove fileItem) `E.andThen` \_ -> do
              case f of
                Left _ -> empty
                Right _ -> do
                  liftEff $ open fileItem{phantom = false} false
                  pure $ M.ItemAdd fileItem{phantom = false}

    M.Move item -> do
      (pure $ M.SetDialog (Just (M.RenameDialog $ M.initialRenameDialog item)))
        `E.andThen` \_ -> do
        getDirectories "/"

    M.SetSort sort -> do
      liftEff $ Rh.modifyHash $ Cd.updateSort sort
      empty

            -- opens item
    M.Open item -> do
      liftEff $ case item.resource of
        Mr.Directory ->
          moveDown item
        Mr.Database ->
          moveDown item
        Mr.File ->
          open item true
        Mr.Table ->
          open item true
        Mr.Notebook ->
          open item false
      empty

            -- clicked on breadcrumb
    M.Breadcrumb b -> do
      liftEff $ Rh.modifyHash $ Cd.updatePath b.link
      empty

    -- clicked on _Folder_ link, create phantom folder
    M.CreateFolder state -> do
      let name = getNewName Config.newFolderName state
      path <- liftEff (Cd.getPath <$> Rh.getHash)
      pure $ M.ItemAdd $ Mi.initDirectory{root = path, name = name}

    -- clicked on _File_ link triggering file uploading
    M.UploadFile node _ -> do
      let el = U.convertToElement node
      mbInput <- liftEff $ querySelector "input" el
      case mbInput of
        Nothing -> empty
        Just input -> do
          liftEff $ Ue.raiseEvent "click" input
          empty

    M.MountDatabase _ ->
      pure $ M.SetDialog (Just M.MountDialog)

    M.Configure _ -> do
      pure $ M.SetDialog (Just M.ConfigureDialog)

    M.SearchSubmit s p -> do
      liftEff $ maybe (pure unit) Tm.clearTimeout s.timeout
      setQE (s.nextValue <> " +path:" <> p)

    M.SearchClear isSearching search -> do
      liftEff $ maybe (pure unit) Tm.clearTimeout search.timeout
      if isSearching then do
        rnd <- show <$> (liftEff $ randomInt 1000000 2000000)
        liftEff (Rh.modifyHash $ Cd.updateSalt rnd)
        pure $ M.Loading false
        else
        setQE "path:/"

    M.SearchChange search ch p -> E.async $ Aff.makeAff $ \_ k -> do
      k $ M.SearchNextValue ch
      maybe (pure unit) Tm.clearTimeout search.timeout
      tim <- Tm.timeout Config.searchTimeout $ do
        E.runEvent (const $ pure unit) (const $ pure unit) $
          setQE (ch <> " path:\"" <> p <> "\"")
      k $ M.SearchTimeout tim
      k $ M.SearchValidation true

-- ATTENTION
-- This works too slow
--      (pure $ M.SearchNextValue ch) `E.andThen` \_ -> do
--        tim <- liftEff $ Tm.timeout Config.searchTimeout $ do
--          E.runEvent (const $ pure unit) (const $ pure unit) $
--            setQE (ch <> " path:\"" <> p <> "\"")
--        (pure $ M.SearchTimeout tim) `E.andThen` \_ -> do
--          pure $ M.SearchValidation true

    -- ATTENTION
    -- This all should be moved to `initializer`
    -- ATTENTION
    M.Share item -> E.async $ Aff.makeAff $ \_ k -> do
      url <- itemURL item
      k $ M.SetDialog (Just $ M.ShareDialog url)
      mbCopy <- document globalWindow >>= getElementById "copy-button"
      case mbCopy of
        Nothing -> pure unit
        Just btn -> void do
          Z.make btn >>= Z.onCopy (Z.setData "text/plain" url)

  where itemURL item = do
          loc <- U.locationString
          hash <- Rh.getHash
          let newUrl = loc <> case item.resource of
                Mr.File -> foldl (<>) ""
                     [Config.notebookUrl,
                      "#", Mi.itemPath item,
                      "/view",
                      "/?q=", U.encodeURIComponent ("select * from ...")
                     ]
                Mr.Notebook -> foldl (<>) ""
                     [Config.notebookUrl,
                      "#", Mi.itemPath item,
                      "/view"]
                _ -> "#" <> Cd.updatePath (item.root <> "/" <> item.name) hash
          pure $ newUrl

        setQE q = do
          case S.mkQuery q of
            Left _ | q /= "" -> pure $ M.SearchValidation false
            Right _ -> do
              liftEff (Rh.modifyHash $ Cd.updateQ q)
              pure $ M.SearchValidation true
            _ -> do
              liftEff (Rh.modifyHash $ Cd.updateQ "")
              pure $ M.SearchValidation true

        -- open dir or db
        moveDown item = Rh.modifyHash $ Cd.updatePath (item.root <> "/" <> item.name <> "/")
        -- open notebook or file
        open item isNew = U.newTab $ foldl (<>) ""
                          ([Config.notebookUrl,
                            "#", Mi.itemPath item,
                            "/edit"] <>
                             if isNew then
                             ["/?q=", U.encodeURIComponent ("select * from ...")]
                           else [])
        -- get fresh name for this state
        getNewName :: String -> M.State -> String
        getNewName name state =
          if A.findIndex (\x -> x.name == name) state.items /= -1 then
            getNewName' name 1
            else name
          where getNewName' name i =
                  -- Str.split and Str.joinWith work with []
                  -- converting from/to List will be too expensive
                  case Str.split "." name of
                    [] -> ""
                    body:suffixes ->
                      let newName = Str.joinWith "." $ (body <> show i):suffixes
                      in if A.findIndex
                            (\x -> x.name == newName)
                            state.items /= -1
                         then getNewName' name (i + 1)
                         else newName

getDirectories :: forall e. String -> E.Event (FileAppEff e) M.Input
getDirectories path = do
  ei <- liftAff $ Aff.attempt $ Api.listing path
  case ei of
    Right items -> do
      let children = A.filter (\x -> x.resource == Mr.Directory ||
                                   x.resource == Mr.Database) items
          directories = (\x -> path <> x.name <> "/") <$> children

      (pure $  M.AddRenameDirs directories) `E.andThen` \_ ->
        fold (getDirectories <$> directories)
    _ -> empty

selectThis :: forall e o. Et.Event (|o) ->
              E.EventHandler (E.Event (dom :: DOM|e) M.Input)
selectThis ev =
  pure $ (E.async $ Aff.makeAff \_ _ -> U.select ev.target)

import Debug.Foreign

rename :: forall e. Mi.Item -> String ->
          E.EventHandler (E.Event (FileAppEff e) M.Input)
rename item dest = pure do
  let o = fprintUnsafe dest
      move :: Aff.Aff (FileAppEff e) String
      move = Api.moveItem item dest
  errorString <- liftAff $ move
  (pure $ M.RenameError errorString) `E.andThen` \_ -> do
    case errorString of
      "" -> do liftEff U.reload
               empty
      _ -> empty

checkRename :: forall e. String -> M.RenameDialogRec ->
               E.EventHandler (E.Event (FileAppEff e) M.Input)
checkRename name r = pure do
  if name == ""
    then pure $ M.RenameError "Please, enter new name"
    else
    (if Str.indexOf "/" name /= -1
     then pure $ M.RenameError "Incorrect File Name"
     else checkList name r.selectedContent) `E.andThen` \_ ->
    pure $ M.RenameChanged name

renameItemClicked :: forall e. String -> String ->
                     E.EventHandler (E.Event (FileAppEff e) M.Input)
renameItemClicked target dir = pure $ do
  (pure $ M.SetRenameSelected dir) `E.andThen` \_ -> do
    items <- liftAff $ Api.listing dir
    let list = _.name <$> items
    (pure $ M.RenameSelectedContent list) `E.andThen` \_ ->
      checkList target list

checkList :: forall e. String -> [String] -> E.Event (FileAppEff e) M.Input
checkList target list =
  pure case A.elemIndex target list of
    -1 -> M.RenameError ""
    _ ->  M.RenameError "Item with such name exists in target folder"

-- | File component main handler
module Controller.File (
  handler,
  getDirectories,
  selectThis,
  rename,
  checkRename,
  renameItemClicked
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Exception
import Control.Monad.Error.Class
import Control.Monad.Eff.Random
import Control.Monad.Aff.Class
import Control.Monad.Trans
import Control.Plus (empty)

import DOM
import Data.Maybe
import Data.Tuple
import Data.Either
import Data.Foldable
import Data.Traversable
import Control.Apply

import Data.DOM.Simple.Types
import Data.DOM.Simple.Document
import Data.DOM.Simple.Window
import Data.DOM.Simple.Element
import EffectTypes

import qualified Utils as U
import qualified Utils.Event as Ue
import qualified Utils.File as Uf
import qualified Data.Array as A
import qualified Halogen as Hl
import qualified Control.Timer as Tm
import qualified Config as Config
import qualified Control.Monad.Aff as Aff
import qualified Text.SlamSearch as S
import qualified Routing.Hash as Rh
import qualified Data.String as Str
import qualified Driver.File as Cd
import qualified Network.HTTP.Affjax as Af

import qualified Data.String.Regex as Rgx
import qualified Model.File as M
import qualified Model.Item as Mi
import qualified Model.Notebook as Mn
import qualified Model.Resource as Mr
import qualified Api.Fs as Api
import qualified Control.UI.ZClipboard as Z

import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import qualified Halogen.HTML.Events.Types as Et

handler :: forall e. M.Request -> E.Event (FileAppEff e) M.Input
handler r =
  case r of
    M.Delete item -> E.async $ do
      Api.deleteItem item
      pure $ M.Remove item

    M.CreateNotebook state -> do
      let name = getNewName Config.newNotebookName state
      path <- liftEff $ Cd.getPath <$> Rh.getHash
      let notebook = Mi.initNotebook{root = path, name = name, phantom = true}
      -- immidiately updating state and then
      (pure $ M.ItemAdd notebook) `E.andThen` \_ -> do
        f <- liftAff $ Aff.attempt $ Api.makeNotebook notebook Mn.newNotebook
        (pure $ M.Remove notebook) `E.andThen` \_ ->  do
          case f of
            Left _ -> empty
            Right _ -> do
              liftEff $ open notebook{phantom = false} false
              -- and add real notebook to list
              pure $ M.ItemAdd notebook{phantom = false}

    M.FileListChanged node state -> do
      fileArr <- Uf.fileListToArray <$> (liftAff $ Uf.files node)
      liftEff $ U.clearValue node
      case A.head fileArr of
        Nothing ->
          let err :: Aff.Aff (FileAppEff e) M.Input
              err = throwError $ error "empty filelist"
          in liftAff err
        Just file -> do
          let newReader :: Eff (FileAppEff e) _
              newReader = Uf.newReaderEff

              readAsBinaryString :: _ -> _ -> Aff.Aff (FileAppEff e) _
              readAsBinaryString = Uf.readAsBinaryString

          path <- liftEff (Cd.getPath <$> Rh.getHash)
          name <- flip getNewName state <$> (liftEff $ Uf.name file)
          let fileItem = Mi.initFile{root = path, name = name, phantom = true}

          reader <- liftEff newReader
          content <- liftAff $ readAsBinaryString file reader

          (pure $ M.ItemAdd fileItem) `E.andThen` \_ -> do
            f <- liftAff $ Aff.attempt $ Api.makeFile fileItem content
            (pure $ M.Remove fileItem) `E.andThen` \_ -> do
              case f of
                Left _ -> empty
                Right _ -> do
                  liftEff $ open fileItem{phantom = false} false
                  pure $ M.ItemAdd fileItem{phantom = false}

    M.Move item -> do
      (pure $ M.SetDialog (Just (M.RenameDialog $ M.initialRenameDialog item)))
        `E.andThen` \_ -> do
        getDirectories "/"

    M.SetSort sort -> do
      liftEff $ Rh.modifyHash $ Cd.updateSort sort
      empty

            -- opens item
    M.Open item -> do
      liftEff $ case item.resource of
        Mr.Directory ->
          moveDown item
        Mr.Database ->
          moveDown item
        Mr.File ->
          open item true
        Mr.Table ->
          open item true
        Mr.Notebook ->
          open item false
      empty

            -- clicked on breadcrumb
    M.Breadcrumb b -> do
      liftEff $ Rh.modifyHash $ Cd.updatePath b.link
      empty

    -- clicked on _Folder_ link, create phantom folder
    M.CreateFolder state -> do
      let name = getNewName Config.newFolderName state
      path <- liftEff (Cd.getPath <$> Rh.getHash)
      pure $ M.ItemAdd $ Mi.initDirectory{root = path, name = name}

    -- clicked on _File_ link triggering file uploading
    M.UploadFile node _ -> do
      let el = U.convertToElement node
      mbInput <- liftEff $ querySelector "input" el
      case mbInput of
        Nothing -> empty
        Just input -> do
          liftEff $ Ue.raiseEvent "click" input
          empty

    M.MountDatabase _ ->
      pure $ M.SetDialog (Just M.MountDialog)

    M.Configure _ -> do
      pure $ M.SetDialog (Just M.ConfigureDialog)

    M.SearchSubmit s p -> do
      liftEff $ maybe (pure unit) Tm.clearTimeout s.timeout
      setQE (s.nextValue <> " +path:" <> p)

    M.SearchClear isSearching search -> do
      liftEff $ maybe (pure unit) Tm.clearTimeout search.timeout
      if isSearching then do
        rnd <- show <$> (liftEff $ randomInt 1000000 2000000)
        liftEff (Rh.modifyHash $ Cd.updateSalt rnd)
        pure $ M.Loading false
        else
        setQE "path:/"

    M.SearchChange search ch p -> E.async $ Aff.makeAff $ \_ k -> do
      k $ M.SearchNextValue ch
      maybe (pure unit) Tm.clearTimeout search.timeout
      tim <- Tm.timeout Config.searchTimeout $ do
        E.runEvent (const $ pure unit) (const $ pure unit) $
          setQE (ch <> " path:\"" <> p <> "\"")
      k $ M.SearchTimeout tim
      k $ M.SearchValidation true

-- ATTENTION
-- This works too slow
--      (pure $ M.SearchNextValue ch) `E.andThen` \_ -> do
--        tim <- liftEff $ Tm.timeout Config.searchTimeout $ do
--          E.runEvent (const $ pure unit) (const $ pure unit) $
--            setQE (ch <> " path:\"" <> p <> "\"")
--        (pure $ M.SearchTimeout tim) `E.andThen` \_ -> do
--          pure $ M.SearchValidation true

    -- ATTENTION
    -- This all should be moved to `initializer`
    -- ATTENTION
    M.Share item -> E.async $ Aff.makeAff $ \_ k -> do
      url <- itemURL item
      k $ M.SetDialog (Just $ M.ShareDialog url)
      mbCopy <- document globalWindow >>= getElementById "copy-button"
      case mbCopy of
        Nothing -> pure unit
        Just btn -> void do
          Z.make btn >>= Z.onCopy (Z.setData "text/plain" url)

  where itemURL item = do
          loc <- U.locationString
          hash <- Rh.getHash
          let newUrl = loc <> case item.resource of
                Mr.File -> foldl (<>) ""
                     [Config.notebookUrl,
                      "#", Mi.itemPath item,
                      "/view",
                      "/?q=", U.encodeURIComponent ("select * from ...")
                     ]
                Mr.Notebook -> foldl (<>) ""
                     [Config.notebookUrl,
                      "#", Mi.itemPath item,
                      "/view"]
                _ -> "#" <> Cd.updatePath (item.root <> "/" <> item.name) hash
          pure $ newUrl

        setQE q = do
          case S.mkQuery q of
            Left _ | q /= "" -> pure $ M.SearchValidation false
            Right _ -> do
              liftEff (Rh.modifyHash $ Cd.updateQ q)
              pure $ M.SearchValidation true
            _ -> do
              liftEff (Rh.modifyHash $ Cd.updateQ "")
              pure $ M.SearchValidation true

        -- open dir or db
        moveDown item = Rh.modifyHash $ Cd.updatePath (item.root <> "/" <> item.name <> "/")
        -- open notebook or file
        open item isNew = U.newTab $ foldl (<>) ""
                          ([Config.notebookUrl,
                            "#", Mi.itemPath item,
                            "/edit"] <>
                             if isNew then
                             ["/?q=", U.encodeURIComponent ("select * from ...")]
                           else [])
        -- get fresh name for this state
        getNewName :: String -> M.State -> String
        getNewName name state =
          if A.findIndex (\x -> x.name == name) state.items /= -1 then
            getNewName' name 1
            else name
          where getNewName' name i =
                  -- Str.split and Str.joinWith work with []
                  -- converting from/to List will be too expensive
                  case Str.split "." name of
                    [] -> ""
                    body:suffixes ->
                      let newName = Str.joinWith "." $ (body <> show i):suffixes
                      in if A.findIndex
                            (\x -> x.name == newName)
                            state.items /= -1
                         then getNewName' name (i + 1)
                         else newName

getDirectories :: forall e. String -> E.Event (FileAppEff e) M.Input
getDirectories path = do
  ei <- liftAff $ Aff.attempt $ Api.listing path
  case ei of
    Right items -> do
      let children = A.filter (\x -> x.resource == Mr.Directory ||
                                   x.resource == Mr.Database) items
          directories = (\x -> path <> x.name <> "/") <$> children

      (pure $  M.AddRenameDirs directories) `E.andThen` \_ ->
        fold (getDirectories <$> directories)
    _ -> empty

selectThis :: forall e o. Et.Event (|o) ->
              E.EventHandler (E.Event (dom :: DOM|e) M.Input)
selectThis ev =
  pure $ (E.async $ Aff.makeAff \_ _ -> U.select ev.target)

import Debug.Foreign

rename :: forall e. Mi.Item -> String ->
          E.EventHandler (E.Event (FileAppEff e) M.Input)
rename item dest = pure do
  let o = fprintUnsafe dest
      move :: Aff.Aff (FileAppEff e) String
      move = Api.moveItem item dest
  errorString <- liftAff $ move
  (pure $ M.RenameError errorString) `E.andThen` \_ -> do
    case errorString of
      "" -> do liftEff U.reload
               empty
      _ -> empty

checkRename :: forall e. String -> M.RenameDialogRec ->
               E.EventHandler (E.Event (FileAppEff e) M.Input)
checkRename name r = pure do
  if name == ""
    then pure $ M.RenameError "Please, enter new name"
    else
    (if Str.indexOf "/" name /= -1
     then pure $ M.RenameError "Incorrect File Name"
     else checkList name r.selectedContent) `E.andThen` \_ ->
    pure $ M.RenameChanged name

renameItemClicked :: forall e. String -> String ->
                     E.EventHandler (E.Event (FileAppEff e) M.Input)
renameItemClicked target dir = pure $ do
  items <- liftAff $ Api.listing dir
  let list = _.name <$> items
  (pure $ M.RenameSelectedContent list) `E.andThen` \_ ->
      (pure $ M.SetRenameSelected dir) `E.andThen` \_ ->
      checkList target list

checkList :: forall e. String -> [String] -> E.Event (FileAppEff e) M.Input
checkList target list =
  pure case A.elemIndex target list of
    -1 -> M.RenameError ""
    _ ->  M.RenameError "Item with such name exists in target folder"


`mouseButton` might want to actually return the signal it produces.

module Signal.DOM
  ( animationFrame
  , keyPressed
  , mouseButton
  , touch
  , tap
  , mousePos
  , CoordinatePair(..)
  , Touch(..)
  ) where

import Control.Monad.Eff (Eff(..))
import Control.Timer (Timer(..))
import Data.Function
import DOM (DOM(..))
import Signal (constant, Signal(..), (~>), unwrap)
import Signal.Time (now, Time(..))

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

foreign import keyPressedP """
  function keyPressedP(constant, keyCode) {
    return function() {
      var out = constant(false);
      window.addEventListener("keydown", function(e) {
        if (e.keyCode === keyCode) out.set(true);
      });
      window.addEventListener("keyup", function(e) {
        if (e.keyCode === keyCode) out.set(false);
      });
      return out;
    };
  }""" :: forall e c. Fn2 (c -> Signal c) Number (Eff (dom :: DOM | e) (Signal Boolean))

keyPressed :: forall e. Number -> Eff (dom :: DOM | e) (Signal Boolean)
keyPressed = runFn2 keyPressedP constant

foreign import mouseButtonP """
  function mouseButtonP(constant, button) {
    return function() {
      var out = constant(false);
      window.addEventListener("mousedown", function(e) {
        if (e.button === button) out.set(true);
      });
      window.addEventListener("mouseup", function(e) {
        if (e.button === button) out.set(false);
      });
      return out;
    };
  }""" :: forall e c. Fn2 (c -> Signal c) Number (Eff (dom :: DOM | e) (Signal Boolean))

mouseButton :: forall e. Number -> Eff (dom :: DOM | e) (Signal Boolean)
mouseButton = runFn2 mouseButtonP constant

type Touch = { id :: String
             , screenX :: Number, screenY :: Number
             , clientX :: Number, clientY :: Number
             , pageX :: Number, pageY :: Number
             , radiusX :: Number, radiusY :: Number
             , rotationAngle :: Number, force :: Number }

foreign import touchP """
  function touchP(constant) {
    var out = constant(false);
    function report(e) {
      var touches = [], i, l = e.touches.length;
      for (i = 0; i < l; i++) touches.push(e.touches.item(i));
      out.set(touches);
    }
    window.addEventListener("touchstart", report);
    window.addEventListener("touchend", report);
    window.addEventListener("touchmove", report);
    window.addEventListener("touchcancel", report);
    return function() {
      return out;
    };
  }""" :: forall e c. Fn1 (c -> Signal c) (Eff (dom :: DOM | e) (Signal [Touch]))

touch :: forall e. Eff (dom :: DOM | e) (Signal [Touch])
touch = runFn1 touchP constant

tap :: forall e. Eff (dom :: DOM | e) (Signal Boolean)
tap = do
  touches <- touch
  return $ touches ~> \t -> case t of
    [] -> false
    _ -> true

foreign import mousePosP """
  function mousePosP(constant) {
    var out = constant({x:0,y:0});
    window.addEventListener('mousemove', function(e) {
      if (e.pageX !== undefined && e.pageY !== undefined) {
        out.set({x:e.pageX, y: e.pageY});
      } else if (e.clientX !== undefined && e.clientY !== undefined) {
        out.set({
          x: e.clientX + document.body.scrollLeft +
             document.documentElement.scrollLeft,
          y: e.clientY + document.body.scrollTop +
             document.documentElement.scrollTop
        });
      } else {
        throw new Error('Mouse event has no coordinates I recognise!');
      }
    });
    return function() {
      return out;
    };
  }""" :: forall e c. (c -> Signal c) -> Eff (dom :: DOM | e) (Signal CoordinatePair)

mousePos :: forall e. Eff (dom :: DOM | e) (Signal CoordinatePair)
mousePos = mousePosP constant

foreign import animationFrameP """
  function animationFrameP(constant, now) {
    return function() {
      var requestAnimFrame, cancelAnimFrame;
      if (window.requestAnimationFrame) {
        requestAnimFrame = window.requestAnimationFrame;
        cancelAnimFrame = window.cancelAnimationFrame;
      } else if (window.mozRequestAnimationFrame) {
        requestAnimFrame = window.mozRequestAnimationFrame;
        cancelAnimFrame = window.mozCancelAnimationFrame;
      } else if (window.webkitRequestAnimationFrame) {
        requestAnimFrame = window.webkitRequestAnimationFrame;
        cancelAnimFrame = window.webkitCancelAnimationFrame;
      } else if (window.msRequestAnimationFrame) {
        requestAnimFrame = window.msRequestAnimationFrame;
        cancelAnimFrame = window.msCancelAnimationFrame;
      } else if (window.oRequestAnimationFrame) {
        requestAnimFrame = window.oRequestAnimationFrame;
        cancelAnimFrame = window.oCancelAnimationFrame;
      } else {
        requestAnimFrame = function(cb) {setTimeout(function() {cb(now())}, 1000/60)};
        cancelAnimFrame = window.clearTimeout;
      }
      var out = constant(now());
      requestAnimFrame(function tick(t) {
        out.set(t); requestAnimFrame(tick);
      });
      return out;
    };
  }""" :: forall e c. Fn2 (c -> Signal c) (Eff (timer :: Timer | e) Time) (Eff (dom :: DOM, timer :: Timer | e) (Signal Time))

animationFrame :: forall e. Eff (dom :: DOM, timer :: Timer | e) (Signal Time)
animationFrame = runFn2 animationFrameP constant now

module Signal.DOM
  ( animationFrame
  , keyPressed
  , mouseButton
  , touch
  , tap
  , mousePos
  , CoordinatePair(..)
  , Touch(..)
  ) where

import Control.Monad.Eff (Eff(..))
import Control.Timer (Timer(..))
import Data.Function
import DOM (DOM(..))
import Signal (constant, Signal(..), (~>), unwrap)
import Signal.Time (now, Time(..))

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

foreign import keyPressedP """
  function keyPressedP(constant, keyCode) {
    return function() {
      var out = constant(false);
      window.addEventListener("keydown", function(e) {
        if (e.keyCode === keyCode) out.set(true);
      });
      window.addEventListener("keyup", function(e) {
        if (e.keyCode === keyCode) out.set(false);
      });
      return out;
    };
  }""" :: forall e c. Fn2 (c -> Signal c) Number (Eff (dom :: DOM | e) (Signal Boolean))

keyPressed :: forall e. Number -> Eff (dom :: DOM | e) (Signal Boolean)
keyPressed = runFn2 keyPressedP constant

foreign import mouseButtonP """
  function mouseButtonP(constant, button) {
    return function() {
      var out = constant(false);
      window.addEventListener("mousedown", function(e) {
        if (e.button === button) out.set(true);
      });
      window.addEventListener("mouseup", function(e) {
        if (e.button === button) out.set(false);
      });
    };
  }""" :: forall e c. Fn2 (c -> Signal c) Number (Eff (dom :: DOM | e) (Signal Boolean))

mouseButton :: forall e. Number -> Eff (dom :: DOM | e) (Signal Boolean)
mouseButton = runFn2 mouseButtonP constant

type Touch = { id :: String
             , screenX :: Number, screenY :: Number
             , clientX :: Number, clientY :: Number
             , pageX :: Number, pageY :: Number
             , radiusX :: Number, radiusY :: Number
             , rotationAngle :: Number, force :: Number }

foreign import touchP """
  function touchP(constant) {
    var out = constant(false);
    function report(e) {
      var touches = [], i, l = e.touches.length;
      for (i = 0; i < l; i++) touches.push(e.touches.item(i));
      out.set(touches);
    }
    window.addEventListener("touchstart", report);
    window.addEventListener("touchend", report);
    window.addEventListener("touchmove", report);
    window.addEventListener("touchcancel", report);
    return function() {
      return out;
    };
  }""" :: forall e c. Fn1 (c -> Signal c) (Eff (dom :: DOM | e) (Signal [Touch]))

touch :: forall e. Eff (dom :: DOM | e) (Signal [Touch])
touch = runFn1 touchP constant

tap :: forall e. Eff (dom :: DOM | e) (Signal Boolean)
tap = do
  touches <- touch
  return $ touches ~> \t -> case t of
    [] -> false
    _ -> true

foreign import mousePosP """
  function mousePosP(constant) {
    var out = constant({x:0,y:0});
    window.addEventListener('mousemove', function(e) {
      if (e.pageX !== undefined && e.pageY !== undefined) {
        out.set({x:e.pageX, y: e.pageY});
      } else if (e.clientX !== undefined && e.clientY !== undefined) {
        out.set({
          x: e.clientX + document.body.scrollLeft +
             document.documentElement.scrollLeft,
          y: e.clientY + document.body.scrollTop +
             document.documentElement.scrollTop
        });
      } else {
        throw new Error('Mouse event has no coordinates I recognise!');
      }
    });
    return function() {
      return out;
    };
  }""" :: forall e c. (c -> Signal c) -> Eff (dom :: DOM | e) (Signal CoordinatePair)

mousePos :: forall e. Eff (dom :: DOM | e) (Signal CoordinatePair)
mousePos = mousePosP constant

foreign import animationFrameP """
  function animationFrameP(constant, now) {
    return function() {
      var requestAnimFrame, cancelAnimFrame;
      if (window.requestAnimationFrame) {
        requestAnimFrame = window.requestAnimationFrame;
        cancelAnimFrame = window.cancelAnimationFrame;
      } else if (window.mozRequestAnimationFrame) {
        requestAnimFrame = window.mozRequestAnimationFrame;
        cancelAnimFrame = window.mozCancelAnimationFrame;
      } else if (window.webkitRequestAnimationFrame) {
        requestAnimFrame = window.webkitRequestAnimationFrame;
        cancelAnimFrame = window.webkitCancelAnimationFrame;
      } else if (window.msRequestAnimationFrame) {
        requestAnimFrame = window.msRequestAnimationFrame;
        cancelAnimFrame = window.msCancelAnimationFrame;
      } else if (window.oRequestAnimationFrame) {
        requestAnimFrame = window.oRequestAnimationFrame;
        cancelAnimFrame = window.oCancelAnimationFrame;
      } else {
        requestAnimFrame = function(cb) {setTimeout(function() {cb(now())}, 1000/60)};
        cancelAnimFrame = window.clearTimeout;
      }
      var out = constant(now());
      requestAnimFrame(function tick(t) {
        out.set(t); requestAnimFrame(tick);
      });
      return out;
    };
  }""" :: forall e c. Fn2 (c -> Signal c) (Eff (timer :: Timer | e) Time) (Eff (dom :: DOM, timer :: Timer | e) (Signal Time))

animationFrame :: forall e. Eff (dom :: DOM, timer :: Timer | e) (Signal Time)
animationFrame = runFn2 animationFrameP constant now