fixed sharing loading

fixed sharing loading

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

import SlamData.Prelude

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

import Data.Array as Arr
import Data.String as Str
import Data.Path.Pathy (rootDir, (</>), file)
import Data.Path.Pathy as Pt

import DOM.HTML.Types (HTMLElement, htmlElementToElement)

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.CustomProps as Cp
import Halogen.Themes.Bootstrap3 as B
import Halogen.Component.Utils (raise)

import Quasar.Advanced.Types as QT

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

import Utils.Path (FilePath, DirPath, rootFile)

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

data SubjectType
  = User
  | Group
  | Token

derive instance subjectTypeEq ∷ Eq SubjectType

data ErrorType
  = Connection
  | Validation

derive instance errorTypeEq ∷ Eq ErrorType

-- This is utility function that should be used only in
-- select/option stuff
readSubjectType ∷ String → SubjectType
readSubjectType "user" = User
readSubjectType "group" = Group
readSubjectType "token" = Token
readSubjectType _ = User

-- Same with `readSubjectType`
readShareResume ∷ String → ShareResume
readShareResume "edit" = Edit
readShareResume _ = View

printShareResume ∷ ShareResume → String
printShareResume Edit = "Edit"
printShareResume View = "View"

-- It would be better if all this Boolean stuff was replaced with
-- some kind of ADT abstracting automata.
type State =
  { subjectType ∷ SubjectType
  , error ∷ Maybe ErrorType
  , email ∷ String
    -- Actually should be Group from purescript-quasar
  , groups ∷ Array FilePath
  , groupSelected ∷ Maybe FilePath
  , tokenName ∷ String
  , loading ∷ Boolean
  , showError ∷ Boolean
  , submitting ∷ Boolean
  , shareResume ∷ ShareResume
  , tokenSecret ∷ Maybe String
  , deckPath ∷ DirPath
  }

initialState ∷ DirPath → State
initialState deckPath =
  { subjectType: User
  , error: Nothing
  , email: ""
  , groups: [ ]
  , groupSelected: Nothing
  , tokenName: ""
  , loading: true
  , showError: false
  , submitting: false
  , shareResume: View
  , tokenSecret: Nothing
  , deckPath
  }

data Query a
  = Dismiss a
  | Share a
  | ChangeSubjectType SubjectType a
  | EmailChanged String a
  | DismissError a
  | Init a
  | GroupSelected String a
  | TokenNameChanged String a
  | ChangeShareResume ShareResume a
  | InitZClipboard String (Maybe HTMLElement) a
  | SelectElement HTMLElement a

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

render ∷ State → HTML
render state =
  HH.div [ HP.classes [ HH.className "deck-dialog-share" ] ]
   $ (case state.tokenSecret of
         Nothing → [ HH.h4_ [ HH.text "Share deck" ] ]
         Just _ →
           [ HH.h4_ [ HH.text if state.tokenName ≡ ""
                              then "Untitled token"
                              else state.tokenName ⊕ " token"
                    ]
           , HH.h5_ [ HH.text $ printShareResume state.shareResume ]
           ])
  ⊕ [  HH.div
       [ HP.classes [ HH.className "deck-dialog-body" ]
       , HE.onClick ( HE.input_ DismissError )
       ]
       $ [ HH.div
             [ HP.classes
                 $ [ B.alert, B.alertInfo, HH.className "share-loading" ]
                 ⊕ if state.loading then [ ] else [ B.hidden ]
             ]
             [ HH.img [ HP.src "img/blue-spin.svg" ]
             , HH.text "Loading"
             ]
         ]
       ⊕ (flip foldMap state.tokenSecret \token →
           [ HH.form
               [ Cp.nonSubmit
               , HP.classes $ if state.loading then [ B.hidden ] else [ ]
               ]

               [ HH.div
                   [ HP.classes [ B.inputGroup ]
                   , HE.onClick $ HE.input (SelectElement ∘ _.target)
                   ]
                   [ HH.input
                       [ HP.classes [ B.formControl ]
                       , HP.value token
                       , HP.readonly true
                       , HP.title "Token secret"
                       ]
                   , HH.span
                       [ HP.classes [ B.inputGroupBtn ] ]
                       [ HH.button
                           [ HP.classes [ B.btn, B.btnDefault ]
                           , HP.ref (H.action ∘ InitZClipboard token)
                           , HP.id_ "copy-button"
                           ]
                           [ glyph B.glyphiconCopy ]
                       ]
                   ]
               ]
           ])
       ⊕ [ HH.form
             [ Cp.nonSubmit
             , HP.classes if isJust state.tokenSecret ∨ state.loading then [ B.hidden ] else [ ]
             ]
             [ HH.div [ HP.classes [ B.row ] ]
                 [ HH.div [ HP.classes [ B.colXs3 ] ]
                     [ HH.label_
                         [ HH.text "Subject type"
                         , HH.select
                             [ HP.classes [ B.formControl ]
                             , HE.onValueChange (HE.input (ChangeSubjectType ∘ readSubjectType))
                             , HP.disabled state.submitting
                             ]
                             [ HH.option
                                 [ HP.value "user" ]
                                 [ HH.text "User" ]
                             , HH.option
                                 [ HP.value "group" ]
                                 [ HH.text "Group" ]
                             , HH.option
                                 [ HP.value "token" ]
                                 [ HH.text "Token" ]
                             ]
                         ]
                     ]
                 , HH.div [ HP.classes [ B.colXs6 ] ]
                     [ HH.label
                         [ HP.classes
                             $ (if state.subjectType ≠ User then [ B.hidden ] else [ ])
                             ⊕ (if state.error ≡ Just Validation then [ B.hasError ] else [ ])
                         ]
                         [ HH.text "User email"
                         , HH.input
                             [ HP.classes [ B.formControl ]
                             , HP.value state.email
                             , HE.onValueInput $ HE.input EmailChanged
                             , HP.placeholder "User email"
                             , HP.inputType HP.InputText
                             , HP.disabled state.submitting
                             ]
                         ]
                     , HH.label
                         [ HP.classes $ if state.subjectType ≠ Group then [ B.hidden ] else [ ]
                         ]
                         [ HH.text "Group path"
                         , HH.select
                             [ HP.classes [ B.formControl ]
                             , HE.onValueChange (HE.input GroupSelected)
                             , HP.disabled $ Arr.null state.groups ∨ state.submitting
                             ]
                             -- I find using such things in where a bit complicated
                             -- because it's break context. OTOH, lambdas are not
                             -- so fancy as named func. cryogenian.
                             let
                               renderOption ∷ FilePath → HTML
                               renderOption group =
                                 HH.option
                                   [ HP.value $ Pt.printPath  group ]
                                   [ HH.text $ Pt.printPath  group ]
                             in
                               map renderOption state.groups
                         ]
                     , HH.label
                         [ HP.classes $ if state.subjectType ≠ Token then [ B.hidden ] else [ ]
                         ]
                         [ HH.text "Token name"
                         , HH.input
                             [ HP.classes [ B.formControl ]
                             , HP.inputType HP.InputText
                             , HP.placeholder "Token name"
                             , HP.value state.tokenName
                             , HE.onValueInput (HE.input TokenNameChanged)
                             , HP.disabled state.submitting
                             ]
                         ]
                     ]
                 , HH.div [ HP.classes [ B.colXs3 ] ]
                     [ HH.label_
                         [ HH.text "Permission"
                         , HH.select
                             [ HP.classes [ B.formControl ]
                             , HE.onValueChange (HE.input (ChangeShareResume ∘ readShareResume))
                             , HP.disabled state.submitting
                             ]

                             [ HH.option
                                 [ HP.value "view" ]
                                 [ HH.text "View" ]
                             , HH.option
                                 [ HP.value "edit" ]
                                 [ HH.text "Edit" ]
                             ]
                         ]
                     ]
                 ]
             ]
         ]

   , HH.div [ HP.classes [ HH.className "deck-dialog-footer" ] ]
       $ [ HH.div
           [ HP.classes
               $ [ B.alert, B.alertDanger ]
               ⊕ (if state.showError ∧ state.error ≡ Just Connection then [ ] else [ B.hidden ])
           , HE.onClick (HE.input_ DismissError)
           ]
           [ HH.text
               $ "This action couldn't be performed. "
               ⊕ "Please check your network connection and try again"
           ]
       , HH.div
           [ HP.classes
               $ [ B.alert, B.alertInfo ]
               ⊕ (if state.showError ∧ state.error ≡ Just Validation then [ ] else [ B.hidden ])
           ]
           [ HH.text
               "Please check if user email is correct"
           ]
       , HH.button
           [ HP.classes
               $ [ B.btn, B.btnDefault ]
               ⊕ (if state.loading then [ B.hidden ] else [ ])
           , HP.buttonType HP.ButtonButton
           , HE.onClick (HE.input_ Dismiss)
           , HP.disabled state.submitting
           ]
           [ HH.text "Dismiss" ]
       ]
     ⊕  (if isJust state.tokenSecret
           then [ ]
           else
           [ HH.button
               [ HP.classes
                   $ [ B.btn, B.btnPrimary ]
                   ⊕ (if state.loading then [ B.hidden ] else [ ])
                   ⊕ (if isJust state.error && state.showError then [ B.hasError ] else [ ])
               , HP.buttonType HP.ButtonButton
               , HE.onClick (HE.input_ Share)
               , HP.enabled (not state.submitting)
               ]
               [ HH.text if state.submitting then "Sharing..." else  "Share" ]
           ])
   ]

eval ∷ Query ~> DSL
eval (Dismiss next) = pure next
eval (ChangeSubjectType st next) = do
  H.modify (_{subjectType = st})
  unless (st ≡ User)
    $ H.modify (_{ error = Nothing
                 , showError = false
                 })
  pure next
