refactoring: extracts common workspace creation logic

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.FileSystem.Component
  ( module SlamData.FileSystem.Component.State
  , module SlamData.FileSystem.Component.Query
  , module SlamData.FileSystem.Component.ChildSlot
  , component
  ) where

import SlamData.Prelude

import Control.Monad.Rec.Class (tailRecM, Step(Done, Loop))
import Control.UI.Browser (setLocation, locationString, clearValue)
import Control.UI.Browser as Browser
import Control.UI.Browser.Event as Be
import Control.UI.File as Cf

import CSS as CSS

import Data.Argonaut (jsonParser, jsonEmptyObject)
import Data.Array as Array
import Data.Coyoneda (liftCoyoneda)
import Data.Foldable as F
import Data.Lens ((.~), preview)
import Data.MediaType (MediaType(..))
import Data.MediaType.Common (textCSV, applicationJSON)
import Data.Path.Pathy (rootDir, (</>), dir, file, parentDir, printPath)
import Data.String as S
import Data.String.Regex as RX
import Data.String.Regex.Flags as RXF

import DOM.Event.Event as DEE

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Core as HC
import Halogen.HTML.CSS as HCSS
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource as ES

import Quasar.Data (QData(..))
import Quasar.Mount as QM

import SlamData.Common.Sort (notSort)
import SlamData.Config as Config
import SlamData.Dialog.Render as RenderDialog
import SlamData.FileSystem.Breadcrumbs.Component as Breadcrumbs
import SlamData.FileSystem.Component.CSS as FileSystemClassNames
import SlamData.FileSystem.Component.ChildSlot (ChildQuery, ChildSlot)
import SlamData.FileSystem.Component.ChildSlot as CS
import SlamData.FileSystem.Component.Query (Query(..))
import SlamData.FileSystem.Component.Render (sorting, toolbar)
import SlamData.FileSystem.Component.State (State, initialState)
import SlamData.FileSystem.Component.State as State
import SlamData.FileSystem.Dialog.Component as Dialog
import SlamData.FileSystem.Dialog.Component.Message as DialogMessage
import SlamData.FileSystem.Dialog.Mount.Component as Mount
import SlamData.FileSystem.Dialog.Mount.Couchbase.Component.State as Couchbase
import SlamData.FileSystem.Dialog.Mount.MarkLogic.Component.State as MarkLogic
import SlamData.FileSystem.Dialog.Mount.MongoDB.Component.State as MongoDB
import SlamData.FileSystem.Dialog.Mount.SQL2.Component.State as SQL2
import SlamData.FileSystem.Dialog.Mount.SparkHDFS.Component.State as Spark
import SlamData.FileSystem.Dialog.Mount.SparkLocal.Component.State as SparkLocal
import SlamData.FileSystem.Listing.Component as Listing
import SlamData.FileSystem.Listing.Item (Item(..), itemResource, sortItem)
import SlamData.FileSystem.Listing.Item.Component as Item
import SlamData.FileSystem.Resource (Resource)
import SlamData.FileSystem.Resource as R
import SlamData.FileSystem.Routing (browseURL)
import SlamData.FileSystem.Routing.Salt (newSalt)
import SlamData.FileSystem.Search.Component as Search
import SlamData.GlobalError as GE
import SlamData.GlobalMenu.Component as GlobalMenu
import SlamData.Header.Component as Header
import SlamData.Header.Gripper.Component as Gripper
import SlamData.LocalStorage.Class as LS
import SlamData.LocalStorage.Keys as LSK
import SlamData.Monad (Slam)
import SlamData.Notification.Component as NC
import SlamData.Quasar (ldJSON) as API
import SlamData.Quasar.Auth (authHeaders) as API
import SlamData.Quasar.Data (makeFile, save) as API
import SlamData.Quasar.FS (children, delete, getNewName) as API
import SlamData.Quasar.Mount (mountInfo) as API
import SlamData.Render.Common (content, row)
import SlamData.Wiring as Wiring
import SlamData.Workspace.Action (Action(..), AccessType(..))
import SlamData.Workspace.Routing (mkWorkspaceURL)

import Utils (finally)
import Utils.DOM as D
import Utils.Path (DirPath, getNameStr)

type HTML = H.ParentHTML Query ChildQuery ChildSlot Slam
type DSL = H.ParentDSL State Query ChildQuery ChildSlot Void Slam

component ∷ H.Component HH.HTML Query Unit Void Slam
component =
  H.lifecycleParentComponent
    { render
    , eval
    , receiver: const Nothing
    , initialState: const initialState
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }

render ∷ State → HTML
render state@{ version, sort, salt, path } =
  HH.div
    [ HP.classes [ FileSystemClassNames.filesystem ]
    , HE.onClick (HE.input_ DismissSignInSubmenu)
    ]
    $ [ HH.slot' CS.cpHeader unit Header.component unit absurd
      , content
          [ HH.slot' CS.cpSearch unit Search.component unit $ HE.input HandleSearch
          , HH.div_
            [ Breadcrumbs.render { path, sort, salt }
            , toolbar state
            ]
          , row [ sorting state ]
          , HH.slot' CS.cpListing unit Listing.component unit $ HE.input HandleListing
          ]
      , HH.slot' CS.cpDialog unit Dialog.component unit $ HE.input HandleDialog
      , HH.slot' CS.cpNotify unit (NC.component $ NC.renderModeFromAccessType Editable) unit
          $ HE.input HandleNotifications
      ]
    ⊕ (guard state.presentIntroVideo $> renderIntroVideo)
    ⊕ (guard state.presentIntroVideo $> renderIntroVideoBackdrop)

renderIntroVideoBackdrop ∷ HTML
renderIntroVideoBackdrop =
  HH.div
    [ HP.class_ (HH.ClassName "deck-dialog-backdrop")
    , HE.onMouseDown $ HE.input_ DismissIntroVideo
    ]
    []

renderIntroVideo ∷ HTML
renderIntroVideo =
  HH.div
    [ HP.class_ $ HC.ClassName "deck-dialog" ]
    [ HH.div
        [ HCSS.style do
             CSS.paddingLeft CSS.nil
             CSS.paddingRight CSS.nil
        ]
        [ HH.h4
            [ HCSS.style do
                CSS.paddingLeft $ CSS.rem 1.0
                CSS.paddingRight $ CSS.rem 1.0
            ]
            [ HH.text "Welcome to SlamData!" ]
        , HH.video
            [ HP.autoplay true ]
            [ HH.source
                [ HP.type_ (MediaType "video/mp4")
                , HP.src "video/getting-started.mp4"
                ]
            ]
        , RenderDialog.modalFooter
            [ HH.button
                [ HP.type_ HP.ButtonButton
                , HE.onClick $ HE.input_ DismissIntroVideo
                , HP.classes [ HH.ClassName "btn", HH.ClassName "btn-primary" ]
                , HCSS.style $ CSS.marginRight $ CSS.rem 1.0
                ]
                [ HH.text "Skip video" ]
            ]
        ]
    ]

eval ∷ Query ~> DSL
eval = case _ of
  Init next → do
    w ← H.lift Wiring.expose
    whenM
      (not <$> dismissedIntroVideoBefore)
      (H.modify $ State._presentIntroVideo .~ true)
    H.subscribe $ busEventSource (flip HandleError ES.Listening) w.bus.globalError
    H.subscribe $ busEventSource (flip HandleSignInMessage ES.Listening) w.auth.signIn
    pure next
  Transition page next → do
    H.modify
      $ (State._isMount .~ page.isMount)
      ∘ (State._salt .~ page.salt)
      ∘ (State._sort .~ page.sort)
      ∘ (State._path .~ page.path)
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.Reset
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetLoading true
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetValue $ fromMaybe "" page.query
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetValid true
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetPath page.path
    resort
    pure next

  PreventDefault e q → do
    H.liftEff $ DEE.preventDefault e
    eval q
  Resort next → do
    st ← H.get
    searchValue ← H.query' CS.cpSearch unit (H.request Search.GetValue)
    H.liftEff $ setLocation $ browseURL searchValue (notSort st.sort) st.salt st.path
    pure next
  SetPath path next → do
    H.modify $ State._path .~ path
    pure next
  SetSort sort next → do
    H.modify $ State._sort .~ sort
    resort
    pure next
  SetSalt salt next → do
    H.modify $ State._salt .~ salt
    pure next
  CheckIsMount path next → do
    checkIsMount path
    pure next
  CheckIsUnconfigured next → do
    checkIsUnconfigured
    pure next
  SetVersion version next → do
    H.modify $ State._version .~ Just version
    pure next

  ShowHiddenFiles next → do
    H.modify $ State._showHiddenFiles .~ true
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.SetIsHidden false
    pure next
  HideHiddenFiles next → do
    H.modify $ State._showHiddenFiles .~ false
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.SetIsHidden true
    pure next

  Configure next → do
    path ← H.gets _.path
    configure $ R.Database path
    pure next
  MakeMount next → do
    parent ← H.gets _.path
    showDialog $ Dialog.Mount $ Mount.New { parent }
    pure next
  MakeFolder next → do
    result ← runExceptT do
      path ← lift $ H.gets _.path
      dirName ← ExceptT $ API.getNewName path Config.newFolderName
      let
        dirPath = path </> dir dirName
        dirRes = R.Directory dirPath
        dirItem = PhantomItem dirRes
        hiddenFile = dirPath </> file (Config.folderMark)
        cleanupItem = void $ H.lift $ H.query' CS.cpListing unit $ H.action $ Listing.Filter (_ ≠ dirItem)
      _ ← H.lift $ H.query' CS.cpListing unit $ H.action $ Listing.Add dirItem
      finally cleanupItem $ ExceptT $ API.save hiddenFile jsonEmptyObject
      pure dirRes
    case result of
      Left err → case GE.fromQError err of
        Left msg →
          showDialog $ Dialog.Error
            $ "There was a problem creating the directory: " ⊕ msg
        Right ge →
          GE.raiseGlobalError ge
      Right dirRes →
        void $ H.query' CS.cpListing unit $ H.action $ Listing.Add $ Item dirRes
    pure next
  MakeWorkspace next → do
    state ← H.get
    isMounted >>= if _
       then
         createWorkspace state.path \mkUrl →
           H.liftEff $ setLocation $ mkUrl New
       else
         showDialog
           $ Dialog.Error
           $ "There was a problem creating the workspace: Path "
           ⊕ printPath state.path
           ⊕ " is not inside a mount."
    pure next
  UploadFile el next → do
    mbInput ← H.liftEff $ D.querySelector "input" el
    for_ mbInput \input →
      void $ H.liftEff $ Be.raiseEvent "click" input
    pure next
  FileListChanged el next → do
    fileArr ← map Cf.fileListToArray $ (H.liftAff $ Cf.files el)
    H.liftEff $ clearValue el
    -- TODO: notification? this shouldn't be a runtime exception anyway!
    -- let err ∷ Slam Unit
    --     err = throwError $ error "empty filelist"
    -- in H.liftAff err
    for_ (Array.head fileArr) uploadFileSelected
    pure next
  Download next → do
    path ← H.gets _.path
    download $ R.Directory path
    pure next

  DismissSignInSubmenu next → do
    dismissSignInSubmenu
    pure next
  DismissMountHint next → do
    dismissMountHint
    pure next
  DismissIntroVideo next → do
    dismissIntroVideo
    pure next

  HandleError ge next → do
    showDialog $ Dialog.Error $ GE.print ge
    pure next
  HandleListing (Listing.ItemMessage m) next → do
    handleItemMessage m
    pure next
  HandleListing (Listing.Added items) next
    | Array.length items < 2 → do
        resort
        pure next
    | otherwise → do
        path ← H.gets _.path
        presentMountHint items path
        resort
        pure next
  HandleDialog DialogMessage.Dismiss next →
    pure next
  HandleDialog DialogMessage.MountSave next → do
    mount ←
      H.query' CS.cpDialog unit $ H.request Dialog.SaveMount
    for_ (join mount) \m → do
      hideDialog
      -- check if we just edited the mount for the current directory, as if
      -- so, we don't want to add an item to the list for it
      isCurrentMount ← case m of
        R.Database path' → (\p → path' ≡ (p </> dir "")) <$> H.gets _.path
        _ → pure false
      if isCurrentMount
        then
          H.liftEff Browser.reload
        else do
          _ ← H.query' CS.cpListing unit $ H.action $ Listing.Add $ Item (R.Mount m)
          dismissMountHint
          resort
          checkIsMount =<< H.gets _.path
          checkIsUnconfigured
    pure next
  HandleDialog DialogMessage.MountDelete next → do
    mount ← R.Mount ∘ R.Database <$> H.gets _.path
    remove mount
    H.liftEff Browser.reload
    pure next
  HandleNotifications NC.ExpandGlobalMenu next → do
    gripperState ← queryHeaderGripper $ H.request Gripper.GetState
    when (gripperState ≠ Just Gripper.Opened) do
      _ ← queryHeaderGripper $ H.action $ Gripper.StartDragging 0.0
      _ ← queryHeaderGripper $ H.action Gripper.StopDragging
      pure unit
    pure next
  HandleNotifications _ next →
    pure next
  HandleSearch m next → do
    salt ← H.liftEff newSalt
    st ← H.get
    value ← case m of
      Search.Cleared →
        pure Nothing
      Search.Submit → do
        H.query' CS.cpSearch unit $ H.request Search.GetValue
    H.liftEff $ setLocation $ browseURL value st.sort salt st.path
    pure next
  SetLoading bool next → do
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetLoading bool
    pure next
  SetIsSearching bool next → do
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.SetIsSearching bool
    pure next
  AddListings items next → do
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.Adds items
    pure next
  ShowError message next → do
    _ ← H.query' CS.cpDialog unit $ H.action $ Dialog.Show $ Dialog.Error message
    pure next
  HandleSignInMessage message next → do
    when (message ≡ GlobalMenu.SignInSuccess) (H.liftEff Browser.reload)
    pure next

handleItemMessage ∷ Item.Message → DSL Unit
handleItemMessage = case _ of
  Item.Selected →
    pure unit
  Item.Edit res → do
    loc ← H.liftEff locationString
    for_ (preview R._Workspace res) \wp →
      H.liftEff $ setLocation $ append (loc ⊕ "/") $ mkWorkspaceURL wp (Load Editable)
  Item.Open res → do
    { sort, salt, path } ← H.get
    loc ← H.liftEff locationString
    for_ (preview R._filePath res) \fp →
      createWorkspace path \mkUrl →
        H.liftEff $ setLocation $ mkUrl $ Exploring fp
    for_ (preview R._dirPath res) \dp →
      H.liftEff $ setLocation $ browseURL Nothing sort salt dp
    for_ (preview R._Workspace res) \wp →
      H.liftEff $ setLocation $ append (loc ⊕ "/") $ mkWorkspaceURL wp (Load ReadOnly)
  Item.Configure (R.Mount mount) → do
    configure mount
  Item.Configure _ →
    pure unit
  Item.Move res → do
    showDialog $ Dialog.Rename res
    flip getDirectories rootDir \x →
      void $ H.query' CS.cpDialog unit $ H.action $ Dialog.AddDirsToRename x
  Item.Remove res →
    remove res
  Item.Share res → do
    path ← H.gets _.path
    loc ← map (_ ⊕ "/") $ H.liftEff locationString
    for_ (preview R._filePath res) \fp → do
      createWorkspace path \mkUrl →
        showDialog $ Dialog.Share $ append loc $ mkUrl $ Exploring fp
    for_ (preview R._Workspace res) \wp → do
      showDialog (Dialog.Share $ append loc $ mkWorkspaceURL wp (Load ReadOnly))
  Item.Download res →
    download res

checkIsMount ∷ DirPath → DSL Unit
checkIsMount path = do
  isMount ← isRight <$> API.mountInfo (Left path)
  H.modify $ State._isMount .~ isMount

isMounted ∷ DSL Boolean
isMounted = do
  path ← H.gets _.path
  tailRecM go path
  where
  go ∷ DirPath → DSL (Step DirPath Boolean)
  go path = do
    isMount ← isRight <$> API.mountInfo (Left path)
    pure
      $ if isMount
          then Done true
          else maybe (Done false) Loop (parentDir path)

checkIsUnconfigured ∷ DSL Unit
checkIsUnconfigured = do
  isMount ← isRight <$> API.mountInfo (Left rootDir)
  isEmpty ← either (const false) Array.null <$> API.children rootDir
  H.modify $ State._isUnconfigured .~ (not isMount ∧ isEmpty)