eval (Share next) = next <$ do
  H.modify (_{ error = Nothing
             , showError = false
             , submitting = true
             })

  H.modify (_{submitting = true})
  state ← H.get

  let
    actions = sharingActions state.deckPath state.shareResume

  if state.subjectType ≡ Token
    then do
    res ←
      Q.createToken
        (if state.tokenName ≡ "" then Nothing else Just $ QT.TokenName state.tokenName)
        actions

    case res of
      Left _ →
        showConnectionError
      Right token →
        H.modify (_{ tokenSecret = QT.runTokenHash <$> token.secret
                   , submitting = false
                   })
    else do
    let
      shareRequest ∷ QT.ShareRequestR
      shareRequest =
        { users: (if state.subjectType ≡ User
                  then map (const $ QT.UserId state.email) actions
                  else [ ])
        , groups: (if state.subjectType ≡ Group
                   then Arr.catMaybes $ map (const $ state.groupSelected) actions
                   else [ ])
        , actions
        }
    res ← Q.sharePermission shareRequest
    case res of
      Left _ →
        showConnectionError
      Right [] →
        showConnectionError
      _ → raise $ H.action Dismiss
eval (DismissError next) =
  H.modify (_{showError = false}) $> next
eval (EmailChanged str next) = do
  let
    incorrectEmail = emailIsIncorrect str
  H.modify (_{email = str})
  mbError ← H.gets _.error
  unless (mbError ≡ Just Connection)
    $ H.modify
      if incorrectEmail
        then (_{ error = Just Validation
               , showError = true
               })
        else (_{ error = Nothing
               , showError = false
               })
  pure next
eval (Init next) = next <$ do
  res ← Q.groupInfo (rootDir </> file "")
  case res of
    Left _ →
      showConnectionError
    Right grInfo →
      H.modify (_{groups = [rootFile] ⊕ grInfo.subGroups })
  H.modify (_{loading = false})
eval (GroupSelected grpString next) = next <$ do
  groups ← H.gets _.groups
  let
    group =
      Arr.findIndex (\x → grpString ≡ Pt.printPath x) groups
      >>= Arr.index groups
  H.modify (_{groupSelected = group})
eval (TokenNameChanged str next) =
  H.modify (_{tokenName = str}) $> next
eval (ChangeShareResume sr next) =
  H.modify (_{shareResume = sr}) $> next
eval (InitZClipboard token mbEl next) =
  next <$ for_ mbEl \el → do
    H.fromEff $ Z.make (htmlElementToElement el)
      >>= Z.onCopy (Z.setData "text/plain" token)
eval (SelectElement el next) =
  next <$ H.fromEff (select el)

emailIsIncorrect ∷ String → Boolean
emailIsIncorrect = not ∘ Str.contains "@"

showConnectionError ∷ DSL Unit
showConnectionError =
  H.modify (_{ error = Just Connection
             , showError = true
             , submitting = false
             })

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

import SlamData.Prelude

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

import Data.Array as Arr
import Data.String as Str
import Data.Path.Pathy (rootDir, (</>), file)
import Data.Path.Pathy as Pt

import DOM.HTML.Types (HTMLElement, htmlElementToElement)

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.CustomProps as Cp
import Halogen.Themes.Bootstrap3 as B
import Halogen.Component.Utils (raise)

import Quasar.Advanced.Types as QT

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

import Utils.Path (FilePath, DirPath, rootFile)

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

data SubjectType
  = User
  | Group
  | Token

derive instance subjectTypeEq ∷ Eq SubjectType

data ErrorType
  = Connection
  | Validation

derive instance errorTypeEq ∷ Eq ErrorType

-- This is utility function that should be used only in
-- select/option stuff
readSubjectType ∷ String → SubjectType
readSubjectType "user" = User
readSubjectType "group" = Group
readSubjectType "token" = Token
readSubjectType _ = User

-- Same with `readSubjectType`
readShareResume ∷ String → ShareResume
readShareResume "edit" = Edit
readShareResume _ = View

printShareResume ∷ ShareResume → String
printShareResume Edit = "Edit"
printShareResume View = "View"

-- It would be better if all this Boolean stuff was replaced with
-- some kind of ADT abstracting automata.
type State =
  { subjectType ∷ SubjectType
  , error ∷ Maybe ErrorType
  , email ∷ String
    -- Actually should be Group from purescript-quasar
  , groups ∷ Array FilePath
  , groupSelected ∷ Maybe FilePath
  , tokenName ∷ String
  , loading ∷ Boolean
  , showError ∷ Boolean
  , submitting ∷ Boolean
  , shareResume ∷ ShareResume
  , tokenSecret ∷ Maybe String
  , deckPath ∷ DirPath
  }

initialState ∷ DirPath → State
initialState deckPath =
  { subjectType: User
  , error: Nothing
  , email: ""
  , groups: [ ]
  , groupSelected: Nothing
  , tokenName: ""
  , loading: true
  , showError: false
  , submitting: false
  , shareResume: View
  , tokenSecret: Nothing
  , deckPath
  }

data Query a
  = Dismiss a
  | Share a
  | ChangeSubjectType SubjectType a
  | EmailChanged String a
  | DismissError a
  | Init a
  | GroupSelected String a
  | TokenNameChanged String a
  | ChangeShareResume ShareResume a
  | InitZClipboard String (Maybe HTMLElement) a
  | SelectElement HTMLElement a

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

render ∷ State → HTML
render state =
  HH.div [ HP.classes [ HH.className "deck-dialog-share" ] ]
   $ (case state.tokenSecret of
         Nothing → [ HH.h4_ [ HH.text "Share deck" ] ]
         Just _ →
           [ HH.h4_ [ HH.text if state.tokenName ≡ ""
                              then "Untitled token"
                              else state.tokenName ⊕ " token"
                    ]
           , HH.h5_ [ HH.text $ printShareResume state.shareResume ]
           ])
  ⊕ [  HH.div
       [ HP.classes [ HH.className "deck-dialog-body" ]
       , HE.onClick ( HE.input_ DismissError )
       ]
       $ [ HH.div
             [ HP.classes
                 $ [ B.alert, B.alertInfo, HH.className "share-loading" ]
                 ⊕ if state.loading then [ ] else [ B.hidden ]
             ]
             [ HH.img [ HP.src "img/blue-spin.svg" ]
             , HH.text "Loading"
             ]
         ]
       ⊕ (flip foldMap state.tokenSecret \token →
           [ HH.form
               [ Cp.nonSubmit
               , HP.classes $ if state.loading then [ B.hidden ] else [ ]
               ]

               [ HH.div
                   [ HP.classes [ B.inputGroup ]
                   , HE.onClick $ HE.input (SelectElement ∘ _.target)
                   ]
                   [ HH.input
                       [ HP.classes [ B.formControl ]
                       , HP.value token
                       , HP.readonly true
                       , HP.title "Token secret"
                       ]
                   , HH.span
                       [ HP.classes [ B.inputGroupBtn ] ]
                       [ HH.button
                           [ HP.classes [ B.btn, B.btnDefault ]
                           , HP.ref (H.action ∘ InitZClipboard token)
                           , HP.id_ "copy-button"
                           ]
                           [ glyph B.glyphiconCopy ]
                       ]
                   ]
               ]
           ])
       ⊕ [ HH.form
             [ Cp.nonSubmit
             , HP.classes if isJust state.tokenSecret ∨ state.loading then [ B.hidden ] else [ ]
             ]
             [ HH.div [ HP.classes [ B.row ] ]
                 [ HH.div [ HP.classes [ B.colXs3 ] ]
                     [ HH.label_
                         [ HH.text "Subject type"
                         , HH.select
                             [ HP.classes [ B.formControl ]
                             , HE.onValueChange (HE.input (ChangeSubjectType ∘ readSubjectType))
                             , HP.disabled state.submitting
                             ]
                             [ HH.option
                                 [ HP.value "user" ]
                                 [ HH.text "User" ]
                             , HH.option
                                 [ HP.value "group" ]
                                 [ HH.text "Group" ]
                             , HH.option
                                 [ HP.value "token" ]
                                 [ HH.text "Token" ]
                             ]
                         ]
                     ]
                 , HH.div [ HP.classes [ B.colXs6 ] ]
                     [ HH.label
                         [ HP.classes
                             $ (if state.subjectType ≠ User then [ B.hidden ] else [ ])
                             ⊕ (if state.error ≡ Just Validation then [ B.hasError ] else [ ])
                         ]
                         [ HH.text "User email"
                         , HH.input
                             [ HP.classes [ B.formControl ]
                             , HP.value state.email
                             , HE.onValueInput $ HE.input EmailChanged
                             , HP.placeholder "User email"
                             , HP.inputType HP.InputText
                             , HP.disabled state.submitting
                             ]
                         ]
                     , HH.label
                         [ HP.classes $ if state.subjectType ≠ Group then [ B.hidden ] else [ ]
                         ]
                         [ HH.text "Group path"
                         , HH.select
                             [ HP.classes [ B.formControl ]
                             , HE.onValueChange (HE.input GroupSelected)
                             , HP.disabled $ Arr.null state.groups ∨ state.submitting
                             ]
                             -- I find using such things in where a bit complicated
                             -- because it's break context. OTOH, lambdas are not
                             -- so fancy as named func. cryogenian.
                             let
                               renderOption ∷ FilePath → HTML
                               renderOption group =
                                 HH.option
                                   [ HP.value $ Pt.printPath  group ]
                                   [ HH.text $ Pt.printPath  group ]
                             in
                               map renderOption state.groups
                         ]
                     , HH.label
                         [ HP.classes $ if state.subjectType ≠ Token then [ B.hidden ] else [ ]
                         ]
                         [ HH.text "Token name"
                         , HH.input
                             [ HP.classes [ B.formControl ]
                             , HP.inputType HP.InputText
                             , HP.placeholder "Token name"
                             , HP.value state.tokenName
                             , HE.onValueInput (HE.input TokenNameChanged)
                             , HP.disabled state.submitting
                             ]
                         ]
                     ]
                 , HH.div [ HP.classes [ B.colXs3 ] ]
                     [ HH.label_
                         [ HH.text "Permission"
                         , HH.select
                             [ HP.classes [ B.formControl ]
                             , HE.onValueChange (HE.input (ChangeShareResume ∘ readShareResume))
                             , HP.disabled state.submitting
                             ]

                             [ HH.option
                                 [ HP.value "view" ]
                                 [ HH.text "View" ]
                             , HH.option
                                 [ HP.value "edit" ]
                                 [ HH.text "Edit" ]
                             ]
                         ]
                     ]
                 ]
             ]
         ]

   , HH.div [ HP.classes [ HH.className "deck-dialog-footer" ] ]
       $ [ HH.div
           [ HP.classes
               $ [ B.alert, B.alertDanger ]
               ⊕ (if state.showError ∧ state.error ≡ Just Connection then [ ] else [ B.hidden ])
           , HE.onClick (HE.input_ DismissError)
           ]
           [ HH.text
               $ "This action couldn't be performed. "
               ⊕ "Please check your network connection and try again"
           ]
       , HH.div
           [ HP.classes
               $ [ B.alert, B.alertInfo ]
               ⊕ (if state.showError ∧ state.error ≡ Just Validation then [ ] else [ B.hidden ])
           ]
           [ HH.text
               "Please check if user email is correct"
           ]
       , HH.button
           [ HP.classes
               $ [ B.btn, B.btnDefault ]
               ⊕ (if state.loading then [ B.hidden ] else [ ])
           , HP.buttonType HP.ButtonButton
           , HE.onClick (HE.input_ Dismiss)
           , HP.disabled state.submitting
           ]
           [ HH.text "Dismiss" ]
       ]
     ⊕  (if isJust state.tokenSecret
           then [ ]
           else
           [ HH.button
               [ HP.classes
                   $ [ B.btn, B.btnPrimary ]
                   ⊕ (if state.loading then [ B.hidden ] else [ ])
                   ⊕ (if isJust state.error && state.showError then [ B.hasError ] else [ ])
               , HP.buttonType HP.ButtonButton
               , HE.onClick (HE.input_ Share)
               , HP.enabled (not state.submitting)
               ]
               [ HH.text if state.submitting then "Sharing..." else  "Share" ]
           ])
   ]