remove ∷ Resource → DSL Unit
remove res = do
  -- Replace actual item with phantom
  _ ← H.query' CS.cpListing unit $ H.action $ Listing.Filter $ not ∘ eq res ∘ itemResource
  _ ← H.query' CS.cpListing unit $ H.action $ Listing.Add $ PhantomItem res
  -- Save order of items during deletion (or phantom will be on top of list)
  resort
  -- Try to delete
  mbTrashFolder ← H.lift $ API.delete res
  -- Remove phantom resource after we have response from server
  _ ← H.query' CS.cpListing unit $ H.action $ Listing.Filter $ not ∘ eq res ∘ itemResource
  case mbTrashFolder of
    Left err → do
      -- Error occured: put item back and show dialog
      void $ H.query' CS.cpListing unit $ H.action $ Listing.Add (Item res)
      case GE.fromQError err of
        Left m →
          showDialog $ Dialog.Error m
        Right ge →
          GE.raiseGlobalError ge
    Right mbRes →
      -- Item has been deleted: probably add trash folder
      for_ mbRes \res' →
        void $ H.query' CS.cpListing unit $ H.action $ Listing.Add (Item res')

  listing ← fromMaybe [] <$> (H.query' CS.cpListing unit $ H.request Listing.Get)
  path ← H.gets _.path
  presentMountHint listing path

  resort
  checkIsMount path
  checkIsUnconfigured

dismissMountHint ∷ DSL Unit
dismissMountHint = do
  LS.persist LSK.dismissedMountHintKey true
  H.modify $ State._presentMountHint .~ false

dismissIntroVideo ∷ DSL Unit
dismissIntroVideo = do
  LS.persist LSK.dismissedIntroVideoKey true
  H.modify $ State._presentIntroVideo .~ false

dismissedIntroVideoBefore ∷ DSL Boolean
dismissedIntroVideoBefore =
  either (const false) id <$> LS.retrieve LSK.dismissedIntroVideoKey

uploadFileSelected ∷ Cf.File → DSL Unit
uploadFileSelected f = do
  { path, sort, salt } ← H.get
  name ←
    H.liftEff (Cf.name f)
      <#> RX.replace (unsafePartial fromRight $ RX.regex "/" RXF.global) ":"
      >>= API.getNewName path

  case name of
    Left err → handleError err
    Right name' → do
      reader ← H.liftEff Cf.newReaderEff
      content' ← H.liftAff $ Cf.readAsBinaryString f reader

      let fileName = path </> file name'
          res = R.File fileName
          fileItem = PhantomItem res
          ext = Array.last (S.split (S.Pattern ".") name')
          mime = if ext ≡ Just "csv"
                 then textCSV
                 else if isApplicationJSON content'
                      then applicationJSON
                      else API.ldJSON
      _ ← H.query' CS.cpListing unit $ H.action (Listing.Add fileItem)
      f' ← API.makeFile fileName (CustomData mime content')
      _ ← H.query' CS.cpListing unit $ H.action $ Listing.Filter (not ∘ eq res ∘ itemResource)
      case f' of
        Left err → handleError err
        Right _ →
          void $ H.query' CS.cpListing unit $ H.action $ Listing.Add (Item res)

  where
  isApplicationJSON ∷ String → Boolean
  isApplicationJSON content'
    -- Parse if content is small enough
    | S.length content' < 1048576 = isRight $ jsonParser content'
    -- Or check if its first/last characters are [/]
    | otherwise =
        let trimmed = S.trim content'
        in (startsWithEndsWith "[" "]" trimmed) || (startsWithEndsWith "{" "}" trimmed)

  startsWithEndsWith startsWith endsWith s =
    F.all isJust [S.stripPrefix (S.Pattern startsWith) s, S.stripSuffix (S.Pattern endsWith) s]

  handleError err =
    case GE.fromQError err of
      Left msg → showDialog $ Dialog.Error msg
      Right ge → GE.raiseGlobalError ge

presentMountHint ∷ ∀ a. Array a → DirPath → DSL Unit
presentMountHint xs path = do
  isSearching ←
    map (fromMaybe false) $ H.query' CS.cpSearch unit (H.request Search.IsSearching)
  isLoading ←
    map (fromMaybe true)  $ H.query' CS.cpSearch unit (H.request Search.IsLoading)

  H.modify
    ∘ (State._presentMountHint .~ _)
    ∘ ((Array.null xs ∧ path ≡ rootDir ∧ not (isSearching ∧ isLoading)) ∧ _)
    ∘ not
    ∘ either (const false) id
    =<< dismissedBefore
  where
  dismissedBefore ∷ DSL (Either String Boolean)
  dismissedBefore =
    LS.retrieve LSK.dismissedMountHintKey

dismissSignInSubmenu ∷ DSL Unit
dismissSignInSubmenu =
  void $ queryGlobalMenu (H.action GlobalMenu.DismissSubmenu)

resort ∷ DSL Unit
resort = do
  sort ← H.gets _.sort
  H.query' CS.cpSearch unit (H.request Search.IsSearching)
    >>= traverse_ \isSearching →
      void $ H.query' CS.cpListing unit $ H.action $ Listing.SortBy (sortItem isSearching sort)

configure ∷ R.Mount → DSL Unit
configure m =
  API.mountInfo anyPath >>= case m, _ of
    R.View path, Left err → raiseError err
    R.Database path, Left err
      | path /= rootDir → raiseError err
      | otherwise →
          showDialog $ Dialog.Mount Mount.Root
    R.View path, Right config →
      showDialog $ Dialog.Mount
        $ Mount.Edit
          { parent: either parentDir parentDir anyPath
          , name: Just $ getNameStr anyPath
          , settings: fromConfig config
          }
    R.Database path, Right config →
      showDialog $ Dialog.Mount
        $ Mount.Edit
          { parent: if path ≡ rootDir then Nothing else either parentDir parentDir anyPath
          , name: if path ≡ rootDir then Nothing else Just $ getNameStr anyPath
          , settings: fromConfig config
          }
  where
    anyPath =
      R.mountPath m

    fromConfig = case _ of
      QM.ViewConfig config → Mount.SQL2 (SQL2.stateFromViewInfo config)
      QM.MongoDBConfig config → Mount.MongoDB (MongoDB.fromConfig config)
      QM.CouchbaseConfig config → Mount.Couchbase (Couchbase.fromConfig config)
      QM.MarkLogicConfig config → Mount.MarkLogic (MarkLogic.fromConfig config)
      QM.SparkHDFSConfig config → Mount.SparkHDFS (Spark.fromConfig config)
      QM.SparkLocalConfig config → Mount.SparkLocal (SparkLocal.fromConfig config)

    raiseError err = case GE.fromQError err of
      Left msg →
        showDialog $ Dialog.Error
          $ "There was a problem reading the mount settings: "
          ⊕ msg
      Right ge →
        GE.raiseGlobalError ge

download ∷ R.Resource → DSL Unit
download res = do
  hs ← H.lift API.authHeaders
  showDialog $ Dialog.Download res hs
  pure unit

getChildren
  ∷ (R.Resource → Boolean)
  → (Array R.Resource → DSL Unit)
  → DirPath
  → DSL Unit
getChildren pred cont start = do
  ei ← API.children start
  case ei of
    Right items → do
      let items' = Array.filter pred items
          parents = Array.mapMaybe (either Just (const Nothing) ∘ R.getPath) items
      cont items'
      traverse_ (getChildren pred cont) parents
    _ → pure unit

getDirectories ∷ (Array R.Resource → DSL Unit) → DirPath → DSL Unit
getDirectories = getChildren $ R.isDirectory ∨ R.isDatabaseMount

showDialog ∷ Dialog.Dialog → DSL Unit
showDialog = void ∘ H.query' CS.cpDialog unit ∘ H.action ∘ Dialog.Show

hideDialog ∷ DSL Unit
hideDialog =
  void $ H.query' CS.cpDialog unit $ H.action Dialog.RaiseDismiss

queryHeaderGripper ∷ ∀ a. Gripper.Query a → DSL (Maybe a)
queryHeaderGripper =
   H.query' CS.cpHeader unit ∘ Header.QueryGripper ∘ liftCoyoneda

queryGlobalMenu ∷ ∀ a. GlobalMenu.Query a → DSL (Maybe a)
queryGlobalMenu =
   H.query' CS.cpHeader unit ∘ Header.QueryGlobalMenu ∘ liftCoyoneda

createWorkspace ∷ ∀ a. DirPath → ((Action → String) → DSL a) → DSL Unit
createWorkspace path action = do
  let newWorkspaceName = Config.newWorkspaceName ⊕ "." ⊕ Config.workspaceExtension
  name ← API.getNewName path newWorkspaceName
  case name of
    Left err →
      case GE.fromQError err of
        Left msg →
          -- This error isn't strictly true as we're not actually creating the
          -- workspace here, but saying there was a problem "creating a name for the
          -- workspace" would be a little strange
          showDialog $ Dialog.Error
            $ "There was a problem creating the workspace: " ⊕ msg
        Right ge →
          GE.raiseGlobalError ge
    Right name' →
      void $ action (mkWorkspaceURL (path </> dir name'))

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.FileSystem.Component
  ( module SlamData.FileSystem.Component.State
  , module SlamData.FileSystem.Component.Query
  , module SlamData.FileSystem.Component.ChildSlot
  , component
  ) where

import SlamData.Prelude

import Control.Monad.Rec.Class (tailRecM, Step(Done, Loop))
import Control.UI.Browser (setLocation, locationString, clearValue)
import Control.UI.Browser as Browser
import Control.UI.Browser.Event as Be
import Control.UI.File as Cf

import CSS as CSS

import Data.Argonaut (jsonParser, jsonEmptyObject)
import Data.Array as Array
import Data.Coyoneda (liftCoyoneda)
import Data.Foldable as F
import Data.Lens ((.~), preview)
import Data.MediaType (MediaType(..))
import Data.MediaType.Common (textCSV, applicationJSON)
import Data.Path.Pathy (rootDir, (</>), dir, file, parentDir, printPath)
import Data.String as S
import Data.String.Regex as RX
import Data.String.Regex.Flags as RXF

import DOM.Event.Event as DEE

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Core as HC
import Halogen.HTML.CSS as HCSS
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource as ES

import Quasar.Data (QData(..))
import Quasar.Mount as QM

import SlamData.Common.Sort (notSort)
import SlamData.Config as Config
import SlamData.Dialog.Render as RenderDialog
import SlamData.FileSystem.Breadcrumbs.Component as Breadcrumbs
import SlamData.FileSystem.Component.CSS as FileSystemClassNames
import SlamData.FileSystem.Component.ChildSlot (ChildQuery, ChildSlot)
import SlamData.FileSystem.Component.ChildSlot as CS
import SlamData.FileSystem.Component.Query (Query(..))
import SlamData.FileSystem.Component.Render (sorting, toolbar)
import SlamData.FileSystem.Component.State (State, initialState)
import SlamData.FileSystem.Component.State as State
import SlamData.FileSystem.Dialog.Component as Dialog
import SlamData.FileSystem.Dialog.Component.Message as DialogMessage
import SlamData.FileSystem.Dialog.Mount.Component as Mount
import SlamData.FileSystem.Dialog.Mount.Couchbase.Component.State as Couchbase
import SlamData.FileSystem.Dialog.Mount.MarkLogic.Component.State as MarkLogic
import SlamData.FileSystem.Dialog.Mount.MongoDB.Component.State as MongoDB
import SlamData.FileSystem.Dialog.Mount.SQL2.Component.State as SQL2
import SlamData.FileSystem.Dialog.Mount.SparkHDFS.Component.State as Spark
import SlamData.FileSystem.Dialog.Mount.SparkLocal.Component.State as SparkLocal
import SlamData.FileSystem.Listing.Component as Listing
import SlamData.FileSystem.Listing.Item (Item(..), itemResource, sortItem)
import SlamData.FileSystem.Listing.Item.Component as Item
import SlamData.FileSystem.Resource (Resource)
import SlamData.FileSystem.Resource as R
import SlamData.FileSystem.Routing (browseURL)
import SlamData.FileSystem.Routing.Salt (newSalt)
import SlamData.FileSystem.Search.Component as Search
import SlamData.GlobalError as GE
import SlamData.GlobalMenu.Component as GlobalMenu
import SlamData.Header.Component as Header
import SlamData.Header.Gripper.Component as Gripper
import SlamData.LocalStorage.Class as LS
import SlamData.LocalStorage.Keys as LSK
import SlamData.Monad (Slam)
import SlamData.Notification.Component as NC
import SlamData.Quasar (ldJSON) as API
import SlamData.Quasar.Auth (authHeaders) as API
import SlamData.Quasar.Data (makeFile, save) as API
import SlamData.Quasar.FS (children, delete, getNewName) as API
import SlamData.Quasar.Mount (mountInfo) as API
import SlamData.Render.Common (content, row)
import SlamData.Wiring as Wiring
import SlamData.Workspace.Action (Action(..), AccessType(..))
import SlamData.Workspace.Routing (mkWorkspaceURL)

import Utils (finally)
import Utils.DOM as D
import Utils.Path (DirPath, getNameStr)

type HTML = H.ParentHTML Query ChildQuery ChildSlot Slam
type DSL = H.ParentDSL State Query ChildQuery ChildSlot Void Slam

component ∷ H.Component HH.HTML Query Unit Void Slam
component =
  H.lifecycleParentComponent
    { render
    , eval
    , receiver: const Nothing
    , initialState: const initialState
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }

render ∷ State → HTML
render state@{ version, sort, salt, path } =
  HH.div
    [ HP.classes [ FileSystemClassNames.filesystem ]
    , HE.onClick (HE.input_ DismissSignInSubmenu)
    ]
    $ [ HH.slot' CS.cpHeader unit Header.component unit absurd
      , content
          [ HH.slot' CS.cpSearch unit Search.component unit $ HE.input HandleSearch
          , HH.div_
            [ Breadcrumbs.render { path, sort, salt }
            , toolbar state
            ]
          , row [ sorting state ]
          , HH.slot' CS.cpListing unit Listing.component unit $ HE.input HandleListing
          ]
      , HH.slot' CS.cpDialog unit Dialog.component unit $ HE.input HandleDialog
      , HH.slot' CS.cpNotify unit (NC.component $ NC.renderModeFromAccessType Editable) unit
          $ HE.input HandleNotifications
      ]
    ⊕ (guard state.presentIntroVideo $> renderIntroVideo)
    ⊕ (guard state.presentIntroVideo $> renderIntroVideoBackdrop)

renderIntroVideoBackdrop ∷ HTML
renderIntroVideoBackdrop =
  HH.div
    [ HP.class_ (HH.ClassName "deck-dialog-backdrop")
    , HE.onMouseDown $ HE.input_ DismissIntroVideo
    ]
    []

renderIntroVideo ∷ HTML
renderIntroVideo =
  HH.div
    [ HP.class_ $ HC.ClassName "deck-dialog" ]
    [ HH.div
        [ HCSS.style do
             CSS.paddingLeft CSS.nil
             CSS.paddingRight CSS.nil
        ]
        [ HH.h4
            [ HCSS.style do
                CSS.paddingLeft $ CSS.rem 1.0
                CSS.paddingRight $ CSS.rem 1.0
            ]
            [ HH.text "Welcome to SlamData!" ]
        , HH.video
            [ HP.autoplay true ]
            [ HH.source
                [ HP.type_ (MediaType "video/mp4")
                , HP.src "video/getting-started.mp4"
                ]
            ]
        , RenderDialog.modalFooter
            [ HH.button
                [ HP.type_ HP.ButtonButton
                , HE.onClick $ HE.input_ DismissIntroVideo
                , HP.classes [ HH.ClassName "btn", HH.ClassName "btn-primary" ]
                , HCSS.style $ CSS.marginRight $ CSS.rem 1.0
                ]
                [ HH.text "Skip video" ]
            ]
        ]
    ]

eval ∷ Query ~> DSL
eval = case _ of
  Init next → do
    w ← H.lift Wiring.expose
    whenM
      (not <$> dismissedIntroVideoBefore)
      (H.modify $ State._presentIntroVideo .~ true)
    H.subscribe $ busEventSource (flip HandleError ES.Listening) w.bus.globalError
    H.subscribe $ busEventSource (flip HandleSignInMessage ES.Listening) w.auth.signIn
    pure next
  Transition page next → do
    H.modify
      $ (State._isMount .~ page.isMount)
      ∘ (State._salt .~ page.salt)
      ∘ (State._sort .~ page.sort)
      ∘ (State._path .~ page.path)
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.Reset
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetLoading true
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetValue $ fromMaybe "" page.query
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetValid true
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetPath page.path
    resort
    pure next

  PreventDefault e q → do
    H.liftEff $ DEE.preventDefault e
    eval q
  Resort next → do
    st ← H.get
    searchValue ← H.query' CS.cpSearch unit (H.request Search.GetValue)
    H.liftEff $ setLocation $ browseURL searchValue (notSort st.sort) st.salt st.path
    pure next
  SetPath path next → do
    H.modify $ State._path .~ path
    pure next
  SetSort sort next → do
    H.modify $ State._sort .~ sort
    resort
    pure next
  SetSalt salt next → do
    H.modify $ State._salt .~ salt
    pure next
  CheckIsMount path next → do
    checkIsMount path
    pure next
  CheckIsUnconfigured next → do
    checkIsUnconfigured
    pure next
  SetVersion version next → do
    H.modify $ State._version .~ Just version
    pure next

  ShowHiddenFiles next → do
    H.modify $ State._showHiddenFiles .~ true
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.SetIsHidden false
    pure next
  HideHiddenFiles next → do
    H.modify $ State._showHiddenFiles .~ false
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.SetIsHidden true
    pure next

  Configure next → do
    path ← H.gets _.path
    configure $ R.Database path
    pure next
  MakeMount next → do
    parent ← H.gets _.path
    showDialog $ Dialog.Mount $ Mount.New { parent }
    pure next
  MakeFolder next → do
    result ← runExceptT do
      path ← lift $ H.gets _.path
      dirName ← ExceptT $ API.getNewName path Config.newFolderName
      let
        dirPath = path </> dir dirName
        dirRes = R.Directory dirPath
        dirItem = PhantomItem dirRes
        hiddenFile = dirPath </> file (Config.folderMark)
        cleanupItem = void $ H.lift $ H.query' CS.cpListing unit $ H.action $ Listing.Filter (_ ≠ dirItem)
      _ ← H.lift $ H.query' CS.cpListing unit $ H.action $ Listing.Add dirItem
      finally cleanupItem $ ExceptT $ API.save hiddenFile jsonEmptyObject
      pure dirRes
    case result of
      Left err → case GE.fromQError err of
        Left msg →
          showDialog $ Dialog.Error
            $ "There was a problem creating the directory: " ⊕ msg
        Right ge →
          GE.raiseGlobalError ge
      Right dirRes →
        void $ H.query' CS.cpListing unit $ H.action $ Listing.Add $ Item dirRes
    pure next
  MakeWorkspace next → do
    state ← H.get
    isMounted >>= if _
      then do
        let
          newWorkspaceName = Config.newWorkspaceName ⊕ "." ⊕ Config.workspaceExtension
        name ← API.getNewName state.path newWorkspaceName
        case name of
          Left err →
            case GE.fromQError err of
              Left msg →
                -- This error isn't strictly true as we're not actually creating the
                -- workspace here, but saying there was a problem "creating a name for the
                -- workspace" would be a little strange
                showDialog $ Dialog.Error
                  $ "There was a problem creating the workspace: " ⊕ msg
              Right ge →
                GE.raiseGlobalError ge
          Right name' → do
            H.liftEff $ setLocation $ mkWorkspaceURL (state.path </> dir name') New
       else
         showDialog
           $ Dialog.Error
           $ "There was a problem creating the workspace: Path "
           ⊕ printPath state.path
           ⊕ " is not inside a mount."
    pure next
  UploadFile el next → do
    mbInput ← H.liftEff $ D.querySelector "input" el
    for_ mbInput \input →
      void $ H.liftEff $ Be.raiseEvent "click" input
    pure next
  FileListChanged el next → do
    fileArr ← map Cf.fileListToArray $ (H.liftAff $ Cf.files el)
    H.liftEff $ clearValue el
    -- TODO: notification? this shouldn't be a runtime exception anyway!
    -- let err ∷ Slam Unit
    --     err = throwError $ error "empty filelist"
    -- in H.liftAff err
    for_ (Array.head fileArr) uploadFileSelected
    pure next
  Download next → do
    path ← H.gets _.path
    download $ R.Directory path
    pure next

  DismissSignInSubmenu next → do
    dismissSignInSubmenu
    pure next
  DismissMountHint next → do
    dismissMountHint
    pure next
  DismissIntroVideo next → do
    dismissIntroVideo
    pure next

  HandleError ge next → do
    showDialog $ Dialog.Error $ GE.print ge
    pure next
  HandleListing (Listing.ItemMessage m) next → do
    handleItemMessage m
    pure next
  HandleListing (Listing.Added items) next
    | Array.length items < 2 → do
        resort
        pure next
    | otherwise → do
        path ← H.gets _.path
        presentMountHint items path
        resort
        pure next
  HandleDialog DialogMessage.Dismiss next →
    pure next
  HandleDialog DialogMessage.MountSave next → do
    mount ←
      H.query' CS.cpDialog unit $ H.request Dialog.SaveMount
    for_ (join mount) \m → do
      hideDialog
      -- check if we just edited the mount for the current directory, as if
      -- so, we don't want to add an item to the list for it
      isCurrentMount ← case m of
        R.Database path' → (\p → path' ≡ (p </> dir "")) <$> H.gets _.path
        _ → pure false
      if isCurrentMount
        then
          H.liftEff Browser.reload
        else do
          _ ← H.query' CS.cpListing unit $ H.action $ Listing.Add $ Item (R.Mount m)
          dismissMountHint
          resort
          checkIsMount =<< H.gets _.path
          checkIsUnconfigured
    pure next
  HandleDialog DialogMessage.MountDelete next → do
    mount ← R.Mount ∘ R.Database <$> H.gets _.path
    remove mount
    H.liftEff Browser.reload
    pure next
  HandleNotifications NC.ExpandGlobalMenu next → do
    gripperState ← queryHeaderGripper $ H.request Gripper.GetState
    when (gripperState ≠ Just Gripper.Opened) do
      _ ← queryHeaderGripper $ H.action $ Gripper.StartDragging 0.0
      _ ← queryHeaderGripper $ H.action Gripper.StopDragging
      pure unit
    pure next
  HandleNotifications _ next →
    pure next
  HandleSearch m next → do
    salt ← H.liftEff newSalt
    st ← H.get
    value ← case m of
      Search.Cleared →
        pure Nothing
      Search.Submit → do
        H.query' CS.cpSearch unit $ H.request Search.GetValue
    H.liftEff $ setLocation $ browseURL value st.sort salt st.path
    pure next
  SetLoading bool next → do
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetLoading bool
    pure next
  SetIsSearching bool next → do
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.SetIsSearching bool
    pure next
  AddListings items next → do
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.Adds items
    pure next
  ShowError message next → do
    _ ← H.query' CS.cpDialog unit $ H.action $ Dialog.Show $ Dialog.Error message
    pure next
  HandleSignInMessage message next → do
    when (message ≡ GlobalMenu.SignInSuccess) (H.liftEff Browser.reload)
    pure next

handleItemMessage ∷ Item.Message → DSL Unit
handleItemMessage = case _ of
  Item.Selected →
    pure unit
  Item.Edit res → do
    loc ← H.liftEff locationString
    for_ (preview R._Workspace res) \wp →
      H.liftEff $ setLocation $ append (loc ⊕ "/") $ mkWorkspaceURL wp (Load Editable)
  Item.Open res → do
    { sort, salt, path } ← H.get
    loc ← H.liftEff locationString
    for_ (preview R._filePath res) \fp → do
      let newWorkspaceName = Config.newWorkspaceName ⊕ "." ⊕ Config.workspaceExtension
      name ← API.getNewName path newWorkspaceName
      case name of
        Left err →
          case GE.fromQError err of
            Left msg →
              showDialog $ Dialog.Error
              $ "There was a problem creating the workspace: " ⊕ msg
            Right ge →
              GE.raiseGlobalError ge
        Right name' →
          H.liftEff $ setLocation  $ mkWorkspaceURL (path </> dir name') $ Exploring fp
    for_ (preview R._dirPath res) \dp →
      H.liftEff $ setLocation $ browseURL Nothing sort salt dp
    for_ (preview R._Workspace res) \wp →
      H.liftEff $ setLocation $ append (loc ⊕ "/") $ mkWorkspaceURL wp (Load ReadOnly)
  Item.Configure (R.Mount mount) → do
    configure mount
  Item.Configure _ →
    pure unit
  Item.Move res → do
    showDialog $ Dialog.Rename res
    flip getDirectories rootDir \x →
      void $ H.query' CS.cpDialog unit $ H.action $ Dialog.AddDirsToRename x
  Item.Remove res →
    remove res
  Item.Share res → do
    path ← H.gets _.path
    loc ← map (_ ⊕ "/") $ H.liftEff locationString
    for_ (preview R._filePath res) \fp → do
      let newWorkspaceName = Config.newWorkspaceName ⊕ "." ⊕ Config.workspaceExtension
      name ← API.getNewName path newWorkspaceName
      case name of
        Left err →
          case GE.fromQError err of
            Left m →
              showDialog $ Dialog.Error
                $ "There was a problem creating the workspace: " ⊕ m
            Right ge →
              GE.raiseGlobalError ge
        Right name' → do
          showDialog (Dialog.Share $ append loc $  mkWorkspaceURL (path </> dir name') $ Exploring fp)
    for_ (preview R._Workspace res) \wp → do
      showDialog (Dialog.Share $ append loc $ mkWorkspaceURL wp (Load ReadOnly))
  Item.Download res →
    download res

checkIsMount ∷ DirPath → DSL Unit
checkIsMount path = do
  isMount ← isRight <$> API.mountInfo (Left path)
  H.modify $ State._isMount .~ isMount

isMounted ∷ DSL Boolean
isMounted = do
  path ← H.gets _.path
  tailRecM go path
  where
  go ∷ DirPath → DSL (Step DirPath Boolean)
  go path = do
    isMount ← isRight <$> API.mountInfo (Left path)
    pure
      $ if isMount
          then Done true
          else maybe (Done false) Loop (parentDir path)

checkIsUnconfigured ∷ DSL Unit
checkIsUnconfigured = do
  isMount ← isRight <$> API.mountInfo (Left rootDir)
  isEmpty ← either (const false) Array.null <$> API.children rootDir
  H.modify $ State._isUnconfigured .~ (not isMount ∧ isEmpty)

remove ∷ Resource → DSL Unit
remove res = do
  -- Replace actual item with phantom
  _ ← H.query' CS.cpListing unit $ H.action $ Listing.Filter $ not ∘ eq res ∘ itemResource
  _ ← H.query' CS.cpListing unit $ H.action $ Listing.Add $ PhantomItem res
  -- Save order of items during deletion (or phantom will be on top of list)
  resort
  -- Try to delete
  mbTrashFolder ← H.lift $ API.delete res
  -- Remove phantom resource after we have response from server
  _ ← H.query' CS.cpListing unit $ H.action $ Listing.Filter $ not ∘ eq res ∘ itemResource
  case mbTrashFolder of
    Left err → do
      -- Error occured: put item back and show dialog
      void $ H.query' CS.cpListing unit $ H.action $ Listing.Add (Item res)
      case GE.fromQError err of
        Left m →
          showDialog $ Dialog.Error m
        Right ge →
          GE.raiseGlobalError ge
    Right mbRes →
      -- Item has been deleted: probably add trash folder
      for_ mbRes \res' →
        void $ H.query' CS.cpListing unit $ H.action $ Listing.Add (Item res')

  listing ← fromMaybe [] <$> (H.query' CS.cpListing unit $ H.request Listing.Get)
  path ← H.gets _.path
  presentMountHint listing path

  resort
  checkIsMount path
  checkIsUnconfigured

dismissMountHint ∷ DSL Unit
dismissMountHint = do
  LS.persist LSK.dismissedMountHintKey true
  H.modify $ State._presentMountHint .~ false

dismissIntroVideo ∷ DSL Unit
dismissIntroVideo = do
  LS.persist LSK.dismissedIntroVideoKey true
  H.modify $ State._presentIntroVideo .~ false

dismissedIntroVideoBefore ∷ DSL Boolean
dismissedIntroVideoBefore =
  either (const false) id <$> LS.retrieve LSK.dismissedIntroVideoKey

uploadFileSelected ∷ Cf.File → DSL Unit
uploadFileSelected f = do
  { path, sort, salt } ← H.get
  name ←
    H.liftEff (Cf.name f)
      <#> RX.replace (unsafePartial fromRight $ RX.regex "/" RXF.global) ":"
      >>= API.getNewName path

  case name of
    Left err → handleError err
    Right name' → do
      reader ← H.liftEff Cf.newReaderEff
      content' ← H.liftAff $ Cf.readAsBinaryString f reader

      let fileName = path </> file name'
          res = R.File fileName
          fileItem = PhantomItem res
          ext = Array.last (S.split (S.Pattern ".") name')
          mime = if ext ≡ Just "csv"
                 then textCSV
                 else if isApplicationJSON content'
                      then applicationJSON
                      else API.ldJSON
      _ ← H.query' CS.cpListing unit $ H.action (Listing.Add fileItem)
      f' ← API.makeFile fileName (CustomData mime content')
      _ ← H.query' CS.cpListing unit $ H.action $ Listing.Filter (not ∘ eq res ∘ itemResource)
      case f' of
        Left err → handleError err
        Right _ →
          void $ H.query' CS.cpListing unit $ H.action $ Listing.Add (Item res)

  where
  isApplicationJSON ∷ String → Boolean
  isApplicationJSON content'
    -- Parse if content is small enough
    | S.length content' < 1048576 = isRight $ jsonParser content'
    -- Or check if its first/last characters are [/]
    | otherwise =
        let trimmed = S.trim content'
        in (startsWithEndsWith "[" "]" trimmed) || (startsWithEndsWith "{" "}" trimmed)

  startsWithEndsWith startsWith endsWith s =
    F.all isJust [S.stripPrefix (S.Pattern startsWith) s, S.stripSuffix (S.Pattern endsWith) s]

  handleError err =
    case GE.fromQError err of
      Left msg → showDialog $ Dialog.Error msg
      Right ge → GE.raiseGlobalError ge

presentMountHint ∷ ∀ a. Array a → DirPath → DSL Unit
presentMountHint xs path = do
  isSearching ←
    map (fromMaybe false) $ H.query' CS.cpSearch unit (H.request Search.IsSearching)
  isLoading ←
    map (fromMaybe true)  $ H.query' CS.cpSearch unit (H.request Search.IsLoading)

  H.modify
    ∘ (State._presentMountHint .~ _)
    ∘ ((Array.null xs ∧ path ≡ rootDir ∧ not (isSearching ∧ isLoading)) ∧ _)
    ∘ not
    ∘ either (const false) id
    =<< dismissedBefore
  where
  dismissedBefore ∷ DSL (Either String Boolean)
  dismissedBefore =
    LS.retrieve LSK.dismissedMountHintKey

dismissSignInSubmenu ∷ DSL Unit
dismissSignInSubmenu =
  void $ queryGlobalMenu (H.action GlobalMenu.DismissSubmenu)

resort ∷ DSL Unit
resort = do
  sort ← H.gets _.sort
  H.query' CS.cpSearch unit (H.request Search.IsSearching)
    >>= traverse_ \isSearching →
      void $ H.query' CS.cpListing unit $ H.action $ Listing.SortBy (sortItem isSearching sort)

configure ∷ R.Mount → DSL Unit
configure m =
  API.mountInfo anyPath >>= case m, _ of
    R.View path, Left err → raiseError err
    R.Database path, Left err
      | path /= rootDir → raiseError err
      | otherwise →
          showDialog $ Dialog.Mount Mount.Root
    R.View path, Right config →
      showDialog $ Dialog.Mount
        $ Mount.Edit
          { parent: either parentDir parentDir anyPath
          , name: Just $ getNameStr anyPath
          , settings: fromConfig config
          }
    R.Database path, Right config →
      showDialog $ Dialog.Mount
        $ Mount.Edit
          { parent: if path ≡ rootDir then Nothing else either parentDir parentDir anyPath
          , name: if path ≡ rootDir then Nothing else Just $ getNameStr anyPath
          , settings: fromConfig config
          }
  where
    anyPath =
      R.mountPath m

    fromConfig = case _ of
      QM.ViewConfig config → Mount.SQL2 (SQL2.stateFromViewInfo config)
      QM.MongoDBConfig config → Mount.MongoDB (MongoDB.fromConfig config)
      QM.CouchbaseConfig config → Mount.Couchbase (Couchbase.fromConfig config)
      QM.MarkLogicConfig config → Mount.MarkLogic (MarkLogic.fromConfig config)
      QM.SparkHDFSConfig config → Mount.SparkHDFS (Spark.fromConfig config)
      QM.SparkLocalConfig config → Mount.SparkLocal (SparkLocal.fromConfig config)

    raiseError err = case GE.fromQError err of
      Left msg →
        showDialog $ Dialog.Error
          $ "There was a problem reading the mount settings: "
          ⊕ msg
      Right ge →
        GE.raiseGlobalError ge

download ∷ R.Resource → DSL Unit
download res = do
  hs ← H.lift API.authHeaders
  showDialog $ Dialog.Download res hs
  pure unit

getChildren
  ∷ (R.Resource → Boolean)
  → (Array R.Resource → DSL Unit)
  → DirPath
  → DSL Unit
getChildren pred cont start = do
  ei ← API.children start
  case ei of
    Right items → do
      let items' = Array.filter pred items
          parents = Array.mapMaybe (either Just (const Nothing) ∘ R.getPath) items
      cont items'
      traverse_ (getChildren pred cont) parents
    _ → pure unit

getDirectories ∷ (Array R.Resource → DSL Unit) → DirPath → DSL Unit
getDirectories = getChildren $ R.isDirectory ∨ R.isDatabaseMount

showDialog ∷ Dialog.Dialog → DSL Unit
showDialog = void ∘ H.query' CS.cpDialog unit ∘ H.action ∘ Dialog.Show

hideDialog ∷ DSL Unit
hideDialog =
  void $ H.query' CS.cpDialog unit $ H.action Dialog.RaiseDismiss

queryHeaderGripper ∷ ∀ a. Gripper.Query a → DSL (Maybe a)
queryHeaderGripper =
   H.query' CS.cpHeader unit ∘ Header.QueryGripper ∘ liftCoyoneda

queryGlobalMenu ∷ ∀ a. GlobalMenu.Query a → DSL (Maybe a)
queryGlobalMenu =
   H.query' CS.cpHeader unit ∘ Header.QueryGlobalMenu ∘ liftCoyoneda


Use specified imports and rename getArgs to getArgsBind

Signed-off-by: Joern Bernhardt <7b85a41a628204b76aba4326273a3ccc74bd009a@campudus.com>

module Main where

import Prelude (Unit, bind, (<>), (>>=))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Array (head, tail)
import Data.Maybe (Maybe(..))
import Node.Process (PROCESS, argv)

greeting :: String -> String
greeting who = "Hello " <> who <> "!"

getArgsBind :: Array String -> Maybe (String)
getArgsBind args = tail args >>= tail >>= head

getArgsDo :: Array String -> Maybe (String)
getArgsDo args = do
  a <- tail args
  b <- tail a
  head b

get :: Maybe String -> String
get (Just str) = str
get Nothing    = ""

main :: forall eff. Eff (console :: CONSOLE, process :: PROCESS | eff) Unit
main = do
  arr <- argv
  log (greeting (get (getArgsBind arr)))

module Main where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Array (head, tail)
import Data.Maybe
import Node.Process (PROCESS, argv)

greeting :: String -> String
greeting who = "Hello " <> who <> "!"

getArgs :: Array String -> Maybe (String)
getArgs args = tail args >>= tail >>= head

getArgsDo :: Array String -> Maybe (String)
getArgsDo args = do
  a <- tail args
  b <- tail a
  head b

get :: Maybe String -> String
get (Just str) = str
get Nothing    = ""

main :: forall eff. Eff (console :: CONSOLE, process :: PROCESS | eff) Unit
main = do
  arr <- argv
  log (greeting (get (getArgsDo arr)))


Add MonadEff ExceptT instance

Add MonadEff ExceptT instance

module Control.Monad.Except.Trans where

import Prelude

import Control.Alt (Alt)
import Control.Alternative (Alternative)
import Control.Monad.Rec.Class (MonadRec, tailRecM)
import Control.Monad.Eff.Class (MonadEff, liftEff)
import Control.Monad.Trans
import Control.MonadPlus (MonadPlus)
import Control.Plus (Plus)
import Data.Either (Either(..), either)
import Data.Monoid (Monoid, mempty)

-- | A monad transformer which adds exceptions to other monads, in the same way
-- | as `Except`. As before, `e` is the type of exceptions, and `a` is the type
-- | of successful results. The new type parameter `m` is the inner monad that
-- | computations run in.
newtype ExceptT e m a = ExceptT (m (Either e a))

-- | The inverse of `ExceptT`. Run a computation in the `ExceptT` monad.
runExceptT :: forall e m a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT x) = x

-- | Transform any exceptions thrown by an `ExceptT` computation using the given function.
withExceptT :: forall e e' m a. (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT f = ExceptT <<< (<$>) (mapLeft f) <<< runExceptT
  where
  mapLeft _ (Right x) = Right x
  mapLeft f (Left x) = Left (f x)

-- | Transform the unwrapped computation using the given function.
mapExceptT :: forall e e' m n a b. (m (Either e a) -> n (Either e' b)) -> ExceptT e m a -> ExceptT e' n b
mapExceptT f m = ExceptT (f (runExceptT m))

instance functorExceptT :: (Functor m) => Functor (ExceptT e m) where
  map f = mapExceptT ((<$>) ((<$>) f))

instance applyExceptT :: (Apply m) => Apply (ExceptT e m) where
  apply (ExceptT f) (ExceptT x) =
    let f' = (<*>) <$> f
        x' = f' <*> x
    in ExceptT x'

instance applicativeExceptT :: (Applicative m) => Applicative (ExceptT e m) where
  pure = ExceptT <<< pure <<< Right

instance bindExceptT :: (Monad m) => Bind (ExceptT e m) where
  bind m k = ExceptT (runExceptT m >>=
                          either (return <<< Left) (runExceptT <<< k))

instance monadExceptT :: (Monad m) => Monad (ExceptT e m)

instance monadRecErrorT :: (Semigroup e, MonadRec m) => MonadRec (ExceptT e m) where
  tailRecM f = ExceptT <<< tailRecM \a -> do
    m <- runExceptT (f a)
    return case m of
      Left e -> Right (Left e)
      Right (Left a1) -> Left a1
      Right (Right b) -> Right (Right b)

instance altExceptT :: (Semigroup e, Monad m) => Alt (ExceptT e m) where
  alt m n = ExceptT $ do
    rm <- runExceptT m
    case rm of
      Right x -> pure (Right x)
      Left err -> do
        rn <- runExceptT n
        case rn of
          Right x -> pure (Right x)
          Left err' -> pure (Left (err <> err'))

instance plusExceptT :: (Monoid e, Monad m) => Plus (ExceptT e m) where
  empty = throwE mempty

instance alternativeExceptT :: (Monoid e, Monad m) => Alternative (ExceptT e m)

instance monadPlusExceptT :: (Monoid e, Monad m) => MonadPlus (ExceptT e m)

instance monadTransExceptT :: MonadTrans (ExceptT e) where
  lift m = ExceptT $ do
    a <- m
    return $ Right a

instance monadEffExceptT :: (Monad m, MonadEff eff m) => MonadEff eff (ExceptT e m) where
  liftEff = lift <<< liftEff

-- | Throw an exception in an `ExceptT` computation.
throwE :: forall e m a. (Applicative m) => e -> ExceptT e m a
throwE = ExceptT <<< pure <<< Left

-- | Catch an exception in an `ExceptT` computation.
catchE :: forall e e' m a. (Monad m) => ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE m handler = ExceptT (runExceptT m >>= either (runExceptT <<< handler) (pure <<< Right))

module Control.Monad.Except.Trans where

import Prelude

import Control.Alt (Alt)
import Control.Alternative (Alternative)
import Control.Monad.Rec.Class (MonadRec, tailRecM)
import Control.Monad.Trans
import Control.MonadPlus (MonadPlus)
import Control.Plus (Plus)
import Data.Either (Either(..), either)
import Data.Monoid (Monoid, mempty)

-- | A monad transformer which adds exceptions to other monads, in the same way
-- | as `Except`. As before, `e` is the type of exceptions, and `a` is the type
-- | of successful results. The new type parameter `m` is the inner monad that
-- | computations run in.
newtype ExceptT e m a = ExceptT (m (Either e a))

-- | The inverse of `ExceptT`. Run a computation in the `ExceptT` monad.
runExceptT :: forall e m a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT x) = x

-- | Transform any exceptions thrown by an `ExceptT` computation using the given function.
withExceptT :: forall e e' m a. (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT f = ExceptT <<< (<$>) (mapLeft f) <<< runExceptT
  where
  mapLeft _ (Right x) = Right x
  mapLeft f (Left x) = Left (f x)

-- | Transform the unwrapped computation using the given function.
mapExceptT :: forall e e' m n a b. (m (Either e a) -> n (Either e' b)) -> ExceptT e m a -> ExceptT e' n b
mapExceptT f m = ExceptT (f (runExceptT m))

instance functorExceptT :: (Functor m) => Functor (ExceptT e m) where
  map f = mapExceptT ((<$>) ((<$>) f))

instance applyExceptT :: (Apply m) => Apply (ExceptT e m) where
  apply (ExceptT f) (ExceptT x) =
    let f' = (<*>) <$> f
        x' = f' <*> x
    in ExceptT x'

instance applicativeExceptT :: (Applicative m) => Applicative (ExceptT e m) where
  pure = ExceptT <<< pure <<< Right

instance bindExceptT :: (Monad m) => Bind (ExceptT e m) where
  bind m k = ExceptT (runExceptT m >>=
                          either (return <<< Left) (runExceptT <<< k))

instance monadExceptT :: (Monad m) => Monad (ExceptT e m)