eval ∷ Query ~> DSL
eval (Dismiss next) = pure next
eval (ChangeSubjectType st next) = do
  H.modify (_{subjectType = st})
  unless (st ≡ User)
    $ H.modify (_{ error = Nothing
                 , showError = false
                 })
  pure next
eval (Share next) = next <$ do
  H.modify (_{ error = Nothing
             , showError = false
             , submitting = true
             })

  H.modify (_{submitting = true})
  state ← H.get

  let
    actions = sharingActions state.deckPath state.shareResume

  if state.subjectType ≡ Token
    then do
    res ←
      Q.createToken
        (if state.tokenName ≡ "" then Nothing else Just $ QT.TokenName state.tokenName)
        actions

    case res of
      Left _ →
        showConnectionError
      Right token →
        H.modify (_{ tokenSecret = QT.runTokenHash <$> token.secret
                   , submitting = false
                   })
    else do
    let
      shareRequest ∷ QT.ShareRequestR
      shareRequest =
        { users: (if state.subjectType ≡ User
                  then map (const $ QT.UserId state.email) actions
                  else [ ])
        , groups: (if state.subjectType ≡ Group
                   then Arr.catMaybes $ map (const $ state.groupSelected) actions
                   else [ ])
        , actions
        }
    res ← Q.sharePermission shareRequest
    case res of
      Left _ →
        showConnectionError
      Right [] →
        showConnectionError
      _ → raise $ H.action Dismiss
eval (DismissError next) =
  H.modify (_{showError = false}) $> next
eval (EmailChanged str next) = do
  let
    incorrectEmail = emailIsIncorrect str
  H.modify (_{email = str})
  mbError ← H.gets _.error
  unless (mbError ≡ Just Connection)
    $ H.modify
      if incorrectEmail
        then (_{ error = Just Validation
               , showError = true
               })
        else (_{ error = Nothing
               , showError = false
               })
  pure next
eval (Init next) = next <$ do
  res ← Q.groupInfo (rootDir </> file "")
  case res of
    Left _ →
      showConnectionError
    Right grInfo →
      H.modify (_{groups = [rootFile] ⊕ grInfo.subGroups, loading = false })
eval (GroupSelected grpString next) = next <$ do
  groups ← H.gets _.groups
  let
    group =
      Arr.findIndex (\x → grpString ≡ Pt.printPath x) groups
      >>= Arr.index groups
  H.modify (_{groupSelected = group})
eval (TokenNameChanged str next) =
  H.modify (_{tokenName = str}) $> next
eval (ChangeShareResume sr next) =
  H.modify (_{shareResume = sr}) $> next
eval (InitZClipboard token mbEl next) =
  next <$ for_ mbEl \el → do
    H.fromEff $ Z.make (htmlElementToElement el)
      >>= Z.onCopy (Z.setData "text/plain" token)
eval (SelectElement el next) =
  next <$ H.fromEff (select el)

emailIsIncorrect ∷ String → Boolean
emailIsIncorrect = not ∘ Str.contains "@"

showConnectionError ∷ DSL Unit
showConnectionError =
  H.modify (_{ error = Just Connection
             , showError = true
             , submitting = false
             })


Simplify example

Simplify example

module Main where

import Data.Array (map)
import Data.String (joinWith, length)

import Control.Monad.Eff
import Control.Monad.Cont.Trans

import Network.HTTP.Client

import Debug.Trace

main = runContT (getResponseText purescript_org) trace
  where
  getResponseText req = responseToString <$> getAll req

  responseToString :: Response -> String
  responseToString (Response chunks) = joinWith "" $ map runChunk chunks

  purescript_org :: Request
  purescript_org = Request
    { host: "www.purescript.org"
    , path: "/"
    }

module Main where

import Data.Maybe
import Data.Array (map)
import Data.Function (on)
import Data.String (joinWith, length)

import Control.Monad.Eff
import Control.Monad.Eff.Ref

import Control.Monad.Parallel
import Control.Monad.Cont.Trans

import Network.HTTP.Client

import Debug.Trace

main = do
  flip runContT k do
    runParallel $
      longest <$> Parallel (getResponseText purescript_org)
              <*> Parallel (getResponseText try_purescript_org)
  where
  longest :: String -> String -> Ordering
  longest = compare `on` length

  k LT = trace "try.purescript.org"
  k GT = trace "www.purescript.org"
  k EQ = trace "Lengths are equal"

  getResponseText req = responseToString <$> getAll req

  responseToString :: Response -> String
  responseToString (Response chunks) = joinWith "" $ map runChunk chunks

  purescript_org :: Request
  purescript_org = Request
    { host: "www.purescript.org"
    , path: "/"
    }

  try_purescript_org :: Request
  try_purescript_org = Request
    { host: "try.purescript.org"
    , path: "/"
    }


Remove unused

Remove unused

Original commit 403f677a8b61c8baaa15de181733e7736d7c01c5

module Language.Swift
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isAlphaNum, isDigit)
import Data.Foldable (for_, null)
import Data.FoldableWithIndex (forWithIndex_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (camelCase, capitalize, decapitalize, genericStringEscape, intToHex, legalizeCharacters, startWithLetter)
import Data.Tuple (Tuple(..))
import Utils (removeElement)

keywords :: Array String
keywords =
    [ "associatedtype", "class", "deinit", "enum", "extension", "fileprivate", "func", "import", "init", "inout", "internal", "let", "open", "operator", "private", "protocol", "public", "static", "struct", "subscript", "typealias", "var"
    , "break", "case", "continue", "default", "defer", "do", "else", "fallthrough", "for", "guard", "if", "in", "repeat", "return", "switch", "where", "while"
    , "as", "Any", "catch", "false", "is", "nil", "rethrows", "super", "self", "Self", "throw", "throws", "true", "try"
    , "_"
    , "associativity", "convenience", "dynamic", "didSet", "final", "get", "infix", "indirect", "lazy", "left", "mutating", "nonmutating", "optional", "override", "postfix", "precedence", "prefix", "Protocol", "required", "right", "set", "Type", "unowned", "weak", "willSet"
    , "String", "Int", "Double", "Bool", "Data", "CommandLine", "FileHandle", "JSONSerialization"
    , "checkNull", "removeNSNull", "nilToNSNull", "convertArray", "convertOptional", "convertDict", "convertDouble"
    ]

renderer :: Renderer
renderer =
    { name: "Swift"
    , aceMode: "swift"
    , extension: "swift"
    , doc: swiftDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: keywords
        , topLevelName: forbidNamer (swiftNameStyle true) (\n -> [swiftNameStyle true n])
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (swiftNameStyle true <<< combineNames)
            , nameFromTypes: simpleNamer (unionNameIntercalated (swiftNameStyle true) "Or")
            }
        }
    }

swiftNameStyle :: Boolean -> String -> String
swiftNameStyle isUpper =
    legalizeCharacters isPartCharacter >>> camelCase >>> startWithLetter isStartCharacter isUpper
    where
        isStartCharacter :: Char -> Boolean
        isStartCharacter c = c == '_' || (isAlphaNum c && not (isDigit c))

        isPartCharacter :: Char -> Boolean
        isPartCharacter c = c == '_' || isAlphaNum c

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = swiftNameStyle true $ combineNames names