instance monadRecErrorT :: (Semigroup e, MonadRec m) => MonadRec (ExceptT e m) where
  tailRecM f = ExceptT <<< tailRecM \a -> do
    m <- runExceptT (f a)
    return case m of
      Left e -> Right (Left e)
      Right (Left a1) -> Left a1
      Right (Right b) -> Right (Right b)

instance altExceptT :: (Semigroup e, Monad m) => Alt (ExceptT e m) where
  alt m n = ExceptT $ do
    rm <- runExceptT m
    case rm of
      Right x -> pure (Right x)
      Left err -> do
        rn <- runExceptT n
        case rn of
          Right x -> pure (Right x)
          Left err' -> pure (Left (err <> err'))

instance plusExceptT :: (Monoid e, Monad m) => Plus (ExceptT e m) where
  empty = throwE mempty

instance alternativeExceptT :: (Monoid e, Monad m) => Alternative (ExceptT e m)

instance monadPlusExceptT :: (Monoid e, Monad m) => MonadPlus (ExceptT e m)

instance monadTransExceptT :: MonadTrans (ExceptT e) where
  lift m = ExceptT $ do
    a <- m
    return $ Right a

-- | Throw an exception in an `ExceptT` computation.
throwE :: forall e m a. (Applicative m) => e -> ExceptT e m a
throwE = ExceptT <<< pure <<< Left

-- | Catch an exception in an `ExceptT` computation.
catchE :: forall e e' m a. (Monad m) => ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE m handler = ExceptT (runExceptT m >>= either (runExceptT <<< handler) (pure <<< Right))


complete FFI

complete FFI

module KanColle.DamageAnalysisFFI where

import Prelude
import KanColle.Util
import KanColle.DamageAnalysis.Damage
import KanColle.DamageAnalysis2
import KanColle.KCAPI.Battle
import Data.Foreign
import Data.Maybe
import Data.Array
import Data.Function
import Data.Nullable

readDameCon :: Array Int -> Array (Maybe DameCon)
readDameCon = map convert
  where
    convert :: Int -> Maybe DameCon
    convert 0 = Nothing
    convert 1 = Just RepairTeam
    convert 2 = Just RepairGodness
    convert x = throwWith ("readDameCon: invalid input: " <> show x)

dc6 :: Array (Maybe DameCon)
dc6 = replicate 6 Nothing

dc12 :: Array (Maybe DameCon)
dc12 = replicate 12 Nothing

type FleetResult f = Array (f ShipResult)

type BattleResult f =
  { main :: FleetResult f
  , enemy :: FleetResult f
  }

type CombinedBattleResult f =
  { main :: FleetResult f
  , enemy :: FleetResult f
  , escort :: FleetResult f
  }

liftToFFI :: (Array (Maybe DameCon) -> Battle -> BattleResult Maybe)
          -> Fn2 (Array Int) Battle (BattleResult Nullable)
liftToFFI f = mkFn2 (\ds b -> convert (f (readDameCon ds) b))
  where
    convert s = { main: map toNullable s.main
                , enemy: map toNullable s.enemy }

liftToFFICombined :: (Array (Maybe DameCon) -> Battle -> CombinedBattleResult Maybe)
                  -> Fn2 (Array Int) Battle (CombinedBattleResult Nullable)
liftToFFICombined f = mkFn2 (\ds b -> convert (f (readDameCon ds) b))
  where
    convert s = { main: map toNullable s.main
                , enemy: map toNullable s.enemy
                , escort: map toNullable s.escort }

analyzeBattleJS :: Fn2 (Array Int) Battle (BattleResult Nullable)
analyzeBattleJS = liftToFFI analyzeBattle

analyzeNightBattleJS :: Fn2 (Array Int) Battle (BattleResult Nullable)
analyzeNightBattleJS = liftToFFI analyzeNightBattle

analyzeSTFBattleJS :: Fn2 (Array Int) Battle (CombinedBattleResult Nullable)
analyzeSTFBattleJS = liftToFFICombined analyzeSTFBattle

analyzeCTFBattleJS :: Fn2 (Array Int) Battle (CombinedBattleResult Nullable)
analyzeCTFBattleJS = liftToFFICombined analyzeCTFBattle

analyzeTECFBattleJS :: Fn2 (Array Int) Battle (CombinedBattleResult Nullable)
analyzeTECFBattleJS = liftToFFICombined analyzeTECFBattle

analyzeCombinedNightBattleJS :: Fn2 (Array Int) Battle (BattleResult Nullable)
analyzeCombinedNightBattleJS = liftToFFI analyzeCombinedNightBattle

module KanColle.DamageAnalysisFFI where

import Prelude
import KanColle.Util
import KanColle.DamageAnalysis.Damage
import KanColle.DamageAnalysis2
import KanColle.KCAPI.Battle
import Data.Foreign
import Data.Maybe
import Data.Array
import Data.Function
import Data.Nullable

readDameCon :: Array Int -> Array (Maybe DameCon)
readDameCon = map convert
  where
    convert :: Int -> Maybe DameCon
    convert 0 = Nothing
    convert 1 = Just RepairTeam
    convert 2 = Just RepairGodness
    convert x = throwWith ("readDameCon: invalid input: " <> show x)

dc6 :: Array (Maybe DameCon)
dc6 = replicate 6 Nothing

dc12 :: Array (Maybe DameCon)
dc12 = replicate 12 Nothing

analyzeBattleJS :: Fn2 (Array Int) Battle { main :: Array (Nullable ShipResult)
                                          , enemy :: Array (Nullable ShipResult)}
analyzeBattleJS = mkFn2 (\ds b -> convert (analyzeBattle (readDameCon ds) b))
  where
    convert s = { main: map toNullable s.main
                , enemy: map toNullable s.enemy }

analyzeNightBattleJS :: Fn2 (Array Int) Battle { main :: Array (Nullable ShipResult)
                                               , enemy :: Array (Nullable ShipResult)}
analyzeNightBattleJS = mkFn2 (\ds b -> convert (analyzeNightBattle (readDameCon ds) b))
  where
    convert s = { main: map toNullable s.main
                , enemy: map toNullable s.enemy }


Add more tests for customEOA

Add more tests for customEOA

module Test.Spec.CompilerSpec (parserGenSpec) where

import Prelude
import Debug.Trace
import Data.Tuple (Tuple(..))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Either (Either(..), either)
import Data.List (List(..), toList, length, fromList, singleton)
import Data.Map (Map(..))
import Data.StrMap as StrMap
import Data.StrMap (StrMap())
import Data.Tuple (uncurry)
import Data.Map as Map
import Data.Array as A
import Data.Foldable (for_, intercalate)
import Control.Monad.Eff.Exception (error, throwException)
import Text.Parsing.Parser as P

import Test.Assert (assert)
import Test.Spec (describe, it, Spec())
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff)
import Test.Support.Arguments

import Language.Docopt (parseDocopt)
import Language.Docopt.Errors
import Language.Docopt.Argument
import Language.Docopt.Value
import Language.Docopt.Usage
import Language.Docopt.Env (Env())
import Language.Docopt.Compiler (genParser, runParser)
import Language.Docopt.Argument   as D
import Language.Docopt.Env        as Env
import Language.Docopt.Trans.Flat as T
import Test.Support.Docopt        as D

type Options =  { customEOA    :: Array String
                , optionsFirst :: Boolean
                }

type Test = { help  :: String
            , cases :: Array Case
            }

type Case = { argv     :: Array String
            , env      :: Array (Tuple String String)
            , expected :: Either String (StrMap Value)
            , options  :: Maybe Options
            }

test :: String     -- ^ The help text
     -> Array Case -- ^ The array of test cases to cover
     -> Test
test help ks = { help: help, cases: ks }

pass ::  Maybe Options                -- ^ The options
      -> Array String                 -- ^ ARGV
      -> (Array (Tuple String Value)) -- ^ The expected output
      -> Case
pass opts i o = { argv:     i
                , env:      []
                , options:  opts
                , expected: Right $ StrMap.fromList $ toList o
                }

pass' :: Maybe Options                 -- ^ The options
      -> Array String                  -- ^ ARGV
      -> (Array (Tuple String String)) -- ^ The environment
      -> (Array (Tuple String Value))  -- ^ The expected output
      -> Case
pass' opts i e o = { argv:     i
                   , env:      e
                   , options:  opts
                   , expected: Right $ StrMap.fromList $ toList o
                   }

fail :: Array String -- ^ ARGV
      -> String      -- ^ The expected error message
      -> Case
fail i e = { argv: i, env: [],  expected: Left e, options: Nothing }

fail' :: Array String                  -- ^ ARGV
      -> (Array (Tuple String String)) -- ^ The environment
      -> String                        -- ^ The expected error message
      -> Case
fail' i e err = { argv: i, env: e, expected: Left err, options: Nothing }

(:>) = Tuple
infixr 0 :>