stringEscape :: String -> String
stringEscape =
    genericStringEscape unicodeEscape
    where
        unicodeEscape i =
            ['\\', 'u', '{'] <> intToHex 0 i <> ['}']

swiftDoc :: Doc Unit
swiftDoc = do
    line "// To parse the JSON, add this file to your project and do:"
    line "//"
    forEachTopLevel_ \topLevelName topLevelType -> do
        typ <- renderType topLevelType
        line $ "//   let " <> decapitalize topLevelName <> " = " <> topLevelName <> "(fromString: jsonString)!"
    blank
    line "import Foundation"

    forEachTopLevel_ \topLevelName topLevelType -> do
        blank
        top <- renderType topLevelType
        line $ "typealias "<> topLevelName <> " = " <> top

    forEachClass_ \className properties -> do
        blank
        renderClassDefinition className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionDefinition unionName unionTypes

    blank
    line $ "// Serialization extensions"

    forEachTopLevel_ renderTopLevelExtensions

    forEachClass_ \className properties -> do
        blank
        renderClassExtension className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionExtension unionName unionTypes

    blank
    supportFunctions

supportFunctions :: Doc Unit
supportFunctions = do
    line """// Helpers

fileprivate func convertArray<T>(_ converter: (Any) -> T?, _ json: Any) -> [T]? {
    guard let jsonArr = json as? [Any] else { return nil }
    var arr = [T]()
    for v in jsonArr {
        if let converted = converter(v) {
            arr.append(converted)
        } else {
            return nil
        }
    }
    return arr
}

fileprivate func convertOptional<T>(_ converter: (Any) -> T?, _ json: Any?) -> T?? {
    guard let v = json else { return .some(nil) }
    return converter(v)
}

fileprivate func convertDict<T>(_ converter: (Any) -> T?, _ json: Any?) -> [String: T]? {
    guard let jsonDict = json as? [String: Any] else { return nil }
    var dict = [String: T]()
    for (k, v) in jsonDict {
        if let converted = converter(v) {
            dict[k] = converted
        } else {
            return nil
        }
    }
    return dict
}

fileprivate func convertToAny<T>(_ dictionary: [String: T], _ converter: (T) -> Any) -> Any {
    var result = [String: Any]()
    for (k, v) in dictionary {
        result[k] = converter(v)
    }
    return result
}

fileprivate func convertDouble(_ v: Any) -> Double? {
    if let w = v as? Double { return w }
    if let w = v as? Int { return Double(w) }
    return nil
}

fileprivate let falseType = NSNumber(value: false).objCType
fileprivate let trueNumber = NSNumber(value: true)
fileprivate let trueType = trueNumber.objCType

fileprivate func convertBool(_ v: Any?) -> Bool? {
    guard let number = v as? NSNumber
    else {
        if let b = v as? Bool {
            return b
        }
        return nil
    }

    if number.objCType != falseType && number.objCType != trueType {
        return nil
    }
    return number.isEqual(trueNumber)
}

fileprivate func removeNSNull(_ v: Any?) -> Any? {
    if let w = v {
        if w is NSNull {
            return nil
        }
        return w
    }
    return nil
}

fileprivate func checkNull(_ v: Any?) -> Any?? {
    if v != nil { return .none }
    return .some(nil)
}"""

renderUnion :: IRUnionRep -> Doc String
renderUnion ur =
    case nullableFromSet $ unionToSet ur of
    Just r -> do
        rendered <- renderType r
        pure $ rendered <> "?"
    Nothing -> lookupUnionName ur

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "Any?"
    IRNull -> pure "Any?"
    IRInteger -> pure "Int"
    IRDouble -> pure "Double"
    IRBool -> pure "Bool"
    IRString -> pure "String"
    IRArray a -> do
        rendered <- renderType a
        pure $ "[" <> rendered <> "]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "[String: " <> rendered <> "]"
    IRUnion ur -> renderUnion ur

convertAny :: IRType -> String -> Doc String
convertAny (IRArray a) var = do
    converter <- convertAnyFunc a
    pure $ "convertArray(" <> converter <> ", " <> var <> ")"
convertAny (IRMap m) var = do
    converter <- convertAnyFunc m
    pure $ "convertDict(" <> converter <> ", " <> var <> ")"
convertAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        converter <- convertAnyFunc t
        pure $ "convertOptional(" <> converter <> ", " <> var <> ")"
    Nothing -> do
        name <- lookupUnionName ur
        pure $ name <> ".fromJson(" <> var <> ")"
convertAny IRNothing var =
    pure var
convertAny IRBool var =
    pure $ "convertBool(" <> var <> ")"
convertAny IRInteger var =
    pure $ var <> " as? Int"
convertAny IRString var =
    pure $ var <> " as? String"
convertAny t var = do
    converter <- convertAnyFunc t
    pure $ converter <> "(" <> var <> ")"

convertAnyFunc :: IRType -> Doc String
convertAnyFunc = case _ of
    IRClass i -> do
        name <- lookupClassName i
        -- TODO make this look less alien
        pure $ "{ " <> name <> "(fromAny: $0) }"
    IRUnion ur ->
        case nullableFromSet $ unionToSet ur of
        Just t -> do
            converter <- convertAnyFunc t
            pure $ "{ (json: Any) in convertOptional(" <> converter <> ", json) }"
        Nothing -> do
            name <- lookupUnionName ur
            pure $ name <> ".fromJson"
    IRDouble -> pure "convertDouble"
    IRNull -> pure "checkNull"
    t -> do
        converted <- convertAny t "$0"
        pure $ "{ " <> converted <> " }"

convertToAny :: IRType -> String -> Doc String
convertToAny (IRArray a) var = do
    convertCode <- convertToAny a "$0"
    pure $ var <> ".map({ " <> convertCode <> " }) as Any"
convertToAny (IRMap m) var = do
    convertCode <- convertToAny m "$0"
    pure $ "convertToAny(" <> var <> ", { "<> convertCode <> " })"
convertToAny (IRClass i) var =
    pure $ var <> ".any"
convertToAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        convertCode <- convertToAny t "$0"
        pure $ var <> ".map({ " <> convertCode  <> " }) ?? NSNull()"
    Nothing ->
        pure $ var <> ".any"
convertToAny IRNothing var =
    pure $ var <> " ?? NSNull()"
convertToAny IRNull var =
    pure $ "NSNull() as Any"
convertToAny _ var =
    pure $ var <> " as Any"

renderClassDefinition :: String -> Map String IRType -> Doc Unit
renderClassDefinition className properties = do
    let forbidden = keywords <> ["json", "any"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "struct " <> className <> " {"
    indent do
        forEachProperty_ properties propertyNames \_ ptype fieldName _ -> do
            rendered <- renderType ptype
            line $ "let " <> fieldName <> ": " <> rendered
    line "}"

renderTopLevelExtensions :: String -> IRType -> Doc Unit
renderTopLevelExtensions topLevelName topLevelType = do
    blank

    topLevelRendered <- renderType topLevelType
    extensionType <- case topLevelType of
        IRArray t -> ("Array where Element == " <> _) <$> renderType t
        IRMap t -> ("Dictionary where Key == String, Value == " <> _) <$> renderType t
        _ -> pure topLevelRendered

    line $ "extension " <> extensionType <> " {"
    indent do
        line $ "init?(fromString json: String, using encoding: String.Encoding = .utf8) {"
        indent do
            line "guard let data = json.data(using: encoding) else { return nil }"
            line "self.init(fromData: data)"
        line "}"
        blank
        line $ "init?(fromData data: Data) {"
        indent do
            line "guard let json = try? JSONSerialization.jsonObject(with: data, options: []) else { return nil }"
            line "self.init(fromAny: json)"
        line "}"

        case topLevelType of
            IRArray _ ->  do
                blank
                line $ "init?(fromAny untyped: Any) {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "self.init(elements)"
                line "}"
            IRMap _ -> do
                blank
                line $ "init?(fromAny untyped: Any) {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "self.init()"
                    line $ "elements.forEach { self[$0.key] = $0.value }"
                line "}"
            _ -> pure unit

        blank
        line $ "var jsonData: Data? {"
        indent do
            convertCode <- convertToAny topLevelType "self"
            line $ "let json = " <> convertCode
            line "return try? JSONSerialization.data(withJSONObject: json, options: [])"
        line "}"

        blank
        line $ "var jsonString: String? {"
        indent do
            line $ "guard let data = self.jsonData else { return nil }"
            line $ "return String(data: data, encoding: .utf8)"
        line "}"

    line "}"

renderClassExtension :: String -> Map String IRType -> Doc Unit
renderClassExtension className properties = do
    let forbidden = keywords <> ["jsonUntyped", "json"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "extension " <> className <> " {"
    indent do
        line $ "fileprivate init?(fromAny any: Any) {"
        indent do
            line "guard let json = any as? [String: Any] else { return nil }"
            let forbiddenForUntyped = forbidden <> (A.fromFoldable $ M.keys propertyNames)
            let untypedNames = makePropertyNames properties "Any" forbiddenForUntyped
            let forbiddenForConverted = forbiddenForUntyped <> (A.fromFoldable $ M.keys untypedNames)
            forEachProperty_ properties untypedNames \pname ptype untypedName _ -> do
                when (canBeNull ptype) do
                    line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"])"
            unless (M.isEmpty properties) do
                line "guard"
                indent do
                    forEachProperty_ properties untypedNames \pname ptype untypedName isLast -> do
                        let convertedName = lookupName pname propertyNames
                        unless (canBeNull ptype) do
                            line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"]),"
                        convertCode <- convertAny ptype untypedName
                        line $ "let " <> convertedName <> " = " <> convertCode <> (if isLast then "" else ",")
                    line "else { return nil }"
            forEachProperty_ properties propertyNames \pname _ fieldName _ -> do
                let convertedName = lookupName pname propertyNames
                line $ "self." <> fieldName <> " = " <> convertedName
        line "}"
        blank
        line "fileprivate var any: Any {"
        indent do
            if null properties
                then line "return [String: Any]()"
                else do
                    line "return ["
                    indent do
                        forEachProperty_ properties propertyNames \pname ptype fieldName _ -> do
                            convertCode <- convertToAny ptype ("self." <> fieldName)
                            line $ "\"" <> stringEscape pname <> "\": " <> convertCode <> ","
                    line "]"
        line "}"
    line "}"

forEachProperty_ :: Map String IRType -> Map String String -> (String -> IRType -> String -> Boolean -> Doc Unit) -> Doc Unit
forEachProperty_ properties propertyNames f =
    let propertyArray = M.toUnfoldable properties :: Array _
        lastIndex = A.length propertyArray - 1
    in
        forWithIndex_ propertyArray \i (Tuple pname ptype) -> do
            let fieldName = lookupName pname propertyNames
            f pname ptype fieldName (i == lastIndex)

makePropertyNames :: Map String IRType -> String -> Array String -> Map String String
makePropertyNames properties suffix forbidden =
    transformPropertyNames (fieldNamer suffix) otherField forbidden properties
    where
        fieldNamer :: String -> Namer String
        fieldNamer suffix = simpleNamer \name -> swiftNameStyle false name <> suffix

        otherField :: String -> String
        otherField name = "other" <> capitalize name

renderUnionDefinition :: String -> Set IRType -> Doc Unit
renderUnionDefinition unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "enum " <> unionName <> " {"
    indent do
        for_ nonNullTypes \typ -> do
            name <- caseName typ
            rendered <- renderType typ
            line $ "case " <> name <> "(" <> rendered <> ")"
        case emptyOrNull of
            Just t -> do
                name <- caseName t
                line $ "case " <> name
            Nothing -> pure unit
    line "}"

renderUnionExtension :: String -> Set IRType -> Doc Unit
renderUnionExtension unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "extension " <> unionName <> " {"
    indent do
        line $ "fileprivate static func fromJson(_ v: Any) -> " <> unionName <> "? {"
        indent do
            case emptyOrNull of
                Just t -> do
                    name <- caseName t
                    line "guard let v = removeNSNull(v)"
                    line "else {"
                    indent do
                        line $ "return ." <> name
                    line "}"
                Nothing -> pure unit
            when (S.member IRBool unionTypes) do
                renderCase IRBool
            when (S.member IRInteger unionTypes) do
                renderCase IRInteger
            for_ (S.difference nonNullTypes $ S.fromFoldable [IRBool, IRInteger]) \typ -> do
                renderCase typ
            line "return nil"
        line "}"
        blank
        line $ "fileprivate var any: Any {"
        indent do
            line $ "switch self {"
            for_ unionTypes \typ -> do
                name <- caseName typ
                let letString = if typ == IRNull then "" else "(let x)"
                convertCode <- convertToAny typ "x"
                line $ "case ." <> name <> letString <> ": return " <> convertCode
            line "}"
        line "}"
    line "}"
    where
    renderCase :: IRType -> Doc Unit
    renderCase t = do
        convertCode <- convertAny t "v"
        name <- caseName t
        line $ "if let x = " <> convertCode <> " { return ." <> name <> "(x) }"

caseName :: IRType -> Doc String
caseName t = swiftNameStyle false <$> getTypeNameForUnion t

module Language.Swift
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isAlphaNum, isDigit)
import Data.Foldable (for_, null)
import Data.FoldableWithIndex (forWithIndex_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (camelCase, capitalize, decapitalize, genericStringEscape, intToHex, legalizeCharacters, startWithLetter)
import Data.Tuple (Tuple(..))
import Utils (removeElement)

keywords :: Array String
keywords =
    [ "associatedtype", "class", "deinit", "enum", "extension", "fileprivate", "func", "import", "init", "inout", "internal", "let", "open", "operator", "private", "protocol", "public", "static", "struct", "subscript", "typealias", "var"
    , "break", "case", "continue", "default", "defer", "do", "else", "fallthrough", "for", "guard", "if", "in", "repeat", "return", "switch", "where", "while"
    , "as", "Any", "catch", "false", "is", "nil", "rethrows", "super", "self", "Self", "throw", "throws", "true", "try"
    , "_"
    , "associativity", "convenience", "dynamic", "didSet", "final", "get", "infix", "indirect", "lazy", "left", "mutating", "nonmutating", "optional", "override", "postfix", "precedence", "prefix", "Protocol", "required", "right", "set", "Type", "unowned", "weak", "willSet"
    , "String", "Int", "Double", "Bool", "Data", "CommandLine", "FileHandle", "JSONSerialization"
    , "checkNull", "removeNSNull", "nilToNSNull", "convertArray", "convertOptional", "convertDict", "convertDouble"
    ]

renderer :: Renderer
renderer =
    { name: "Swift"
    , aceMode: "swift"
    , extension: "swift"
    , doc: swiftDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: keywords
        , topLevelName: forbidNamer (swiftNameStyle true) (\n -> [swiftNameStyle true n])
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (swiftNameStyle true <<< combineNames)
            , nameFromTypes: simpleNamer (unionNameIntercalated (swiftNameStyle true) "Or")
            }
        }
    }

swiftNameStyle :: Boolean -> String -> String
swiftNameStyle isUpper =
    legalizeCharacters isPartCharacter >>> camelCase >>> startWithLetter isStartCharacter isUpper
    where
        isStartCharacter :: Char -> Boolean
        isStartCharacter c = c == '_' || (isAlphaNum c && not (isDigit c))

        isPartCharacter :: Char -> Boolean
        isPartCharacter c = c == '_' || isAlphaNum c

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = swiftNameStyle true $ combineNames names

stringEscape :: String -> String
stringEscape =
    genericStringEscape unicodeEscape
    where
        unicodeEscape i =
            ['\\', 'u', '{'] <> intToHex 0 i <> ['}']

swiftDoc :: Doc Unit
swiftDoc = do
    line "// To parse the JSON, add this file to your project and do:"
    line "//"
    forEachTopLevel_ \topLevelName topLevelType -> do
        typ <- renderType topLevelType
        line $ "//   let " <> decapitalize topLevelName <> " = " <> topLevelName <> "(fromString: jsonString)!"
    blank
    line "import Foundation"

    forEachTopLevel_ \topLevelName topLevelType -> do
        blank
        top <- renderType topLevelType
        line $ "typealias "<> topLevelName <> " = " <> top

    forEachClass_ \className properties -> do
        blank
        renderClassDefinition className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionDefinition unionName unionTypes

    blank
    line $ "// Serialization extensions"

    forEachTopLevel_ renderTopLevelExtensions

    forEachClass_ \className properties -> do
        blank
        renderClassExtension className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionExtension unionName unionTypes

    blank
    supportFunctions

supportFunctions :: Doc Unit
supportFunctions = do
    line """// Helpers

fileprivate func convertArray<T>(_ converter: (Any) -> T?, _ json: Any) -> [T]? {
    guard let jsonArr = json as? [Any] else { return nil }
    var arr = [T]()
    for v in jsonArr {
        if let converted = converter(v) {
            arr.append(converted)
        } else {
            return nil
        }
    }
    return arr
}

fileprivate func convertOptional<T>(_ converter: (Any) -> T?, _ json: Any?) -> T?? {
    guard let v = json else { return .some(nil) }
    return converter(v)
}

fileprivate func convertDict<T>(_ converter: (Any) -> T?, _ json: Any?) -> [String: T]? {
    guard let jsonDict = json as? [String: Any] else { return nil }
    var dict = [String: T]()
    for (k, v) in jsonDict {
        if let converted = converter(v) {
            dict[k] = converted
        } else {
            return nil
        }
    }
    return dict
}

fileprivate func convertToAny<T>(_ dictionary: [String: T], _ converter: (T) -> Any) -> Any {
    var result = [String: Any]()
    for (k, v) in dictionary {
        result[k] = converter(v)
    }
    return result
}

fileprivate func convertDouble(_ v: Any) -> Double? {
    if let w = v as? Double { return w }
    if let w = v as? Int { return Double(w) }
    return nil
}

fileprivate let falseType = NSNumber(value: false).objCType
fileprivate let trueNumber = NSNumber(value: true)
fileprivate let trueType = trueNumber.objCType

fileprivate func convertBool(_ v: Any?) -> Bool? {
    guard let number = v as? NSNumber
    else {
        if let b = v as? Bool {
            return b
        }
        return nil
    }

    if number.objCType != falseType && number.objCType != trueType {
        return nil
    }
    return number.isEqual(trueNumber)
}

fileprivate func removeNSNull(_ v: Any?) -> Any? {
    if let w = v {
        if w is NSNull {
            return nil
        }
        return w
    }
    return nil
}

fileprivate func checkNull(_ v: Any?) -> Any?? {
    if v != nil { return .none }
    return .some(nil)
}"""

renderUnion :: IRUnionRep -> Doc String
renderUnion ur =
    case nullableFromSet $ unionToSet ur of
    Just r -> do
        rendered <- renderType r
        pure $ rendered <> "?"
    Nothing -> lookupUnionName ur

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "Any?"
    IRNull -> pure "Any?"
    IRInteger -> pure "Int"
    IRDouble -> pure "Double"
    IRBool -> pure "Bool"
    IRString -> pure "String"
    IRArray a -> do
        rendered <- renderType a
        pure $ "[" <> rendered <> "]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "[String: " <> rendered <> "]"
    IRUnion ur -> renderUnion ur