parserGenSpec = \_ -> describe "The parser generator" do
  it "" do
    pure unit

  -- Some options that will be used for these tests
  let testCases = [
      test
        "usage: prog <qux>..."
        [ pass Nothing
            [ "a", "b", "c" ]
            [ "<qux>" :> D.array [ D.str "a", D.str "b", D.str "c" ]
            ]
        , fail [ "--foo", "baz" ]
            "Expected <qux>..., but got --foo"
        , fail
            [ "a", "--foo", "-f=10" ]
            "Unmatched option: --foo"
        ]

    , test
        "usage: prog <qux>... --"
        [ pass Nothing
            [ "a", "b", "c", "--" ]
            [ "<qux>" :> D.array [ D.str "a", D.str "b", D.str "c" ]
            , "--"    :> D.array []
            ]
        , pass Nothing
            [ "a", "b", "c", "--", "--", "--" ]
            [ "<qux>" :> D.array [ D.str "a", D.str "b", D.str "c" ]
            , "--"    :> D.array [ D.str "--" , D.str "--" ]
            ]
        ]

    , test
        """
        usage: prog [options]
        options:
          -h, --host <host[:port]> [default: "http://localhost:3000"]
        """
        [ pass
            Nothing
            [ "-hhttp://localhost:5000" ]
            [ "-h"     :> D.str "http://localhost:5000"
            , "--host" :> D.str "http://localhost:5000"
            ]
        ]

    , test
        """
        usage: prog [options]
        options:
          -h, --host FOO [default: BAR] [env: HOST]
        """
        [ pass'
            Nothing
            []
            [ "HOST" :> "HOME" ]
            [ "-h"     :> D.str "HOME"
            , "--host" :> D.str "HOME"
            ]
        ]

    , test
        """
        usage: prog (-iFILE)
        options:
          -i, --input FILE
        """
        [ fail [] "Expected option(s): -i|--input=FILE"
        , pass Nothing
            [ "-i", "bar" ]
            [ "-i"      :> D.str "bar"
            , "--input" :> D.str "bar" ]
        ]

    , test
        """
        usage: prog (-iFILE) -oFILE
        options:
          -i, --input FILE
          -o, --output FILE
        """
        [ fail []
          $ "Expected option(s): -i|--input=FILE, -o|--output=FILE"

        , fail [ "-i", "bar" ]
          $ "Expected option(s): -o|--output=FILE"

        , pass Nothing
            [ "-i", "bar", "-o", "bar" ]
            [ "--input"  :> D.str "bar"
            , "-i"       :> D.str "bar"
            , "--output" :> D.str "bar"
            , "-o"       :> D.str "bar" ]

          -- group should be interchangable if it's only of options:
        , pass Nothing
            [ "-o", "bar", "-i", "bar" ]
            [ "--input"  :> D.str "bar"
            , "-i"       :> D.str "bar"
            , "--output" :> D.str "bar"
            , "-o"       :> D.str "bar" ]
        ]

    , test
        """
        usage: prog ((-iFILE) -rFILE) -oFILE
        options:
          -i, --input FILE
          -o, --output FILE
          -r, --redirect FILE [env: QUX]
        """
        [ fail []
          $ "Expected option(s): -i|--input=FILE -r|--redirect=FILE, -o|--output=FILE"

        , fail [ "-i", "bar", "-r", "bar" ]
            "Expected option(s): -o|--output=FILE"

        , pass Nothing
            [ "-i", "bar", "-r", "bar", "-o", "bar" ]
            [ "--input"    :> D.str "bar"
            , "-i"         :> D.str "bar"
            , "--redirect" :> D.str "bar"
            , "-r"         :> D.str "bar"
            , "--output"   :> D.str "bar"
            , "-o"         :> D.str "bar" ]

          -- group should be interchangable if it's only of options:
        , pass Nothing
            [ "-o", "bar", "-r", "bar", "-i", "bar" ]
            [ "--input"    :> D.str "bar"
            , "-i"         :> D.str "bar"
            , "--redirect" :> D.str "bar"
            , "-r"         :> D.str "bar"
            , "--output"   :> D.str "bar"
            , "-o"         :> D.str "bar" ]

        , pass' Nothing
            [ "-o", "bar", "-i", "bar" ]
            [ "QUX" :> "BAR" ]
            [ "--input"    :> D.str "bar"
            , "-i"         :> D.str "bar"
            , "--redirect" :> D.str "BAR"
            , "-r"         :> D.str "BAR"
            , "--output"   :> D.str "bar"
            , "-o"         :> D.str "bar" ]
        ]

    , test
        """
        usage: prog ((-i FILE) <env>) -oFILE
        options:
          -i, --input FILE
          -o, --output FILE
          -r, --redirect FILE
        """
        [ fail [] "Expected option(s): -i|--input=FILE"
          -- XXX: Would be cool to show the reason the group did not parse!
        , fail [ "-i", "bar" ] "Expected <env>"
        , pass Nothing
            [ "-i", "bar", "x", "-o", "bar" ]
            [ "--input"  :> D.str "bar"
            , "-i"       :> D.str "bar"
            , "<env>"    :> D.str "x"
            , "--output" :> D.str "bar"
            , "-o"       :> D.str "bar" ]
          -- group should NOT be interchangable if it contains non-options:
        , fail [ "-o", "bar", "x", "-i", "bar" ]
            "Expected option(s): -i|--input=FILE"
        ]

    , test
        """
        usage: prog [options]
        options:
          -o, --out FOO [env: FOO]
        """
        [ pass' Nothing
            []
            [ "FOO"    :> "BAR" ]
            [  "--out" :> D.str "BAR"
            ,  "-o"    :> D.str "BAR" ]
        ]

    , test
        """
        usage: prog [options]
        options:
          -o, --out FOO [default: "ADLER"] [env: FOO]
        """
        [ pass' Nothing
            []
            [ "FOO" :> "BAR" ]
            [  "--out" :> D.str "BAR"
            ,  "-o"    :> D.str "BAR" ]
        ]

    , test
        """
        usage: prog -a
           or: prog -b
        """
        [ pass Nothing
            [ "-a" ]
            [ "-a" :> D.bool true ]
        , pass Nothing
            [ "-b" ]
            [ "-b" :> D.bool true ]
        , pass Nothing
            []
            []
        ]

    , test
        """
        usage: prog a
           or: prog b
        """
        [ pass Nothing
            [ "a" ]
            [ "a" :> D.bool true ]
        , pass Nothing
            [ "b" ]
            [ "b" :> D.bool true ]
        , fail
            [ "a", "b" ]
            "Unmatched command: b"
        , fail
            [ "b", "a" ]
            "Unmatched command: a"
        , fail [] ""
        ]

    , test
        """
        usage: prog foo -io -q... -b=BAZ -f=FOZ... baz
        options:
          -i, --input
          -o, --out
          -q, --qux...
          -b, --baz BAZ [default: "ax"]
          -f, --foo FOZ...
        """
        [ pass Nothing
            [ "foo", "--out", "--input", "--qux", "--foo=ox", "baz" ]
            [ "foo"     :> D.bool true
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "--qux"   :> D.int 1
            , "-q"      :> D.int 1
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            , "baz"     :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            ]

        , pass Nothing
            [ "foo" , "--out", "-qqq", "--foo=ox", "--baz=ax", "--input", "baz" ]
            [ "foo"     :> D.bool true
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--qux"   :> D.int 3
            , "-q"      :> D.int 3
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "baz"     :> D.bool true
            ]

        , pass Nothing
            [ "foo", "-q", "-o", "--qux", "-i", "--baz=ax", "-f=ox", "baz" ]
            [ "foo"     :> D.bool true
            , "--qux"   :> D.int 2
            , "-q"      :> D.int 2
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            , "baz"     :> D.bool true
            ]

        , pass Nothing
            [ "foo", "--baz=ax", "-o", "-f=ox", "-i", "baz" ]
            [ "foo"     :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "baz"     :> D.bool true
            ]

        , pass Nothing
            [ "foo", "-o", "-i", "-bax", "-f=ox", "baz" ]
            [ "foo"     :> D.bool true
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "baz"     :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            ]

        , fail
            [ "foo" ]
            "Expected option(s): -f|--foo=FOZ..."
        , fail
            [ "foo", "-o", "-i", "-bax" ]
            "Expected option(s): -f|--foo=FOZ..."
        ]

    , test
        """
        usage: prog [foo]
        """
        [ fail [ "goo" ] "Unmatched command: goo" ]

    , test
        """
        usage: prog (foo)
        """
        [ fail [ "goo" ] "Expected foo, but got goo" ]

    , test
        """
        Usage: prog [options]
        options:
          -n
        """
        [ pass
            (Just { customEOA: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { customEOA: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "true", "false" ]
            [ "-n" :> D.array [ D.str "true",  D.str "false" ] ]
        ]

    , test
        """
        Usage: prog [options]
        options:
          -n...
        """
        [ pass
            (Just { customEOA: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { customEOA: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "true", "false" ]
            [ "-n" :> D.array [ D.str "true",  D.str "false" ] ]
        ]

    , test
        """
        Usage: prog [options]
        options:
          -n[=FOO]
        """
        [ pass
            (Just { customEOA: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { customEOA: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "true", "false" ]
            [ "-n" :> D.array [ D.str "true",  D.str "false" ] ]
        ]

    , test
        """
        Usage: prog [options]
        options:
          -n[=FOO]...
        """
        [ pass
            (Just { customEOA: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { customEOA: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "true", "false" ]
            [ "-n" :> D.array [ D.str "true",  D.str "false" ] ]
        ]

    , test
        """
        Usage: prog [options]
        options:
          -n, --noop
        """
        [ pass
            (Just { customEOA: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n"     :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ]
            , "--noop" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { customEOA: [ "--noop" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n"     :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ]
            , "--noop" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { customEOA: [ "-n", "--noop" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n"     :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ]
            , "--noop" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        ]

    , test
        """
        Usage: prog [options]
        options:
          -n ARC
        """
        [ pass
            (Just { customEOA: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        ]

    , test
        """
        Usage: prog ((((foo|bar)|qux)|wux)|-n ARC)
        options:
          -n ARC
        """
        [ pass
            (Just { customEOA: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        ]

    , test
        """
        Usage: prog ((((foo|bar)|-n ARC)|wux))
        options:
          -n ARC
        """
        [ pass
            (Just { customEOA: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        ]
  ]

  for_ testCases \(({ help, cases })) -> do
    describe help do
      for_ cases \(({ argv, env, expected, options })) ->
            let msg = either (\e -> "Should fail with \"" <> e <> "\"")
                              prettyPrintOut
                              expected
                premsg = if A.length argv > 0
                            then intercalate " " argv
                            else "(no input)"
            in it (premsg <> " -> " <> msg) do
                  vliftEff do
                    { specification } <- runEitherEff do
                      parseDocopt help { smartOptions: true }
                    validate (specification)
                             argv
                             (Env.fromFoldable env)
                             options
                             expected

    where

      prettyPrintOut :: StrMap Value -> String
      prettyPrintOut m = "\n\t" <> prettyPrintStrMap m

      prettyPrintStrMap :: StrMap Value -> String
      prettyPrintStrMap m = intercalate "\n\t" $
        StrMap.toList m <#> \(Tuple arg val) ->
          arg <> " => " <> prettyPrintValue val

      validate :: forall eff.  List Usage
                            -> Array String
                            -> Env
                            -> Maybe Options
                            -> Either String (StrMap Value)
                            -> Eff (err :: EXCEPTION | eff) Unit
      validate spec argv env options expected = do
        let result = uncurry (T.reduce spec env)
                <$> runParser
                      env
                      argv
                      (genParser spec (fromMaybe {
                        optionsFirst: false
                      , customEOA:    []
                      } options))

        case result of
          Left (e@(P.ParseError { message: msg })) ->
            either
              (\e' ->
                if (msg /= e')
                  then throwException $ error $
                    "Unexpected error:\n" <> msg
                  else return unit)
              (const $ throwException $ error $ show e)
              expected
          Right r -> do
            either
              (\e ->
                throwException $ error $
                  "Missing expected exception:"
                    <> "\n"
                    <> show e
                    <> "\n"
                    <> "\n"
                    <> "instead received output:"
                    <> "\n"
                    <> prettyPrintOut r)
              (\r' ->
                if (r /= r')
                  then throwException $ error $
                    "Unexpected output:\n"
                      <> prettyPrintOut r
                  else return unit)
              expected

module Test.Spec.CompilerSpec (parserGenSpec) where

import Prelude
import Debug.Trace
import Data.Tuple (Tuple(..))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Exception (EXCEPTION())
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Either (Either(..), either)
import Data.List (List(..), toList, length, fromList, singleton)
import Data.Map (Map(..))
import Data.StrMap as StrMap
import Data.StrMap (StrMap())
import Data.Tuple (uncurry)
import Data.Map as Map
import Data.Array as A
import Data.Foldable (for_, intercalate)
import Control.Monad.Eff.Exception (error, throwException)
import Text.Parsing.Parser as P

import Test.Assert (assert)
import Test.Spec (describe, it, Spec())
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Assert.Simple
import Test.Support (vliftEff, runMaybeEff, runEitherEff)
import Test.Support.Arguments

import Language.Docopt (parseDocopt)
import Language.Docopt.Errors
import Language.Docopt.Argument
import Language.Docopt.Value
import Language.Docopt.Usage
import Language.Docopt.Env (Env())
import Language.Docopt.Compiler (genParser, runParser)
import Language.Docopt.Argument   as D
import Language.Docopt.Env        as Env
import Language.Docopt.Trans.Flat as T
import Test.Support.Docopt        as D

type Options =  { customEOA    :: Array String
                , optionsFirst :: Boolean
                }

type Test = { help  :: String
            , cases :: Array Case
            }

type Case = { argv     :: Array String
            , env      :: Array (Tuple String String)
            , expected :: Either String (StrMap Value)
            , options  :: Maybe Options
            }

test :: String     -- ^ The help text
     -> Array Case -- ^ The array of test cases to cover
     -> Test
test help ks = { help: help, cases: ks }

pass ::  Maybe Options                -- ^ The options
      -> Array String                 -- ^ ARGV
      -> (Array (Tuple String Value)) -- ^ The expected output
      -> Case
pass opts i o = { argv:     i
                , env:      []
                , options:  opts
                , expected: Right $ StrMap.fromList $ toList o
                }

pass' :: Maybe Options                 -- ^ The options
      -> Array String                  -- ^ ARGV
      -> (Array (Tuple String String)) -- ^ The environment
      -> (Array (Tuple String Value))  -- ^ The expected output
      -> Case
pass' opts i e o = { argv:     i
                   , env:      e
                   , options:  opts
                   , expected: Right $ StrMap.fromList $ toList o
                   }

fail :: Array String -- ^ ARGV
      -> String      -- ^ The expected error message
      -> Case
fail i e = { argv: i, env: [],  expected: Left e, options: Nothing }

fail' :: Array String                  -- ^ ARGV
      -> (Array (Tuple String String)) -- ^ The environment
      -> String                        -- ^ The expected error message
      -> Case
fail' i e err = { argv: i, env: e, expected: Left err, options: Nothing }

(:>) = Tuple
infixr 0 :>

parserGenSpec = \_ -> describe "The parser generator" do
  it "" do
    pure unit

  -- Some options that will be used for these tests
  let testCases = [
      test
        "usage: prog <qux>..."
        [ pass Nothing
            [ "a", "b", "c" ]
            [ "<qux>" :> D.array [ D.str "a", D.str "b", D.str "c" ]
            ]
        , fail [ "--foo", "baz" ]
            "Expected <qux>..., but got --foo"
        , fail
            [ "a", "--foo", "-f=10" ]
            "Unmatched option: --foo"
        ]

    , test
        "usage: prog <qux>... --"
        [ pass Nothing
            [ "a", "b", "c", "--" ]
            [ "<qux>" :> D.array [ D.str "a", D.str "b", D.str "c" ]
            , "--"    :> D.array []
            ]
        , pass Nothing
            [ "a", "b", "c", "--", "--", "--" ]
            [ "<qux>" :> D.array [ D.str "a", D.str "b", D.str "c" ]
            , "--"    :> D.array [ D.str "--" , D.str "--" ]
            ]
        ]

    , test
        """
        usage: prog [options]
        options:
          -h, --host <host[:port]> [default: "http://localhost:3000"]
        """
        [ pass
            Nothing
            [ "-hhttp://localhost:5000" ]
            [ "-h"     :> D.str "http://localhost:5000"
            , "--host" :> D.str "http://localhost:5000"
            ]
        ]

    , test
        """
        usage: prog [options]
        options:
          -h, --host FOO [default: BAR] [env: HOST]
        """
        [ pass'
            Nothing
            []
            [ "HOST" :> "HOME" ]
            [ "-h"     :> D.str "HOME"
            , "--host" :> D.str "HOME"
            ]
        ]

    , test
        """
        usage: prog (-iFILE)
        options:
          -i, --input FILE
        """
        [ fail [] "Expected option(s): -i|--input=FILE"
        , pass Nothing
            [ "-i", "bar" ]
            [ "-i"      :> D.str "bar"
            , "--input" :> D.str "bar" ]
        ]

    , test
        """
        usage: prog (-iFILE) -oFILE
        options:
          -i, --input FILE
          -o, --output FILE
        """
        [ fail []
          $ "Expected option(s): -i|--input=FILE, -o|--output=FILE"

        , fail [ "-i", "bar" ]
          $ "Expected option(s): -o|--output=FILE"

        , pass Nothing
            [ "-i", "bar", "-o", "bar" ]
            [ "--input"  :> D.str "bar"
            , "-i"       :> D.str "bar"
            , "--output" :> D.str "bar"
            , "-o"       :> D.str "bar" ]

          -- group should be interchangable if it's only of options:
        , pass Nothing
            [ "-o", "bar", "-i", "bar" ]
            [ "--input"  :> D.str "bar"
            , "-i"       :> D.str "bar"
            , "--output" :> D.str "bar"
            , "-o"       :> D.str "bar" ]
        ]

    , test
        """
        usage: prog ((-iFILE) -rFILE) -oFILE
        options:
          -i, --input FILE
          -o, --output FILE
          -r, --redirect FILE [env: QUX]
        """
        [ fail []
          $ "Expected option(s): -i|--input=FILE -r|--redirect=FILE, -o|--output=FILE"

        , fail [ "-i", "bar", "-r", "bar" ]
            "Expected option(s): -o|--output=FILE"

        , pass Nothing
            [ "-i", "bar", "-r", "bar", "-o", "bar" ]
            [ "--input"    :> D.str "bar"
            , "-i"         :> D.str "bar"
            , "--redirect" :> D.str "bar"
            , "-r"         :> D.str "bar"
            , "--output"   :> D.str "bar"
            , "-o"         :> D.str "bar" ]

          -- group should be interchangable if it's only of options:
        , pass Nothing
            [ "-o", "bar", "-r", "bar", "-i", "bar" ]
            [ "--input"    :> D.str "bar"
            , "-i"         :> D.str "bar"
            , "--redirect" :> D.str "bar"
            , "-r"         :> D.str "bar"
            , "--output"   :> D.str "bar"
            , "-o"         :> D.str "bar" ]

        , pass' Nothing
            [ "-o", "bar", "-i", "bar" ]
            [ "QUX" :> "BAR" ]
            [ "--input"    :> D.str "bar"
            , "-i"         :> D.str "bar"
            , "--redirect" :> D.str "BAR"
            , "-r"         :> D.str "BAR"
            , "--output"   :> D.str "bar"
            , "-o"         :> D.str "bar" ]
        ]

    , test
        """
        usage: prog ((-i FILE) <env>) -oFILE
        options:
          -i, --input FILE
          -o, --output FILE
          -r, --redirect FILE
        """
        [ fail [] "Expected option(s): -i|--input=FILE"
          -- XXX: Would be cool to show the reason the group did not parse!
        , fail [ "-i", "bar" ] "Expected <env>"
        , pass Nothing
            [ "-i", "bar", "x", "-o", "bar" ]
            [ "--input"  :> D.str "bar"
            , "-i"       :> D.str "bar"
            , "<env>"    :> D.str "x"
            , "--output" :> D.str "bar"
            , "-o"       :> D.str "bar" ]
          -- group should NOT be interchangable if it contains non-options:
        , fail [ "-o", "bar", "x", "-i", "bar" ]
            "Expected option(s): -i|--input=FILE"
        ]

    , test
        """
        usage: prog [options]
        options:
          -o, --out FOO [env: FOO]
        """
        [ pass' Nothing
            []
            [ "FOO"    :> "BAR" ]
            [  "--out" :> D.str "BAR"
            ,  "-o"    :> D.str "BAR" ]
        ]

    , test
        """
        usage: prog [options]
        options:
          -o, --out FOO [default: "ADLER"] [env: FOO]
        """
        [ pass' Nothing
            []
            [ "FOO" :> "BAR" ]
            [  "--out" :> D.str "BAR"
            ,  "-o"    :> D.str "BAR" ]
        ]

    , test
        """
        usage: prog -a
           or: prog -b
        """
        [ pass Nothing
            [ "-a" ]
            [ "-a" :> D.bool true ]
        , pass Nothing
            [ "-b" ]
            [ "-b" :> D.bool true ]
        , pass Nothing
            []
            []
        ]

    , test
        """
        usage: prog a
           or: prog b
        """
        [ pass Nothing
            [ "a" ]
            [ "a" :> D.bool true ]
        , pass Nothing
            [ "b" ]
            [ "b" :> D.bool true ]
        , fail
            [ "a", "b" ]
            "Unmatched command: b"
        , fail
            [ "b", "a" ]
            "Unmatched command: a"
        , fail [] ""
        ]

    , test
        """
        usage: prog foo -io -q... -b=BAZ -f=FOZ... baz
        options:
          -i, --input
          -o, --out
          -q, --qux...
          -b, --baz BAZ [default: "ax"]
          -f, --foo FOZ...
        """
        [ pass Nothing
            [ "foo", "--out", "--input", "--qux", "--foo=ox", "baz" ]
            [ "foo"     :> D.bool true
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "--qux"   :> D.int 1
            , "-q"      :> D.int 1
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            , "baz"     :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            ]

        , pass Nothing
            [ "foo" , "--out", "-qqq", "--foo=ox", "--baz=ax", "--input", "baz" ]
            [ "foo"     :> D.bool true
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--qux"   :> D.int 3
            , "-q"      :> D.int 3
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "baz"     :> D.bool true
            ]

        , pass Nothing
            [ "foo", "-q", "-o", "--qux", "-i", "--baz=ax", "-f=ox", "baz" ]
            [ "foo"     :> D.bool true
            , "--qux"   :> D.int 2
            , "-q"      :> D.int 2
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            , "baz"     :> D.bool true
            ]

        , pass Nothing
            [ "foo", "--baz=ax", "-o", "-f=ox", "-i", "baz" ]
            [ "foo"     :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "baz"     :> D.bool true
            ]

        , pass Nothing
            [ "foo", "-o", "-i", "-bax", "-f=ox", "baz" ]
            [ "foo"     :> D.bool true
            , "--out"   :> D.bool true
            , "-o"      :> D.bool true
            , "--input" :> D.bool true
            , "-i"      :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "baz"     :> D.bool true
            , "--baz"   :> D.str "ax"
            , "-b"      :> D.str "ax"
            , "--foo"   :> D.array [ D.str "ox" ]
            , "-f"      :> D.array [ D.str "ox" ]
            ]

        , fail
            [ "foo" ]
            "Expected option(s): -f|--foo=FOZ..."
        , fail
            [ "foo", "-o", "-i", "-bax" ]
            "Expected option(s): -f|--foo=FOZ..."
        ]

    , test
        """
        usage: prog [foo]
        """
        [ fail [ "goo" ] "Unmatched command: goo" ]

    , test
        """
        usage: prog (foo)
        """
        [ fail [ "goo" ] "Expected foo, but got goo" ]

    , test
        """
        Usage: prog [options]
        options:
          -n
        """
        [ pass
            (Just { customEOA: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { customEOA: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "true", "false" ]
            [ "-n" :> D.array [ D.str "true",  D.str "false" ] ]
        ]

    , test
        """
        Usage: prog [options]
        options:
          -n, --noop
        """
        [ pass
            (Just { customEOA: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n"     :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ]
            , "--noop" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { customEOA: [ "--noop" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n"     :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ]
            , "--noop" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        , pass
            (Just { customEOA: [ "-n", "--noop" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n"     :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ]
            , "--noop" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        ]

    , test
        """
        Usage: prog [options]
        options:
          -n ARC
        """
        [ pass
            (Just { customEOA: [ "-n" ]
                  , optionsFirst: true
                  })
            [ "-n", "-a", "-b", "-c" ]
            [ "-n" :> D.array [ D.str "-a",  D.str "-b",  D.str "-c" ] ]
        ]
  ]

  for_ testCases \(({ help, cases })) -> do
    describe help do
      for_ cases \(({ argv, env, expected, options })) ->
            let msg = either (\e -> "Should fail with \"" <> e <> "\"")
                              prettyPrintOut
                              expected
                premsg = if A.length argv > 0
                            then intercalate " " argv
                            else "(no input)"
            in it (premsg <> " -> " <> msg) do
                  vliftEff do
                    { specification } <- runEitherEff do
                      parseDocopt help { smartOptions: true }
                    validate (specification)
                             argv
                             (Env.fromFoldable env)
                             options
                             expected

    where

      prettyPrintOut :: StrMap Value -> String
      prettyPrintOut m = "\n\t" <> prettyPrintStrMap m

      prettyPrintStrMap :: StrMap Value -> String
      prettyPrintStrMap m = intercalate "\n\t" $
        StrMap.toList m <#> \(Tuple arg val) ->
          arg <> " => " <> prettyPrintValue val

      validate :: forall eff.  List Usage
                            -> Array String
                            -> Env
                            -> Maybe Options
                            -> Either String (StrMap Value)
                            -> Eff (err :: EXCEPTION | eff) Unit
      validate spec argv env options expected = do
        let result = uncurry (T.reduce spec env)
                <$> runParser
                      env
                      argv
                      (genParser spec (fromMaybe {
                        optionsFirst: false
                      , customEOA:    []
                      } options))

        case result of
          Left (e@(P.ParseError { message: msg })) ->
            either
              (\e' ->
                if (msg /= e')
                  then throwException $ error $
                    "Unexpected error:\n" <> msg
                  else return unit)
              (const $ throwException $ error $ show e)
              expected
          Right r -> do
            either
              (\e ->
                throwException $ error $
                  "Missing expected exception:"
                    <> "\n"
                    <> show e
                    <> "\n"
                    <> "\n"
                    <> "instead received output:"
                    <> "\n"
                    <> prettyPrintOut r)
              (\r' ->
                if (r /= r')
                  then throwException $ error $
                    "Unexpected output:\n"
                      <> prettyPrintOut r
                  else return unit)
              expected


Tests for referential equality

Tests for referential equality

module Main where

import Prelude
import Eff
import QuickCheck

testConst :: Number -> Number -> Number -> Boolean
testConst a b c = const a b == const a c

testReadShow :: Number -> Boolean
testReadShow a = a == read (show a)

main = do
  Trace.trace "testConst:"
  quickCheck testConst

  Trace.trace "testReadShow:"
  quickCheck testReadShow

  Trace.trace "Precedence of && and ||:"
  quickCheck $ \a b c -> ((a :: Boolean && b) || c) == ((a || c) && (b || c))

  Trace.trace "Test Eq instance for Ref:"
  quickCheck $ \a -> (Ref a :: Ref Number) == Ref a
  quickCheck $ \a -> not $ (Ref a :: Ref Number /= Ref a)