convertAny :: IRType -> String -> Doc String
convertAny (IRArray a) var = do
    converter <- convertAnyFunc a
    pure $ "convertArray(" <> converter <> ", " <> var <> ")"
convertAny (IRMap m) var = do
    converter <- convertAnyFunc m
    pure $ "convertDict(" <> converter <> ", " <> var <> ")"
convertAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        converter <- convertAnyFunc t
        pure $ "convertOptional(" <> converter <> ", " <> var <> ")"
    Nothing -> do
        name <- lookupUnionName ur
        pure $ name <> ".fromJson(" <> var <> ")"
convertAny IRNothing var =
    pure var
convertAny IRBool var =
    pure $ "convertBool(" <> var <> ")"
convertAny IRInteger var =
    pure $ var <> " as? Int"
convertAny IRString var =
    pure $ var <> " as? String"
convertAny t var = do
    converter <- convertAnyFunc t
    pure $ converter <> "(" <> var <> ")"

convertAnyFunc :: IRType -> Doc String
convertAnyFunc = case _ of
    IRClass i -> do
        name <- lookupClassName i
        -- TODO make this look less alien
        pure $ "{ " <> name <> "(fromAny: $0) }"
    IRUnion ur ->
        case nullableFromSet $ unionToSet ur of
        Just t -> do
            converter <- convertAnyFunc t
            pure $ "{ (json: Any) in convertOptional(" <> converter <> ", json) }"
        Nothing -> do
            name <- lookupUnionName ur
            pure $ name <> ".fromJson"
    IRDouble -> pure "convertDouble"
    IRNull -> pure "checkNull"
    t -> do
        converted <- convertAny t "$0"
        pure $ "{ " <> converted <> " }"

convertToAny :: IRType -> String -> Doc String
convertToAny (IRArray a) var = do
    convertCode <- convertToAny a "$0"
    pure $ var <> ".map({ " <> convertCode <> " }) as Any"
convertToAny (IRMap m) var = do
    convertCode <- convertToAny m "$0"
    pure $ "convertToAny(" <> var <> ", { "<> convertCode <> " })"
convertToAny (IRClass i) var =
    pure $ var <> ".any"
convertToAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        convertCode <- convertToAny t "$0"
        pure $ var <> ".map({ " <> convertCode  <> " }) ?? NSNull()"
    Nothing ->
        pure $ var <> ".any"
convertToAny IRNothing var =
    pure $ var <> " ?? NSNull()"
convertToAny IRNull var =
    pure $ "NSNull() as Any"
convertToAny _ var =
    pure $ var <> " as Any"

renderClassDefinition :: String -> Map String IRType -> Doc Unit
renderClassDefinition className properties = do
    let forbidden = keywords <> ["json", "any"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "struct " <> className <> " {"
    indent do
        forEachProperty_ properties propertyNames \_ ptype fieldName _ -> do
            rendered <- renderType ptype
            line $ "let " <> fieldName <> ": " <> rendered
    line "}"

renderTopLevelExtensions :: String -> IRType -> Doc Unit
renderTopLevelExtensions topLevelName topLevelType = do
    blank

    topLevelRendered <- renderType topLevelType
    extensionType <- case topLevelType of
        IRArray t -> ("Array where Element == " <> _) <$> renderType t
        IRMap t -> ("Dictionary where Key == String, Value == " <> _) <$> renderType t
        _ -> pure topLevelRendered

    line $ "extension " <> extensionType <> " {"
    indent do
        line $ "init?(fromString json: String, using encoding: String.Encoding = .utf8) {"
        indent do
            line "guard let data = json.data(using: encoding) else { return nil }"
            line "self.init(fromData: data)"
        line "}"
        blank
        line $ "init?(fromData data: Data) {"
        indent do
            line "guard let json = try? JSONSerialization.jsonObject(with: data, options: []) else { return nil }"
            line "self.init(fromAny: json)"
        line "}"

        case topLevelType of
            IRArray _ ->  do
                blank
                line $ "init?(fromAny untyped: Any) {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "self.init(elements)"
                line "}"
            IRMap _ -> do
                blank
                line $ "init?(fromAny untyped: Any) {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "self.init()"
                    line $ "elements.forEach { self[$0.key] = $0.value }"
                line "}"
            _ -> pure unit

        blank
        line $ "var jsonData: Data? {"
        indent do
            convertCode <- convertToAny topLevelType "self"
            line $ "let json = " <> convertCode
            line "return try? JSONSerialization.data(withJSONObject: json, options: [])"
        line "}"

        blank
        line $ "var jsonString: String? {"
        indent do
            line $ "guard let data = self.jsonData else { return nil }"
            line $ "return String(data: data, encoding: .utf8)"
        line "}"

    line "}"

renderClassExtension :: String -> Map String IRType -> Doc Unit
renderClassExtension className properties = do
    let forbidden = keywords <> ["jsonUntyped", "json"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "extension " <> className <> " {"
    indent do
        line $ "fileprivate init?(fromAny any: Any) {"
        indent do
            line "guard let json = any as? [String: Any] else { return nil }"
            let forbiddenForUntyped = forbidden <> (A.fromFoldable $ M.keys propertyNames)
            let untypedNames = makePropertyNames properties "Any" forbiddenForUntyped
            let forbiddenForConverted = forbiddenForUntyped <> (A.fromFoldable $ M.keys untypedNames)
            let convertedNames = makePropertyNames properties "" forbidden
            forEachProperty_ properties untypedNames \pname ptype untypedName _ -> do
                when (canBeNull ptype) do
                    line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"])"
            unless (M.isEmpty properties) do
                line "guard"
                indent do
                    forEachProperty_ properties untypedNames \pname ptype untypedName isLast -> do
                        let convertedName = lookupName pname convertedNames
                        unless (canBeNull ptype) do
                            line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"]),"
                        convertCode <- convertAny ptype untypedName
                        line $ "let " <> convertedName <> " = " <> convertCode <> (if isLast then "" else ",")
                    line "else { return nil }"
            forEachProperty_ properties propertyNames \pname _ fieldName _ -> do
                let convertedName = lookupName pname convertedNames
                line $ "self." <> fieldName <> " = " <> convertedName
        line "}"
        blank
        line "fileprivate var any: Any {"
        indent do
            if null properties
                then line "return [String: Any]()"
                else do
                    line "return ["
                    indent do
                        forEachProperty_ properties propertyNames \pname ptype fieldName _ -> do
                            convertCode <- convertToAny ptype ("self." <> fieldName)
                            line $ "\"" <> stringEscape pname <> "\": " <> convertCode <> ","
                    line "]"
        line "}"
    line "}"

forEachProperty_ :: Map String IRType -> Map String String -> (String -> IRType -> String -> Boolean -> Doc Unit) -> Doc Unit
forEachProperty_ properties propertyNames f =
    let propertyArray = M.toUnfoldable properties :: Array _
        lastIndex = A.length propertyArray - 1
    in
        forWithIndex_ propertyArray \i (Tuple pname ptype) -> do
            let fieldName = lookupName pname propertyNames
            f pname ptype fieldName (i == lastIndex)

makePropertyNames :: Map String IRType -> String -> Array String -> Map String String
makePropertyNames properties suffix forbidden =
    transformPropertyNames (fieldNamer suffix) otherField forbidden properties
    where
        fieldNamer :: String -> Namer String
        fieldNamer suffix = simpleNamer \name -> swiftNameStyle false name <> suffix

        otherField :: String -> String
        otherField name = "other" <> capitalize name

renderUnionDefinition :: String -> Set IRType -> Doc Unit
renderUnionDefinition unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "enum " <> unionName <> " {"
    indent do
        for_ nonNullTypes \typ -> do
            name <- caseName typ
            rendered <- renderType typ
            line $ "case " <> name <> "(" <> rendered <> ")"
        case emptyOrNull of
            Just t -> do
                name <- caseName t
                line $ "case " <> name
            Nothing -> pure unit
    line "}"

renderUnionExtension :: String -> Set IRType -> Doc Unit
renderUnionExtension unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "extension " <> unionName <> " {"
    indent do
        line $ "fileprivate static func fromJson(_ v: Any) -> " <> unionName <> "? {"
        indent do
            case emptyOrNull of
                Just t -> do
                    name <- caseName t
                    line "guard let v = removeNSNull(v)"
                    line "else {"
                    indent do
                        line $ "return ." <> name
                    line "}"
                Nothing -> pure unit
            when (S.member IRBool unionTypes) do
                renderCase IRBool
            when (S.member IRInteger unionTypes) do
                renderCase IRInteger
            for_ (S.difference nonNullTypes $ S.fromFoldable [IRBool, IRInteger]) \typ -> do
                renderCase typ
            line "return nil"
        line "}"
        blank
        line $ "fileprivate var any: Any {"
        indent do
            line $ "switch self {"
            for_ unionTypes \typ -> do
                name <- caseName typ
                let letString = if typ == IRNull then "" else "(let x)"
                convertCode <- convertToAny typ "x"
                line $ "case ." <> name <> letString <> ": return " <> convertCode
            line "}"
        line "}"
    line "}"
    where
    renderCase :: IRType -> Doc Unit
    renderCase t = do
        convertCode <- convertAny t "v"
        name <- caseName t
        line $ "if let x = " <> convertCode <> " { return ." <> name <> "(x) }"

caseName :: IRType -> Doc String
caseName t = swiftNameStyle false <$> getTypeNameForUnion t


Fix download name for old workspaces (#1415)

{-
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.Workspace.Card.DownloadOptions.Eval where

import SlamData.Prelude
import Control.Monad.Throw (class MonadThrow)
import Data.Lens ((^.))
import Data.Path.Pathy (runFileName, fileName)
import SlamData.Download.Model as D
import SlamData.Workspace.Card.DownloadOptions.Component.State as Download
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Port as Port

eval ∷ ∀ m. MonadThrow CEM.CardError m => Download.State → Port.Resource → m Port.Port
eval { compress, options, targetName } resource = case targetName of
  Nothing →
    -- For legacy download options. Otherwise this shouldn't be Nothing.
    pure $ Port.DownloadOptions
      { compress
      , options
      , targetName: runFileName (fileName (resource ^. Port._filePath))
      , resource: resource ^. Port._filePath
      }
  Just "" → required
  Just fn → do
    when (isLeft (D.validFilename fn)) do
      CEM.throw $ "Invalid target filename: " <> fn
    pure $ Port.DownloadOptions
      { compress
      , options
      , targetName: fn
      , resource: resource ^. Port._filePath
      }

  where
    required = CEM.throw "Target filename required"

{-
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.Workspace.Card.DownloadOptions.Eval where

import SlamData.Prelude
import Control.Monad.Throw (class MonadThrow)
import Data.Lens ((^.))
import SlamData.Download.Model as D
import SlamData.Workspace.Card.DownloadOptions.Component.State as Download
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Port as Port

eval ∷ ∀ m. MonadThrow CEM.CardError m => Download.State → Port.Resource → m Port.Port
eval { compress, options, targetName } resource = case targetName of
  Nothing → required
  Just "" → required
  Just fn → do
    when (isLeft (D.validFilename fn)) do
      CEM.throw $ "Invalid target filename: " <> fn
    pure $ Port.DownloadOptions
      { compress
      , options
      , targetName: fn
      , resource: resource ^. Port._filePath
      }

  where
    required = CEM.throw "Target filename required"


Update `EventSource` comments, add `emit'`

module Halogen.Query.EventSource where

import Prelude

import Control.Coroutine as CR
import Control.Monad.Free.Trans as FT
import Control.Monad.Trans.Class (lift)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Maybe (Maybe, maybe)
import Data.Newtype (class Newtype)
import Data.Profunctor (dimap)
import Effect (Effect)
import Effect.Aff (Aff, attempt, launchAff_)
import Effect.Aff.AVar as AV
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (liftEffect)
import Effect.Exception as Exn
import Web.Event.Event as E
import Web.Event.EventTarget as ET

-- | An event source definition - an effect in `m` that when run returns a
-- | producer coroutine that emits actions of type `a`, and runs in the effect
-- | monad `m`.
-- |
-- | It's generally unnecessary to build values of this type directly, the
-- | `affEventSource`, `effectEventSource`, and `eventListenerEventSource`
-- | cover most common event source constructions.
newtype EventSource m a =
  EventSource (m { producer :: CR.Producer a m Unit, finalizer :: Finalizer m })

derive instance newtypeEventSource :: Newtype (EventSource m a) _

instance functorEventSource :: Functor m => Functor (EventSource m) where
  map f (EventSource es) =
    EventSource $
      map
        (\e -> { producer: FT.interpret (lmap f) e.producer, finalizer: e.finalizer })
        es

-- | Changes the effect monad of an event source.
hoist :: forall m n. Functor n => (m ~> n) -> EventSource m ~> EventSource n
hoist nat (EventSource es) =
  EventSource $
    map
      (\e -> { producer: FT.hoistFreeT nat e.producer, finalizer: hoistFinalizer nat e.finalizer })
      (nat es)

-- | Constructs an event source from a setup function that operates in `Aff`.
-- |
-- | - The `Emitter` that the passed function receives is used to `emit` actions
-- |   that will be received by the current component, or can be `close`d to
-- |   shut down the event source and remove the subscription.
-- | - The `Finalizer` that the passed function produces is there to allow for
-- |   some clean-up action to be taken when the event source is unsubscribed
-- |   from. This also runs if the `Emitter` is `close`d. `mempty` can be used
-- |   here if there is no clean-up to perform.
affEventSource
  :: forall m a
   . MonadAff m
  => (Emitter Aff a -> Aff (Finalizer Aff))
  -> EventSource m a
affEventSource recv = EventSource $ liftAff do
  inputVar <- AV.empty
  finalizeVar <- AV.empty
  let
    producer = do
      lift $ liftAff $ flip AV.put finalizeVar =<< recv (Emitter (flip AV.put inputVar))
      CR.producer $ liftAff $ AV.take inputVar
    finalizer = Finalizer do
      liftAff (attempt (AV.take finalizeVar)) >>= case _ of
        Left _ -> pure unit
        Right z -> liftAff do
          AV.kill (Exn.error "finalized") finalizeVar
          finalize z
  pure { producer, finalizer }

-- | Constructs an event source from a setup function that operates in `Eff`.
-- |
-- | - The `Emitter` that the passed function receives is used to `emit` actions
-- |   that will be received by the current component, or can be `close`d to
-- |   shut down the event source and remove the subscription.
-- | - The `Finalizer` that the passed function produces is there to allow for
-- |   some clean-up action to be taken when the event source is unsubscribed
-- |   from. This also runs if the `Emitter` is `close`d. `mempty` can be used
-- |   here if there is no clean-up to perform.
effectEventSource
  :: forall m a
   . MonadAff m
  => (Emitter Effect a -> Effect (Finalizer Effect))
  -> EventSource m a
effectEventSource =
  affEventSource <<<
    dimap
      (hoistEmitter launchAff_)
      (liftEffect <<< map (hoistFinalizer liftEffect))

-- | Constructs an event source from an event in the DOM. Accepts a function
-- | that maps event values to a `Maybe`-wrapped action, allowing it to filter
-- | events if necessary.
eventListenerEventSource
  :: forall m a
   . MonadAff m
  => E.EventType
  -> ET.EventTarget
  -> (E.Event -> Maybe a)
  -> EventSource m a
eventListenerEventSource eventType target f = effectEventSource \emitter -> do
  listener <- ET.eventListener (maybe (pure unit) (emit emitter <<< pure) <<< f)
  ET.addEventListener eventType listener false target
  pure $ Finalizer (ET.removeEventListener eventType listener false target)

-- | Values of this type are created internally by `affEventSource` and
-- | `effectEventSource`, and then passed into the user-provided setup function.
-- |
-- | This type is just a wrapper around a callback, used to simplify the type
-- | signatures for setting up event sources.
newtype Emitter m a = Emitter (Either a Unit -> m Unit)

-- | Emits an "action style" query via the emitter. Accepts a partially applied
-- | query constructor to save having to use `H.action` or applying `unit` when
-- | constructing the query, for example:
-- |
-- | ``` purescript
-- | data Query a = Notify String a
-- |
-- | myEventSource = EventSource.affEventSource \emitter -> do
-- |   Aff.delay (Milliseconds 1000.0)
-- |   EventSource.emit emitter (Notify "hello")
-- |   pure mempty
-- | ```
emit :: forall m a. Emitter m a -> (Unit -> a) -> m Unit
emit emitter q = emit' emitter (q unit)

-- | Emits an action via the emitter.
emit' :: forall m a. Emitter m a -> a -> m Unit
emit' (Emitter f) a = f (Left a)

-- | Closes the emitter, shutting down the event source. This allows an event
-- | source to stop itself internally, rather than requiring external shutdown
-- | by unsubscribing from it.
-- |
-- | The event source will automatically be unsubscribed from when this is
-- | called, and the finalizer returned during event source setup will be
-- | executed.
-- |
-- | Any further calls to `emit` after `close` will be ignored.
close :: forall m a. Emitter m a -> m Unit
close (Emitter f) = f (Right unit)

-- | Changes the effect monad of an emitter.
hoistEmitter :: forall m n. (m Unit -> n Unit) -> Emitter m ~> Emitter n
hoistEmitter nat (Emitter f) = Emitter (nat <<< f)

-- | When setting up an event source, values of this type should be returned to
-- | describe any clean-up operations required. This is just a newtype around
-- | an effectful operation, but helps with type signature comprehension.
-- |
-- | There is a `Monoid` instance provided for finalizers, so `mempty` can be
-- | used in cases where there are no relevant clean-up actions to take.
newtype Finalizer m = Finalizer (m Unit)

instance semigroupFinalizer :: Apply m => Semigroup (Finalizer m) where
  append (Finalizer a) (Finalizer b) = Finalizer (a *> b)

instance monoidFinalizer :: Applicative m => Monoid (Finalizer m) where
  mempty = Finalizer (pure unit)

-- | Runs a finalizer.
finalize :: forall m. Finalizer m -> m Unit
finalize (Finalizer a) = a

-- | Changes the effect monad for a finalizer.
hoistFinalizer :: forall m n. (m ~> n) -> Finalizer m -> Finalizer n
hoistFinalizer nat (Finalizer a) = Finalizer (nat a)

module Halogen.Query.EventSource where

import Prelude

import Control.Coroutine as CR
import Control.Monad.Free.Trans as FT
import Control.Monad.Trans.Class (lift)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Maybe (Maybe, maybe)
import Data.Newtype (class Newtype)
import Data.Profunctor (dimap)
import Effect (Effect)
import Effect.Aff (Aff, attempt, launchAff_)
import Effect.Aff.AVar as AV
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (liftEffect)
import Effect.Exception as Exn
import Web.Event.Event as E
import Web.Event.EventTarget as ET

-- | An event source definition - an effect in `m` that when run returns a
-- | producer coroutine that emits queries of type `f`, and runs in the effect
-- | monad `m`.
-- |
-- | It's generally unnecessary to build values of this type directly with this
-- | constructor, the `affEventSource`, `effectEventSource`, and
-- | `eventListenerEventSource` cover most event source constructions.
newtype EventSource m a =
  EventSource (m { producer :: CR.Producer a m Unit, finalizer :: Finalizer m })

derive instance newtypeEventSource :: Newtype (EventSource m a) _

instance functorEventSource :: Functor m => Functor (EventSource m) where
  map f (EventSource es) =
    EventSource $
      map
        (\e -> { producer: FT.interpret (lmap f) e.producer, finalizer: e.finalizer })
        es

-- | Changes the effect monad component of an event source.
hoist :: forall m n f. Functor n => (m ~> n) -> EventSource m f -> EventSource n f
hoist nat (EventSource es) =
  EventSource $
    map
      (\e -> { producer: FT.hoistFreeT nat e.producer, finalizer: hoistFinalizer nat e.finalizer })
      (nat es)

-- | Constructs an event source from a setup function that operates in `Aff`.
-- |
-- | - The `Emitter` that the passed function receives is used to `emit` queries
-- |   that will be received by the current component, or can be `close`d to
-- |   shut down the event source and remove the subscription.
-- | - The `Finalizer` that the passed function produces is there to allow for
-- |   some clean-up action to be taken when the event source is unsubscribed
-- |   from. This also runs if the `Emitter` is `close`d. `mempty` can be used
-- |   here if there is no clean-up to perform.
affEventSource
  :: forall m a
   . MonadAff m
  => (Emitter Aff a -> Aff (Finalizer Aff))
  -> EventSource m a
affEventSource recv = EventSource $ liftAff do
  inputVar <- AV.empty
  finalizeVar <- AV.empty
  let
    producer = do
      lift $ liftAff $ flip AV.put finalizeVar =<< recv (Emitter (flip AV.put inputVar))
      CR.producer $ liftAff $ AV.take inputVar
    finalizer = Finalizer do
      liftAff (attempt (AV.take finalizeVar)) >>= case _ of
        Left _ -> pure unit
        Right z -> liftAff do
          AV.kill (Exn.error "finalized") finalizeVar
          finalize z
  pure { producer, finalizer }

-- | Constructs an event source from a setup function that operates in `Eff`.
-- |
-- | - The `Emitter` that the passed function receives is used to `emit` queries
-- |   that will be received by the current component, or can be `close`d to
-- |   shut down the event source and remove the subscription.
-- | - The `Finalizer` that the passed function produces is there to allow for
-- |   some clean-up action to be taken when the event source is unsubscribed
-- |   from. This also runs if the `Emitter` is `close`d. `mempty` can be used
-- |   here if there is no clean-up to perform.
effectEventSource
  :: forall m a
   . MonadAff m
  => (Emitter Effect a -> Effect (Finalizer Effect))
  -> EventSource m a
effectEventSource =
  affEventSource <<<
    dimap
      (hoistEmitter launchAff_)
      (liftEffect <<< map (hoistFinalizer liftEffect))

-- | Constructs an event source from an event in the DOM. Accepts a function
-- | that maps event values to a `Maybe`-wrapped query, allowing it to filter
-- | events if necessary.
eventListenerEventSource
  :: forall m a
   . MonadAff m
  => E.EventType
  -> ET.EventTarget
  -> (E.Event -> Maybe a)
  -> EventSource m a
eventListenerEventSource eventType target f = effectEventSource \emitter -> do
  listener <- ET.eventListener (maybe (pure unit) (emit emitter <<< pure) <<< f)
  ET.addEventListener eventType listener false target
  pure $ Finalizer (ET.removeEventListener eventType listener false target)

-- | Values of this type are created internally by `affEventSource` and
-- | `effectEventSource`, and then passed into the user-provided setup function.
-- |
-- | This type is just a wrapper around a callback, used to simplify the type
-- | signatures for setting up event sources.
newtype Emitter m a = Emitter (Either a Unit -> m Unit)

-- | Emits an "action style" query via the emitter. Accepts a partially applied
-- | query constructor to save having to use `H.action` or applying `unit` when
-- | constructing the query, for example:
-- |
-- | ``` purescript
-- | data Query a = Notify String a
-- |
-- | myEventSource = EventSource.affEventSource \emitter -> do
-- |   Aff.delay (Milliseconds 1000.0)
-- |   EventSource.emit emitter (Notify "hello")
-- |   pure mempty
-- | ```
emit :: forall m a. Emitter m a -> (Unit -> a) -> m Unit
emit (Emitter f) q = f (Left (q unit))

-- | Closes the emitter, shutting down the event source. This allows an event
-- | source to stop itself internally, rather than requiring external shutdown
-- | by unsubscribing from it.
-- |
-- | The event source will automatically be unsubscribed from when this is
-- | called, and the finalizer returned during event source setup will be
-- | executed.
-- |
-- | Any further calls to `emit` after `close` will be ignored.
close :: forall m a. Emitter m a -> m Unit
close (Emitter f) = f (Right unit)

-- | Changes the effect monad for an emitter.
hoistEmitter :: forall m n a. (m Unit -> n Unit) -> Emitter m a -> Emitter n a
hoistEmitter nat (Emitter f) = Emitter (nat <<< f)

-- | When setting up an event source, values of this type should be returned to
-- | describe any clean-up operations required. This is just a newtype around
-- | an effectful operation, but helps with type signature comprehension.
-- |
-- | There is a `Monoid` instance provided for finalizers, so `mempty` can be
-- | used in cases where there are no relevant clean-up actions to take.
newtype Finalizer m = Finalizer (m Unit)

instance semigroupFinalizer :: Apply m => Semigroup (Finalizer m) where
  append (Finalizer a) (Finalizer b) = Finalizer (a *> b)

instance monoidFinalizer :: Applicative m => Monoid (Finalizer m) where
  mempty = Finalizer (pure unit)

-- | Runs a finalizer.
finalize :: forall m. Finalizer m -> m Unit
finalize (Finalizer a) = a

-- | Changes the effect monad for a finalizer.
hoistFinalizer :: forall m n. (m ~> n) -> Finalizer m -> Finalizer n
hoistFinalizer nat (Finalizer a) = Finalizer (nat a)


Fix Show Kind instance

Fix Show Kind instance

module Language.PureScript.Kinds where

import Control.Monad.Unify (Unknown())

-- |
-- The data type of kinds
--
data Kind
  -- |
  -- Unification variable of type Kind
  --
  = KUnknown Unknown
  -- |
  -- The kind of types
  --
  | Star
  -- |
  -- The kind of effects
  --
  | Bang
  -- |
  -- Kinds for labelled, unordered rows without duplicates
  --
  | Row Kind
  -- |
  -- Function kinds
  --
  | FunKind Kind Kind

instance showKind :: Show Kind where
  show (KUnknown u) = "KUnknown " ++ show u
  show Star = "Star"
  show Bang = "Bang"
  show (Row k) = "Row " ++ show k
  show (FunKind x y) = "FunKind (" ++ show x ++ ") (" ++ show y ++ ")"

instance eqKind :: Eq Kind where
  (==) (KUnknown u1) (KUnknown u2) = u1 == u2
  (==) Star Star = true
  (==) Bang Bang = true
  (==) (Row k1) (Row k2) = k1 == k2
  (==) (FunKind x1 y1) (FunKind x2 y2) = x1 == y1 && x2 == y2
  (==) _ _ = false
  (/=) x y = not (x == y)

everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind
everywhereOnKinds f = go
  where
  go (Row k1) = f (Row (go k1))
  go (FunKind k1 k2) = f (FunKind (go k1) (go k2))
  go other = f other

everythingOnKinds :: forall r. (r -> r -> r) -> (Kind -> r) -> Kind -> r
everythingOnKinds (<>) f = go
  where
  go k@(Row k1) = f k <> go k1
  go k@(FunKind k1 k2) = f k <> go k1 <> go k2
  go other = f other

module Language.PureScript.Kinds where

import Control.Monad.Unify (Unknown())

-- |
-- The data type of kinds
--
data Kind
  -- |
  -- Unification variable of type Kind
  --
  = KUnknown Unknown
  -- |
  -- The kind of types
  --
  | Star
  -- |
  -- The kind of effects
  --
  | Bang
  -- |
  -- Kinds for labelled, unordered rows without duplicates
  --
  | Row Kind
  -- |
  -- Function kinds
  --
  | FunKind Kind Kind

instance showKind :: Show Kind where
  show (KUnknown u) = "KUnknown " ++ show u
  show Star = "Star"
  show Bang = "Bang"
  show (Row k) = "Row " ++ show k
  show (FunKind x y) = "FunKind " ++ show x ++ " " ++ show y

instance eqKind :: Eq Kind where
  (==) (KUnknown u1) (KUnknown u2) = u1 == u2
  (==) Star Star = true
  (==) Bang Bang = true
  (==) (Row k1) (Row k2) = k1 == k2
  (==) (FunKind x1 y1) (FunKind x2 y2) = x1 == y1 && x2 == y2
  (==) _ _ = false
  (/=) x y = not (x == y)

everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind
everywhereOnKinds f = go
  where
  go (Row k1) = f (Row (go k1))
  go (FunKind k1 k2) = f (FunKind (go k1) (go k2))
  go other = f other

everythingOnKinds :: forall r. (r -> r -> r) -> (Kind -> r) -> Kind -> r
everythingOnKinds (<>) f = go
  where
  go k@(Row k1) = f k <> go k1
  go k@(FunKind k1 k2) = f k <> go k1 <> go k2
  go other = f other