fix itemized duration

fix itemized duration

module Weekend where

import Prelude

import Control.Apply (lift2)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Now (NOW, locale, now)
import Data.DateTime (DateTime, adjust, date, diff, modifyTime, setHour, setMinute, setSecond, setMillisecond, weekday)
import Data.DateTime.Instant (toDateTime)
import Data.DateTime.Locale (Locale(..))
import Data.Either (either)
import Data.Enum (fromEnum, toEnum)
import Data.Formatter.DateTime (formatDateTime)
import Data.Formatter.Number (Formatter(..), format)
import Data.Int (floor, toNumber)
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.Time.Duration (class Duration, Days(..), Hours(..), Milliseconds(..), Minutes(..), Seconds(..), convertDuration)
import Data.Tuple (Tuple(..))
import Math (remainder)

weekendStartDayOfWeek :: Int
weekendStartDayOfWeek = 5

weekendStartHour :: Int
weekendStartHour = 17

offset :: forall eff. Eff (now :: NOW | eff) Minutes
offset = map (\(Locale _ min) -> negate min) locale

currentLocalTime :: forall eff. Eff (now :: NOW | eff) DateTime
currentLocalTime = map (fromMaybe bottom) effMaybeDateTime
  where
  effMaybeDateTime = lift2 adjust offset (map toDateTime now)

formattedCurrentTime :: forall eff. Eff (now :: NOW | eff) String
formattedCurrentTime = map toString currentLocalTime
  where
  toString dateTime = let workaroundForWeekday = show $ weekday $ date dateTime
                          formattedDate = (formatDateTime "HH:mm" >>> either (const "ERROR") id) dateTime
                       in workaroundForWeekday <> ", " <> formattedDate

isWeekend :: forall eff. Eff (now :: NOW | eff) Boolean
isWeekend = map isNothing durationTillWeekend

durationTillWeekend :: forall eff. Eff (now :: NOW | eff) (Maybe String)
durationTillWeekend = map testWeekend currentLocalTime
  where
  testWeekend now =
    let dayOfWeek = fromEnum $ weekday $ date now
        dayDiff   = Days $ toNumber (weekendStartDayOfWeek - dayOfWeek)
        startDate = fromMaybe bottom $ adjust dayDiff now
        startDatetime = modifyTime ((setHour $ fromMaybe bottom $ toEnum weekendStartHour) >>> (setMinute $ fromMaybe bottom $ toEnum 0) >>> (setSecond $ fromMaybe bottom $ toEnum 0) >>> (setMillisecond $ fromMaybe bottom $ toEnum 0)) startDate
     in if startDatetime < now
        then Nothing
        else let timeFormatter = Formatter { comma: false, before: 2, after: 0, abbreviations: false, sign: false }
                 difference :: ItemizedDuration
                 difference = diff startDatetime now
              in case difference of
                (Itemized (Days d) (Hours h) (Minutes m) (Seconds s) (Milliseconds ms)) ->
                  let dd = show $ floor d
                      hh = format timeFormatter h
                      mm = format timeFormatter m
                      ss = format timeFormatter s
                  in Just $ (if d > 0.0 then dd <> " days and " else "") <> hh <> ":" <> mm <> ":" <> ss

msInSecond :: Number
msInSecond = 1000.0
msInMinute :: Number
msInMinute = 60.0 * msInSecond
msInHour :: Number
msInHour = 60.0 * msInMinute
msInDay :: Number
msInDay = 24.0 * msInHour

data ItemizedDuration = Itemized Days Hours Minutes Seconds Milliseconds

instance durationItemized :: Duration ItemizedDuration where
  fromDuration (Itemized (Days d) (Hours h) (Minutes m) (Seconds s) (Milliseconds ms)) =
    Milliseconds (d * msInDay + h * msInHour + m * msInMinute + s * msInSecond + ms)
  toDuration (Milliseconds ms') = Itemized (Days d) (Hours h) (Minutes m) (Seconds s) (Milliseconds ms)
    where divMod x y = Tuple (div x y) (remainder x y)
          Tuple s' ms = divMod ms' 1000.0
          Tuple m' s  = divMod s' 60.0
          Tuple h' m  = divMod m' 60.0
          Tuple d  h  = divMod h' 24.0

module Weekend where

import Prelude

import Control.Apply (lift2)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Now (NOW, locale, now)
import Data.DateTime (DateTime, adjust, date, diff, modifyTime, setHour, setMinute, setSecond, setMillisecond, weekday)
import Data.DateTime.Instant (toDateTime)
import Data.DateTime.Locale (Locale(..))
import Data.Either (either)
import Data.Enum (fromEnum, toEnum)
import Data.Formatter.DateTime (formatDateTime)
import Data.Formatter.Number (Formatter(..), format)
import Data.Int (floor, toNumber)
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.Time.Duration (class Duration, Days(..), Hours(..), Milliseconds(..), Minutes(..), Seconds(..))
import Data.Tuple (Tuple(..))

weekendStartDayOfWeek :: Int
weekendStartDayOfWeek = 5

weekendStartHour :: Int
weekendStartHour = 17

offset :: forall eff. Eff (now :: NOW | eff) Minutes
offset = map (\(Locale _ min) -> negate min) locale

currentLocalTime :: forall eff. Eff (now :: NOW | eff) DateTime
currentLocalTime = map (fromMaybe bottom) effMaybeDateTime
  where
  effMaybeDateTime = lift2 adjust offset (map toDateTime now)

formattedCurrentTime :: forall eff. Eff (now :: NOW | eff) String
formattedCurrentTime = map toString currentLocalTime
  where
  toString dateTime = let workaroundForWeekday = show $ weekday $ date dateTime
                          formattedDate = (formatDateTime "HH:mm" >>> either (const "ERROR") id) dateTime
                       in workaroundForWeekday <> ", " <> formattedDate

isWeekend :: forall eff. Eff (now :: NOW | eff) Boolean
isWeekend = map isNothing durationTillWeekend

durationTillWeekend :: forall eff. Eff (now :: NOW | eff) (Maybe String)
durationTillWeekend = map testWeekend currentLocalTime
  where
  testWeekend now =
    let dayOfWeek = fromEnum $ weekday $ date now
        dayDiff   = Days $ toNumber (weekendStartDayOfWeek - dayOfWeek)
        startDate = fromMaybe bottom $ adjust dayDiff now
        startDatetime = modifyTime ((setHour $ fromMaybe bottom $ toEnum weekendStartHour) >>> (setMinute $ fromMaybe bottom $ toEnum 0) >>> (setSecond $ fromMaybe bottom $ toEnum 0) >>> (setMillisecond $ fromMaybe bottom $ toEnum 0)) startDate
     in if startDatetime < now
        then Nothing
        else let timeFormatter = Formatter { comma: false, before: 2, after: 0, abbreviations: false, sign: false }
                 difference :: ItemizedDuration
                 difference = diff startDatetime now
              in case difference of
                (Itemized (Days d) (Hours h) (Minutes m) (Seconds s) (Milliseconds ms)) ->
                  let dd = show $ floor d
                      hh = format timeFormatter h
                      mm = format timeFormatter m
                      ss = format timeFormatter s
                  in Just $ (if d > 0.0 then dd <> " days and " else "") <> hh <> ":" <> mm <> ":" <> ss

msInSecond :: Number
msInSecond = 1000.0
msInMinute :: Number
msInMinute = 60.0 * msInSecond
msInHour :: Number
msInHour = 60.0 * msInMinute
msInDay :: Number
msInDay = 24.0 * msInHour

data ItemizedDuration = Itemized Days Hours Minutes Seconds Milliseconds

instance durationItemized :: Duration ItemizedDuration where
  fromDuration (Itemized (Days d) (Hours h) (Minutes m) (Seconds s) (Milliseconds ms)) =
    Milliseconds (d * msInDay + h * msInHour + m * msInMinute + s * msInSecond + ms)
  toDuration (Milliseconds ms') = Itemized (Days d) (Hours h) (Minutes m) (Seconds s) (Milliseconds ms)
    where divMod x y = Tuple (div x y) (mod x y)
          Tuple s' ms = divMod ms' 1000.0
          Tuple m' s  = divMod s' 60.0
          Tuple h' m  = divMod m' 60.0
          Tuple d  h  = divMod h' 24.0


Add preventDefault to mount dialog (#400)

This is meant to resolve #400, but sadly I cannot reproduce the
intermittent issue that prompted this change anymore. If indeed it is
the case that the button was causing the page to refresh (by virtue of
being inside a <form>), then this should solve the problem. But it is
not really clear to me that this is what was going on, since I don't
know why it would be non-deterministic.

In any case, the change is probably harmless.

Mount modal form; add preventDefault to onSubmit (via nonSubmit)

Related to #400

module View.File.Modal.MountDialog (mountDialog) where

import Prelude
import Control.Apply ((*>))
import Data.Functor (($>))
import Control.Alt ((<|>))
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Plus (empty)
import Controller.File (saveMount)
import Controller.File.Common (Event())
import Data.Array ((..), length, zipWith, singleton)
import Data.Either (either)
import Data.Foldable (all)
import Data.Inject1 (inj)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.URI (runParseAbsoluteURI, printAbsoluteURI)
import Input.File (FileInput(..))
import Input.File.Mount (MountInput(..))
import Model.File (_dialog)
import Optic.Getter ((^.))
import Optic.Setter ((.~))
import Optic.Index (ix)
import Optic.Index.Types (TraversalP())
import Utils (select, clearValue)
import Utils.Halide (selectThis, onPaste)
import View.Common (glyph, closeButton)
import View.File.Common (HTML())
import View.Modal.Common (header, h4, body, footer, nonSubmit)

import qualified Data.String.Regex as Rx
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as E
import qualified Halogen.HTML.Events.Forms as E
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import qualified Halogen.HTML.Events.Types as ET
import qualified Halogen.Themes.Bootstrap3 as B
import qualified Model.File.Dialog.Mount as M
import qualified View.Css as VC

mountDialog :: forall e. M.MountDialogRec -> Array (HTML e)
mountDialog state =
  [ header $ h4 "Mount"
  , body [ H.form [ A.class_ VC.dialogMount, nonSubmit ]
                  $ (if state.new then [fldName state] else [])
                 ++ [ fldConnectionURI state
                    , selScheme state
                    , userinfo state
                    , hosts state
                    , fldPath state
                    , props state
                    , message errorMessage
                    ]
         ]
  , footer [ progressSpinner state
           , btnCancel
           , btnMount state (if state.new then "Mount" else "Save changes") (state.valid && not state.inProgress)
           ]
  ]

  where
    errorMessage = state.message <|> state.externalValidationError

progressSpinner :: forall e. M.MountDialogRec -> HTML e
progressSpinner state =
  H.img [ A.src $ "img/spin.gif"
        , A.class_ $ VC.mountProgressSpinner state.inProgress
        ]
        []

fldName :: forall e. M.MountDialogRec -> HTML e
fldName state =
  H.div [ A.classes [B.formGroup, VC.mountName] ]
        [ label "Name" [ input state M._name [] ] ]

fldConnectionURI :: forall e. M.MountDialogRec -> HTML e
fldConnectionURI state =
  H.div [ A.classes [B.formGroup, VC.mountURI] ]
        [ label "URI"
                [ H.input [ A.class_ B.formControl
                          , A.placeholder "Paste connection URI here"
                          , A.value (hidePassword state.connectionURI)
                          , E.onKeyDown clearText
                          , E.onKeyPress handleKeyInput
                          , E.onInput (E.input \value -> inj $ UpdateConnectionURI value)
                          , pasteHandler
                          ]
                          []
                ]
        ]
  where

  -- Delete the entire connection URI contents when backspace or delete is used.
  clearText :: ET.Event ET.KeyboardEvent -> E.EventHandler (Event e)
  clearText e =
    if (e.keyCode == 8.0 || e.keyCode == 46.0)
    then E.preventDefault $> (liftEff (clearValue e.target) *> pure (inj $ UpdateConnectionURI ""))
    else pure empty

  -- Ignore key inputs aside from Ctrl+V or Meta+V. When any other keypress is
  -- detected select the current contents instead.
  handleKeyInput :: ET.Event ET.KeyboardEvent -> E.EventHandler (Event e)
  handleKeyInput e =
    if (e.ctrlKey || e.metaKey) && e.charCode == 118.0
    then pure empty
    else E.preventDefault *> selectThis e

  -- In Chrome, this is used to prevent multiple values being pasted in the
  -- field - once pasted, the value is selected so that the new value replaces
  -- it.
  pasteHandler :: A.Attr (Event e)
  pasteHandler = onPaste selectThis

  hidePassword :: String -> String
  hidePassword s = either (const s) go $ runParseAbsoluteURI s
    where
    go uri = printAbsoluteURI $ M.setURIPassword (M.hidePassword (M.passwordFromURI uri)) uri

selScheme :: forall e. M.MountDialogRec -> HTML e
selScheme state =
  H.div [ A.class_ B.formGroup ]
        [ label "Scheme"
                [ H.select [ A.class_ B.formControl ]
                           [ H.option_ [ H.text "mongodb" ] ]
                ]
        ]

hosts :: forall e. M.MountDialogRec -> HTML e
hosts state =
  let allEmpty = M.isEmptyHost `all` state.hosts
  in H.div [ A.classes [B.formGroup, VC.mountHostList] ]
           $ (\ix -> host state ix (ix > 0 && allEmpty)) <$> 0 .. (length state.hosts - 1)

host :: forall p e. M.MountDialogRec -> Int -> Boolean -> HTML e
host state index enabled =
  H.div [ A.class_ VC.mountHost ]
        [ label "Host" [ input' rejectNonHostname state (M._hosts <<< ix index <<< M._host) [ A.disabled enabled ] ]
        , label "Port" [ input' rejectNonPort state (M._hosts <<< ix index <<< M._port) [ A.disabled enabled ] ]
        ]
  where
  rejectNonHostname :: String -> String
  rejectNonHostname = Rx.replace rxNonHostname ""
  rxNonHostname :: Rx.Regex
  rxNonHostname = Rx.regex "[^0-9a-z\\-\\._~%]" (Rx.noFlags { ignoreCase = true, global = true })
  rejectNonPort :: String -> String
  rejectNonPort = Rx.replace rxNonPort ""
  rxNonPort :: Rx.Regex
  rxNonPort = Rx.regex "[^0-9]" (Rx.noFlags { global = true })

fldPath :: forall e. M.MountDialogRec -> HTML e
fldPath state =
  H.div [ A.class_ B.formGroup ]
        [ label "Path" [ input state M._path [] ] ]

userinfo state =
  H.div [ A.classes [B.formGroup, VC.mountUserInfo] ]
        [ fldUser state
        , fldPass state
        ]

fldUser :: forall p e. M.MountDialogRec -> HTML e
fldUser state = label "Username" [ input state M._user [] ]

fldPass :: forall p e. M.MountDialogRec -> HTML e
fldPass state = label "Password" [ input state M._password [ A.type_ "password" ] ]

props :: forall e. M.MountDialogRec -> HTML e
props state =
  H.div [ A.classes [B.formGroup, VC.mountProps] ]
        [ label "Properties" []
        , H.table [ A.classes [B.table, B.tableBordered] ]
                  [ H.thead_ [ H.tr_ [ H.th_ [ H.text "Name" ]
                                     , H.th_ [ H.text "Value" ]
                                     ]
                             ]
                  , H.tbody_ [ H.tr_ [ H.td [ A.colSpan 2.0 ]
                                            [ H.div [ A.class_ VC.mountPropsScrollbox ]
                                                    [ H.table_ $ (prop state) <$> 0 .. (length state.props - 1) ]
                                            ]
                                     ]
                             ]
                  ]
        ]

prop :: forall e. M.MountDialogRec -> Int -> HTML e
prop state index =
  H.tr_ [ H.td_ [ input state (M._props <<< ix index <<< M._name) [ A.classes [B.formControl, B.inputSm] ] ]
        , H.td_ [ input state (M._props <<< ix index <<< M._value) [ A.classes [B.formControl, B.inputSm] ] ]
        ]

message :: forall e. Maybe String -> HTML e
message msg =
  H.div [ A.classes $ [B.alert, B.alertDanger, B.alertDismissable, B.fade] ++ if isJust msg then [B.in_] else [] ]
      $ [ closeButton (E.input_ $ inj ClearMessage) ] ++ maybe [] (singleton <<< H.text) msg

btnCancel :: forall e. HTML e
btnCancel =
  H.button [ A.classes [B.btn]
           , E.onClick (E.input_ $ inj $ WithState (_dialog .~ Nothing))
           ]
           [ H.text "Cancel" ]

btnMount :: forall e. M.MountDialogRec -> String -> Boolean -> HTML e
btnMount state text enabled =
  H.button [ A.classes [B.btn, B.btnPrimary]
           , A.disabled (not enabled)
           , E.onClick (\_ -> pure $ saveMount state)
           ]
           [ H.text text ]

-- | A labelled section within the form.
label :: forall i. String -> Array (H.HTML i) -> H.HTML i
label text inner = H.label_ $ [ H.span_ [ H.text text ] ] ++ inner

-- | A basic text input field that uses a lens to read from and update the
-- | state.
input :: forall e. M.MountDialogRec
                  -> TraversalP M.MountDialogRec String
                  -> Array (A.Attr (Event e))
                  -> HTML e
input state lens = input' id state lens -- can't eta reduce further here as the typechecker doesn't like it

-- | A basic text input field that uses a lens to read from and update the
-- | state, and allows for the input value to be modified.
input' :: forall p e. (String -> String)
                   -> M.MountDialogRec
                   -> TraversalP M.MountDialogRec String
                   -> Array (A.Attr (Event e))
                   -> HTML e
input' f state lens attrs =
  H.input ([ A.class_ B.formControl
           , E.onInput (E.input \val -> inj $ ValueChanged (lens .~ f val))
           , A.value (state ^. lens)
           ] ++ attrs)
          []

module View.File.Modal.MountDialog (mountDialog) where

import Prelude
import Control.Apply ((*>))
import Data.Functor (($>))
import Control.Alt ((<|>))
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Plus (empty)
import Controller.File (saveMount)
import Controller.File.Common (Event())
import Data.Array ((..), length, zipWith, singleton)
import Data.Either (either)
import Data.Foldable (all)
import Data.Inject1 (inj)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.URI (runParseAbsoluteURI, printAbsoluteURI)
import Input.File (FileInput(..))
import Input.File.Mount (MountInput(..))
import Model.File (_dialog)
import Optic.Getter ((^.))
import Optic.Setter ((.~))
import Optic.Index (ix)
import Optic.Index.Types (TraversalP())
import Utils (select, clearValue)
import Utils.Halide (selectThis, onPaste)
import View.Common (glyph, closeButton)
import View.File.Common (HTML())
import View.Modal.Common (header, h4, body, footer)

import qualified Data.String.Regex as Rx
import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as E
import qualified Halogen.HTML.Events.Forms as E
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import qualified Halogen.HTML.Events.Types as ET
import qualified Halogen.Themes.Bootstrap3 as B
import qualified Model.File.Dialog.Mount as M
import qualified View.Css as VC

mountDialog :: forall e. M.MountDialogRec -> Array (HTML e)
mountDialog state =
  [ header $ h4 "Mount"
  , body [ H.form [ A.class_ VC.dialogMount ]
                  $ (if state.new then [fldName state] else [])
                 ++ [ fldConnectionURI state
                    , selScheme state
                    , userinfo state
                    , hosts state
                    , fldPath state
                    , props state
                    , message errorMessage
                    ]
         ]
  , footer [ progressSpinner state
           , btnCancel
           , btnMount state (if state.new then "Mount" else "Save changes") (state.valid && not state.inProgress)
           ]
  ]

  where
    errorMessage = state.message <|> state.externalValidationError

progressSpinner :: forall e. M.MountDialogRec -> HTML e
progressSpinner state =
  H.img [ A.src $ "img/spin.gif"
        , A.class_ $ VC.mountProgressSpinner state.inProgress
        ]
        []

fldName :: forall e. M.MountDialogRec -> HTML e
fldName state =
  H.div [ A.classes [B.formGroup, VC.mountName] ]
        [ label "Name" [ input state M._name [] ] ]

fldConnectionURI :: forall e. M.MountDialogRec -> HTML e
fldConnectionURI state =
  H.div [ A.classes [B.formGroup, VC.mountURI] ]
        [ label "URI"
                [ H.input [ A.class_ B.formControl
                          , A.placeholder "Paste connection URI here"
                          , A.value (hidePassword state.connectionURI)
                          , E.onKeyDown clearText
                          , E.onKeyPress handleKeyInput
                          , E.onInput (E.input \value -> inj $ UpdateConnectionURI value)
                          , pasteHandler
                          ]
                          []
                ]
        ]
  where

  -- Delete the entire connection URI contents when backspace or delete is used.
  clearText :: ET.Event ET.KeyboardEvent -> E.EventHandler (Event e)
  clearText e =
    if (e.keyCode == 8.0 || e.keyCode == 46.0)
    then E.preventDefault $> (liftEff (clearValue e.target) *> pure (inj $ UpdateConnectionURI ""))
    else pure empty

  -- Ignore key inputs aside from Ctrl+V or Meta+V. When any other keypress is
  -- detected select the current contents instead.
  handleKeyInput :: ET.Event ET.KeyboardEvent -> E.EventHandler (Event e)
  handleKeyInput e =
    if (e.ctrlKey || e.metaKey) && e.charCode == 118.0
    then pure empty
    else E.preventDefault *> selectThis e

  -- In Chrome, this is used to prevent multiple values being pasted in the
  -- field - once pasted, the value is selected so that the new value replaces
  -- it.
  pasteHandler :: A.Attr (Event e)
  pasteHandler = onPaste selectThis

  hidePassword :: String -> String
  hidePassword s = either (const s) go $ runParseAbsoluteURI s
    where
    go uri = printAbsoluteURI $ M.setURIPassword (M.hidePassword (M.passwordFromURI uri)) uri

selScheme :: forall e. M.MountDialogRec -> HTML e
selScheme state =
  H.div [ A.class_ B.formGroup ]
        [ label "Scheme"
                [ H.select [ A.class_ B.formControl ]
                           [ H.option_ [ H.text "mongodb" ] ]
                ]
        ]

hosts :: forall e. M.MountDialogRec -> HTML e
hosts state =
  let allEmpty = M.isEmptyHost `all` state.hosts
  in H.div [ A.classes [B.formGroup, VC.mountHostList] ]
           $ (\ix -> host state ix (ix > 0 && allEmpty)) <$> 0 .. (length state.hosts - 1)

host :: forall p e. M.MountDialogRec -> Int -> Boolean -> HTML e
host state index enabled =
  H.div [ A.class_ VC.mountHost ]
        [ label "Host" [ input' rejectNonHostname state (M._hosts <<< ix index <<< M._host) [ A.disabled enabled ] ]
        , label "Port" [ input' rejectNonPort state (M._hosts <<< ix index <<< M._port) [ A.disabled enabled ] ]
        ]
  where
  rejectNonHostname :: String -> String
  rejectNonHostname = Rx.replace rxNonHostname ""
  rxNonHostname :: Rx.Regex
  rxNonHostname = Rx.regex "[^0-9a-z\\-\\._~%]" (Rx.noFlags { ignoreCase = true, global = true })
  rejectNonPort :: String -> String
  rejectNonPort = Rx.replace rxNonPort ""
  rxNonPort :: Rx.Regex
  rxNonPort = Rx.regex "[^0-9]" (Rx.noFlags { global = true })

fldPath :: forall e. M.MountDialogRec -> HTML e
fldPath state =
  H.div [ A.class_ B.formGroup ]
        [ label "Path" [ input state M._path [] ] ]

userinfo state =
  H.div [ A.classes [B.formGroup, VC.mountUserInfo] ]
        [ fldUser state
        , fldPass state
        ]

fldUser :: forall p e. M.MountDialogRec -> HTML e
fldUser state = label "Username" [ input state M._user [] ]

fldPass :: forall p e. M.MountDialogRec -> HTML e
fldPass state = label "Password" [ input state M._password [ A.type_ "password" ] ]

props :: forall e. M.MountDialogRec -> HTML e
props state =
  H.div [ A.classes [B.formGroup, VC.mountProps] ]
        [ label "Properties" []
        , H.table [ A.classes [B.table, B.tableBordered] ]
                  [ H.thead_ [ H.tr_ [ H.th_ [ H.text "Name" ]
                                     , H.th_ [ H.text "Value" ]
                                     ]
                             ]
                  , H.tbody_ [ H.tr_ [ H.td [ A.colSpan 2.0 ]
                                            [ H.div [ A.class_ VC.mountPropsScrollbox ]
                                                    [ H.table_ $ (prop state) <$> 0 .. (length state.props - 1) ]
                                            ]
                                     ]
                             ]
                  ]
        ]

prop :: forall e. M.MountDialogRec -> Int -> HTML e
prop state index =
  H.tr_ [ H.td_ [ input state (M._props <<< ix index <<< M._name) [ A.classes [B.formControl, B.inputSm] ] ]
        , H.td_ [ input state (M._props <<< ix index <<< M._value) [ A.classes [B.formControl, B.inputSm] ] ]
        ]

message :: forall e. Maybe String -> HTML e
message msg =
  H.div [ A.classes $ [B.alert, B.alertDanger, B.alertDismissable, B.fade] ++ if isJust msg then [B.in_] else [] ]
      $ [ closeButton (E.input_ $ inj ClearMessage) ] ++ maybe [] (singleton <<< H.text) msg

btnCancel :: forall e. HTML e
btnCancel =
  H.button [ A.classes [B.btn]
           , E.onClick (E.input_ $ inj $ WithState (_dialog .~ Nothing))
           ]
           [ H.text "Cancel" ]

btnMount :: forall e. M.MountDialogRec -> String -> Boolean -> HTML e
btnMount state text enabled =
  H.button [ A.classes [B.btn, B.btnPrimary]
           , A.disabled (not enabled)
           , E.onClick (\_ -> pure $ saveMount state)
           ]
           [ H.text text ]

-- | A labelled section within the form.
label :: forall i. String -> Array (H.HTML i) -> H.HTML i
label text inner = H.label_ $ [ H.span_ [ H.text text ] ] ++ inner

-- | A basic text input field that uses a lens to read from and update the
-- | state.
input :: forall e. M.MountDialogRec
                  -> TraversalP M.MountDialogRec String
                  -> Array (A.Attr (Event e))
                  -> HTML e
input state lens = input' id state lens -- can't eta reduce further here as the typechecker doesn't like it

-- | A basic text input field that uses a lens to read from and update the
-- | state, and allows for the input value to be modified.
input' :: forall p e. (String -> String)
                   -> M.MountDialogRec
                   -> TraversalP M.MountDialogRec String
                   -> Array (A.Attr (Event e))
                   -> HTML e
input' f state lens attrs =
  H.input ([ A.class_ B.formControl
           , E.onInput (E.input \val -> inj $ ValueChanged (lens .~ f val))
           , A.value (state ^. lens)
           ] ++ attrs)
          []


fixed some warnings caused by imports

fixed some warnings caused by imports

module Test.TypeChecker where

import AST (AD(TList, TTuple), Atom(AInt, Name, Char), Binding(Lit, ConsLit, ListLit, NTupleLit), Definition(Def), Expr(Atom, List, SectR, App, Binary, PrefixOp, Lambda, NTuple, LetExpr, SectL), Op(Power, Colon, Add, Append), TVar(TVar), Type(TypCon, TypVar, AD, TypArr), TypeError(InfiniteType, UnificationFail, UnknownError))
import TypeChecker (Subst, Infer, TypeEnv, Scheme(Forall), inferGroup, inferType, inferDef, prettyPrintType, emptyTyenv, runInfer, typeProgramn, eqScheme)
import Parser (expression, definition)

import Prelude (Unit, bind, ($), show, (==), (++))
import Data.Either (Either(..))
import Data.List (List(..), toList)
import Data.Tuple (Tuple)

import Text.Parsing.Parser (ParseError, runParser)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)

import Control.Monad.State

testInfer:: forall a  eff. String -> a -> (TypeEnv -> a -> Infer (Tuple Subst Type))
 -> Either TypeError Scheme -> Eff (console :: CONSOLE | eff ) Unit
testInfer name input f expected
  = test name  expected $ runInfer $ f emptyTyenv input

testProgramm:: forall eff. String -> List Definition -> Expr
 -> Either TypeError Scheme -> Eff (console :: CONSOLE | eff ) Unit
testProgramm name defs exp expected
 = test name expected $ typeProgramn defs exp

-- test  name -> expected -> actuall -> Eff ...
test:: forall eff. String -> Either TypeError Scheme -> Either TypeError Scheme
 -> Eff (console :: CONSOLE | eff ) Unit
test name expected actuall = if eqTypErrScheme expected actuall
  then log $ "Typing success ("  ++ name ++ ")"
  else log $ "\n \n Typing fail (" ++ name ++ ") :  expected result: \n"
    ++ show expected ++ "\n actuall result: \n" ++ show actuall ++ "\n \n"
     ++ "Pretty Print expected: \n" ++ prettyPrint expected
      ++ "\n Pretty Print actuall: \n" ++ prettyPrint actuall ++ "\n \n"

eqTypErrScheme:: Either TypeError Scheme -> Either TypeError Scheme -> Boolean
eqTypErrScheme (Left a) (Left a') = (a == a')
eqTypErrScheme (Right a) (Right a') = eqScheme a a'
eqTypErrScheme _ _ = false

aint :: Int -> Expr
aint i = Atom $ AInt i

aname :: String -> Expr
aname s = Atom $ Name s

tvar :: String -> Type
tvar s = TypVar $ TVar s

out::forall eff. String -> Eff (console :: CONSOLE | eff ) Unit
out s = log s

parseExp:: String -> Either ParseError Expr
parseExp exp = runParser exp expression

parseDef:: String -> Either ParseError Definition
parseDef def = runParser def definition

typeStr:: String -> Either TypeError Scheme
typeStr expS = case runParser expS expression of
  Right exp -> runInfer $ inferType emptyTyenv exp
  Left _ -> Left $ UnknownError "Parse Error"

typeStrPre:: String -> Either TypeError Scheme
typeStrPre expS = case runParser expS expression of
  Right exp -> typeProgramn Test.Parser.parsedPrelude exp
  Left _ -> Left $ UnknownError "Parse Error"

typeExp:: Expr -> Either TypeError Scheme
typeExp exp = runInfer $ inferType emptyTyenv exp

typeDef:: Definition -> Either TypeError Scheme
typeDef def = runInfer $ inferDef emptyTyenv def

prettyPrint:: Either TypeError Scheme -> String
prettyPrint a@(Left _) = show a
prettyPrint (Right (Forall _ t)) = prettyPrintType t

printTypeExp::forall eff. Expr -> Eff (console :: CONSOLE | eff ) Unit
printTypeExp e = out $ prettyPrint $ typeExp e

printTypeStr::forall eff. String -> Eff (console :: CONSOLE | eff ) Unit
printTypeStr s = out $ prettyPrint $ typeStr s

-- default 1
d1 = Right (Forall Nil $ tvar "a")

runTests :: forall eff. Eff (console :: CONSOLE | eff) Unit
runTests = do
  log "Running Typing Tests"

  testInfer "SectL" (SectL (aint 3) Power)
    inferType(Right (Forall Nil $ TypArr (TypCon "Int") (TypCon "Int")))
  testInfer "SectR" (SectR Power (aint 3))
    inferType(Right (Forall (Nil) (TypArr (TypCon "Int") (TypCon "Int"))))
  testInfer "Lambda1" (Lambda (toList $ [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c",Lit $ Name "d"]) (App (aname "a") (toList [aname "b", aname "c", aname "d"])))
    inferType(Right (Forall (toList [TVar "b",TVar "c", TVar "d", TVar "e"]) (TypArr (TypArr (tvar "b") (TypArr (tvar "c") (TypArr (tvar "d") (tvar "e")))) (TypArr ( tvar "b")  ((TypArr (tvar "c") (TypArr (tvar "d") (tvar "e"))))))))
  testInfer "Lambda2" (Lambda (toList [Lit $ Name "a", Lit $ Name "b"]) (App (aname "a") (toList [aname "b"])))
    inferType(Right (Forall (Cons ((TVar "t_3")) (Cons ((TVar "t_4")) (Nil))) (TypArr (TypArr (TypVar  (TVar "t_3")) (TypVar  (TVar "t_4"))) (TypArr (TypVar  (TVar "t_3")) (TypVar  (TVar "t_4"))))))
  testInfer "List1" (List (toList [aint 1, aint 2, aint 3, aint 4, aint 5])) inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "List2" (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
    inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "List3" (List $ toList [PrefixOp Add, aint 4])
    inferType(Left ((UnificationFail (TypCon "Int") (TypArr (TypCon "Int") (TypArr (TypCon "Int") (TypCon "Int"))))))
  testInfer "Nil List" (List Nil)
    inferType  (Right (Forall (Cons ((TVar "t_0")) (Nil)) (AD (TList (TypVar  (TVar "t_0"))))))
  testInfer "Append" (Binary Append
    (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
    (List Nil))
    inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "Colon" (Binary Colon (aint 3) (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4),Atom $ Char "Hallo"]))
    inferType(Left ((UnificationFail (TypCon "Char") (TypCon "Int"))))
  testInfer "NTuple" (NTuple (toList [Binary Add (aint 1) (aint 2), aint 3]))
    inferType(Right (Forall (Nil) (AD (TTuple (Cons ((TypCon "Int")) (Cons ((TypCon "Int")) (Nil)))))))
  testInfer "SectR Colon" (SectR Colon $ List $ toList [aint 3])
    inferType(Right (Forall (Nil) (TypArr (TypCon "Int") (AD (TList (TypCon "Int"))))))
  testInfer "Def ~map" (Def "map" (toList [Lit $ Name "f", Lit $ Name "xs"]) (App (aname "map") (toList [aname "f",aname"xs"])))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Cons ((TVar "t_4")) (Cons ((TVar "t_5")) (Nil)))) (TypArr (TypVar  (TVar "t_2")) (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_5"))))))
  testInfer "Lambda Wildcard" (Lambda (toList [Lit (Name "_"), Lit (Name "_")]) (aint 5))
    inferType(Right (Forall (Cons ((TVar "t_1")) (Cons ((TVar "t_3")) (Nil))) (TypArr (TypVar  (TVar "t_1")) (TypArr (TypVar  (TVar "t_3")) (TypCon "Int")))))
  testInfer "Lambda ConsBinding" (Lambda (toList [ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (aname "x"))
    inferType(Right (Forall (Cons ((TVar "t_2")) (Nil)) (TypArr (AD (TList (TypVar  (TVar "t_2")))) (TypVar  (TVar "t_2")))))
  testInfer "singel map" (Def "map" (toList [Lit $ Name "f", ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (App  (PrefixOp Colon) (toList [App (aname "f") $ toList [(aname"x")], App (aname "map") (toList [aname"f", aname"xs"])])))
    inferDef (Right (Forall (Cons ((TVar "t_11")) (Cons ((TVar "t_5")) (Nil))) (TypArr (TypArr (TypVar  (TVar "t_5")) (TypVar  (TVar "t_11"))) (TypArr (AD (TList (TypVar  (TVar "t_5")))) (AD (TList (TypVar  (TVar "t_11"))))))))
  testInfer "foldr" (Def "foldr" (toList [Lit $ Name "f", Lit $ Name "ini", ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (App (aname "f") (toList [aname "x",App (aname "foldr") (toList [aname "f", aname "ini" ,aname "xs"  ] )])))
    inferDef (Right (Forall (Cons ((TVar "t_5")) (Cons ((TVar "t_4")) (Cons ((TVar "t_7")) Nil))) (TypArr (TypArr (TypVar  (TVar "t_7")) (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_4")))) (TypArr (TypVar  (TVar "t_5")) (TypArr (AD (TList (TypVar  (TVar "t_7")))) (TypVar  (TVar "t_4")))))))
  testInfer "let Expr"  (LetExpr (Lit $ Name "x") (aint 3) (Lambda (toList [Lit (Name "_"), Lit (Name "_")]) (aname "x")))
    inferType(Right (Forall (Cons ((TVar "t_2")) (Cons ((TVar "t_4")) (Nil))) (TypArr (TypVar  (TVar "t_2")) (TypArr (TypVar  (TVar "t_4")) (TypCon "Int")))))
  testInfer "ConsLit Binding 1" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "x"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Nil)) (TypArr (AD (TList (TypVar  (TVar "t_2")))) (TypVar  (TVar "t_2")))))
  testInfer "ConsLit Binding 2" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "xs"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Nil)) (TypArr (AD (TList (TypVar  (TVar "t_2")))) (TypVar  (TVar "t_2")))))
  testInfer "ConsLit Binding 3" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "xss"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Nil)) (TypArr (AD (TList (TypVar  (TVar "t_2")))) (AD (TList (TypVar  (TVar "t_2")))))))
  testInfer "Binding Tuple 1" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])]) (aname "a"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Cons ((TVar "t_3")) (Nil))) (TypArr (AD (TTuple $ Cons ((TypVar  (TVar "t_2"))) (Cons ((TypVar  (TVar "t_3"))) (Nil)))) (TypVar  (TVar "t_2")))))
  testInfer "Binding Tuple 2" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])]) (aname "b"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Cons ((TVar "t_3")) (Nil))) (TypArr (AD (TTuple (Cons ((TypVar  (TVar "t_2"))) (Cons ((TypVar  (TVar "t_3"))) (Nil))))) (TypVar  (TVar "t_3")))))
  testInfer "Binding Tuple 3" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c"])]) (App (aname "a") (toList [aname "b", aname "c"])))
    inferDef (Right (Forall (Cons ((TVar "t_3")) (Cons ((TVar "t_4")) (Cons ((TVar "t_5")) (Nil)))) (TypArr (AD (TTuple (Cons ((TypArr (TypVar  (TVar "t_3")) (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_5"))))) (Cons ((TypVar  (TVar "t_3"))) (Cons ((TypVar  (TVar "t_4"))) (Nil)))))) (TypVar  (TVar "t_5")))))
  testInfer "ListLit Binding" (Def "list" (toList [ListLit (toList [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c"])]) (App (aname "a") (toList [aname "b", aname "c"])))
    inferDef (Left ((InfiniteType (TVar "t_3") (TypArr (TypVar  (TVar "t_3")) (TypVar  (TVar "t_6"))))))
  testInfer "NTupleLit Binding LetExp"  (LetExpr (NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])) (NTuple (toList [(Lambda (toList [Lit $ Name "f"]) (aname "f")), (Atom $ Char "Hello")])) (App (aname "a") (toList [aname "b"])))
    inferType (Right (Forall (Nil) (TypCon "Char")))
  testInfer "Lambda App" (App (Lambda (Cons (Lit (Name "f")) (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "a")) (Cons (Atom (Name "b")) (Nil))))) (Cons (PrefixOp Add) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))))
    inferType (Right (Forall (Nil) (TypCon "Int")))

  testInfer "zipWith - Group" (toList [Def "zipWith" (toList [Lit $ Name "f", ConsLit (Lit $ Name "x") (Lit $ Name "xs"), ConsLit (Lit $ Name "y") (Lit $ Name "ys")])
      (App (PrefixOp Colon) (toList [App (aname "f") (toList [aname "x",aname "y"]), App (aname "zipWith") (toList [aname "f",aname"xs",aname "ys"])])),
      Def "zipWith" (toList [Lit $ Name "_",ListLit Nil,Lit $ Name "_"]) (List Nil),
      Def "zipWith" (toList [Lit $ Name "_",Lit $ Name "_",ListLit Nil]) (List Nil)])
    inferGroup (Right (Forall (Cons ((TVar "t_23")) (Cons ((TVar "t_33")) (Cons ((TVar "t_34")) (Nil)))) (TypArr (TypArr (TypVar  (TVar "t_23")) (TypArr (TypVar  (TVar "t_33")) (TypVar  (TVar "t_34")))) (TypArr (AD (TList (TypVar  (TVar "t_23")))) (TypArr (AD (TList (TypVar  (TVar "t_33")))) (AD (TList (TypVar  (TVar "t_34")))))))))

  testInfer "real foldr - Group" (toList [(Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ListLit (Nil)) (Nil)))) (Atom (Name "ini"))),
      (Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "x")) (Cons (App (Atom (Name "foldr")) (Cons (Atom (Name "f")) (Cons (Atom (Name "ini")) (Cons (Atom (Name "xs")) (Nil))))) (Nil)))))])
    inferGroup ((Right (Forall ((Cons ((TVar "t_4")) (Cons ((TVar "t_7")) Nil))) (TypArr (TypArr (TypVar  (TVar "t_7")) (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_4")))) (TypArr (TypVar  (TVar "t_4")) (TypArr (AD (TList (TypVar  (TVar "t_7")))) (TypVar  (TVar "t_4"))))))))

  testInfer "scanl - Group" (toList [Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ListLit (Nil)) (Nil)))) (List (Cons (Atom (Name "b")) (Nil))),
                                     Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (Binary Colon (Atom (Name "b")) (App (Atom (Name "scanl")) (Cons (Atom (Name "f")) (Cons (App (Atom (Name "f")) (Cons (Atom (Name "b")) (Cons (Atom (Name "x")) (Nil)))) (Cons (Atom (Name "xs")) (Nil))))))])
          inferGroup (Right (Forall (Cons ((TVar "t_39")) (Cons ((TVar "t_48")) (Nil))) (TypArr (TypArr (TypVar  (TVar "t_48")) (TypArr (TypVar  (TVar "t_39")) (TypVar  (TVar "t_48")))) (TypArr (TypVar  (TVar "t_48")) (TypArr (AD (TList (TypVar  (TVar "t_39")))) (AD (TList (TypVar  (TVar "t_48")))))))))

  testProgramm "Prelude with exp" Test.Parser.parsedPrelude
    ((App (Atom (Name "sum")) (Cons (App (Atom (Name "map")) (Cons (SectR Power (Atom (AInt 2))) (Cons (List (Cons (Atom (AInt 1)) (Cons (Atom (AInt 2)) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))))) (Nil)))) (Nil))))
    (Right (Forall (Nil) (TypCon "Int")))

module Test.TypeChecker where

import AST
import TypeChecker
import Parser

import Prelude hiding (apply,compose)
import Data.Either
import Data.List
import Data.Tuple
import Data.Map as Map
import Data.Maybe
import Data.Foldable

import Text.Parsing.Parser

import Control.Monad.Eff
import Control.Monad.Eff.Console

import Control.Monad.Except.Trans
import Control.Monad.State

testInfer:: forall a  eff. String -> a -> (TypeEnv -> a -> Infer (Tuple Subst Type))
 -> Either TypeError Scheme -> Eff (console :: CONSOLE | eff ) Unit
testInfer name input f expected
  = test name  expected $ runInfer $ f emptyTyenv input

testProgramm:: forall eff. String -> List Definition -> Expr
 -> Either TypeError Scheme -> Eff (console :: CONSOLE | eff ) Unit
testProgramm name defs exp expected
 = test name expected $ typeProgramn defs exp

-- test  name -> expected -> actuall -> Eff ...
test:: forall eff. String -> Either TypeError Scheme -> Either TypeError Scheme
 -> Eff (console :: CONSOLE | eff ) Unit
test name expected actuall = if eqTypErrScheme expected actuall
  then log $ "Typing success ("  ++ name ++ ")"
  else log $ "\n \n Typing fail (" ++ name ++ ") :  expected result: \n"
    ++ show expected ++ "\n actuall result: \n" ++ show actuall ++ "\n \n"
     ++ "Pretty Print expected: \n" ++ prettyPrint expected
      ++ "\n Pretty Print actuall: \n" ++ prettyPrint actuall ++ "\n \n"

eqTypErrScheme:: Either TypeError Scheme -> Either TypeError Scheme -> Boolean
eqTypErrScheme (Left a) (Left a') = (a == a')
eqTypErrScheme (Right a) (Right a') = eqScheme a a'
eqTypErrScheme _ _ = false

aint :: Int -> Expr
aint i = Atom $ AInt i

aname :: String -> Expr
aname s = Atom $ Name s

tvar :: String -> Type
tvar s = TypVar $ TVar s

out::forall eff. String -> Eff (console :: CONSOLE | eff ) Unit
out s = log s

parseExp:: String -> Either ParseError Expr
parseExp exp = runParser exp expression

parseDef:: String -> Either ParseError Definition
parseDef def = runParser def definition

typeStr:: String -> Either TypeError Scheme
typeStr expS = case runParser expS expression of
  Right exp -> runInfer $ inferType emptyTyenv exp
  Left _ -> Left $ UnknownError "Parse Error"

typeStrPre:: String -> Either TypeError Scheme
typeStrPre expS = case runParser expS expression of
  Right exp -> typeProgramn Test.Parser.parsedPrelude exp
  Left _ -> Left $ UnknownError "Parse Error"

typeExp:: Expr -> Either TypeError Scheme
typeExp exp = runInfer $ inferType emptyTyenv exp

typeDef:: Definition -> Either TypeError Scheme
typeDef def = runInfer $ inferDef emptyTyenv def

prettyPrint:: Either TypeError Scheme -> String
prettyPrint a@(Left _) = show a
prettyPrint (Right (Forall _ t)) = prettyPrintType t

printTypeExp::forall eff. Expr -> Eff (console :: CONSOLE | eff ) Unit
printTypeExp e = out $ prettyPrint $ typeExp e

printTypeStr::forall eff. String -> Eff (console :: CONSOLE | eff ) Unit
printTypeStr s = out $ prettyPrint $ typeStr s

-- default 1
d1 = Right (Forall Nil $ tvar "a")

runTests :: forall eff. Eff (console :: CONSOLE | eff) Unit
runTests = do
  log "Running Typing Tests"

  testInfer "SectL" (SectL (aint 3) Power)
    inferType(Right (Forall Nil $ TypArr (TypCon "Int") (TypCon "Int")))
  testInfer "SectR" (SectR Power (aint 3))
    inferType(Right (Forall (Nil) (TypArr (TypCon "Int") (TypCon "Int"))))
  testInfer "Lambda1" (Lambda (toList $ [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c",Lit $ Name "d"]) (App (aname "a") (toList [aname "b", aname "c", aname "d"])))
    inferType(Right (Forall (toList [TVar "b",TVar "c", TVar "d", TVar "e"]) (TypArr (TypArr (tvar "b") (TypArr (tvar "c") (TypArr (tvar "d") (tvar "e")))) (TypArr ( tvar "b")  ((TypArr (tvar "c") (TypArr (tvar "d") (tvar "e"))))))))
  testInfer "Lambda2" (Lambda (toList [Lit $ Name "a", Lit $ Name "b"]) (App (aname "a") (toList [aname "b"])))
    inferType(Right (Forall (Cons ((TVar "t_3")) (Cons ((TVar "t_4")) (Nil))) (TypArr (TypArr (TypVar  (TVar "t_3")) (TypVar  (TVar "t_4"))) (TypArr (TypVar  (TVar "t_3")) (TypVar  (TVar "t_4"))))))
  testInfer "List1" (List (toList [aint 1, aint 2, aint 3, aint 4, aint 5])) inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "List2" (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
    inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "List3" (List $ toList [PrefixOp Add, aint 4])
    inferType(Left ((UnificationFail (TypCon "Int") (TypArr (TypCon "Int") (TypArr (TypCon "Int") (TypCon "Int"))))))
  testInfer "Nil List" (List Nil)
    inferType  (Right (Forall (Cons ((TVar "t_0")) (Nil)) (AD (TList (TypVar  (TVar "t_0"))))))
  testInfer "Append" (Binary Append
    (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
    (List Nil))
    inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "Colon" (Binary Colon (aint 3) (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4),Atom $ Char "Hallo"]))
    inferType(Left ((UnificationFail (TypCon "Char") (TypCon "Int"))))
  testInfer "NTuple" (NTuple (toList [Binary Add (aint 1) (aint 2), aint 3]))
    inferType(Right (Forall (Nil) (AD (TTuple (Cons ((TypCon "Int")) (Cons ((TypCon "Int")) (Nil)))))))
  testInfer "SectR Colon" (SectR Colon $ List $ toList [aint 3])
    inferType(Right (Forall (Nil) (TypArr (TypCon "Int") (AD (TList (TypCon "Int"))))))
  testInfer "Def ~map" (Def "map" (toList [Lit $ Name "f", Lit $ Name "xs"]) (App (aname "map") (toList [aname "f",aname"xs"])))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Cons ((TVar "t_4")) (Cons ((TVar "t_5")) (Nil)))) (TypArr (TypVar  (TVar "t_2")) (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_5"))))))
  testInfer "Lambda Wildcard" (Lambda (toList [Lit (Name "_"), Lit (Name "_")]) (aint 5))
    inferType(Right (Forall (Cons ((TVar "t_1")) (Cons ((TVar "t_3")) (Nil))) (TypArr (TypVar  (TVar "t_1")) (TypArr (TypVar  (TVar "t_3")) (TypCon "Int")))))
  testInfer "Lambda ConsBinding" (Lambda (toList [ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (aname "x"))
    inferType(Right (Forall (Cons ((TVar "t_2")) (Nil)) (TypArr (AD (TList (TypVar  (TVar "t_2")))) (TypVar  (TVar "t_2")))))
  testInfer "singel map" (Def "map" (toList [Lit $ Name "f", ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (App  (PrefixOp Colon) (toList [App (aname "f") $ toList [(aname"x")], App (aname "map") (toList [aname"f", aname"xs"])])))
    inferDef (Right (Forall (Cons ((TVar "t_11")) (Cons ((TVar "t_5")) (Nil))) (TypArr (TypArr (TypVar  (TVar "t_5")) (TypVar  (TVar "t_11"))) (TypArr (AD (TList (TypVar  (TVar "t_5")))) (AD (TList (TypVar  (TVar "t_11"))))))))
  testInfer "foldr" (Def "foldr" (toList [Lit $ Name "f", Lit $ Name "ini", ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (App (aname "f") (toList [aname "x",App (aname "foldr") (toList [aname "f", aname "ini" ,aname "xs"  ] )])))
    inferDef (Right (Forall (Cons ((TVar "t_5")) (Cons ((TVar "t_4")) (Cons ((TVar "t_7")) Nil))) (TypArr (TypArr (TypVar  (TVar "t_7")) (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_4")))) (TypArr (TypVar  (TVar "t_5")) (TypArr (AD (TList (TypVar  (TVar "t_7")))) (TypVar  (TVar "t_4")))))))
  testInfer "let Expr"  (LetExpr (Lit $ Name "x") (aint 3) (Lambda (toList [Lit (Name "_"), Lit (Name "_")]) (aname "x")))
    inferType(Right (Forall (Cons ((TVar "t_2")) (Cons ((TVar "t_4")) (Nil))) (TypArr (TypVar  (TVar "t_2")) (TypArr (TypVar  (TVar "t_4")) (TypCon "Int")))))
  testInfer "ConsLit Binding 1" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "x"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Nil)) (TypArr (AD (TList (TypVar  (TVar "t_2")))) (TypVar  (TVar "t_2")))))
  testInfer "ConsLit Binding 2" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "xs"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Nil)) (TypArr (AD (TList (TypVar  (TVar "t_2")))) (TypVar  (TVar "t_2")))))
  testInfer "ConsLit Binding 3" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "xss"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Nil)) (TypArr (AD (TList (TypVar  (TVar "t_2")))) (AD (TList (TypVar  (TVar "t_2")))))))
  testInfer "Binding Tuple 1" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])]) (aname "a"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Cons ((TVar "t_3")) (Nil))) (TypArr (AD (TTuple $ Cons ((TypVar  (TVar "t_2"))) (Cons ((TypVar  (TVar "t_3"))) (Nil)))) (TypVar  (TVar "t_2")))))
  testInfer "Binding Tuple 2" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])]) (aname "b"))
    inferDef (Right (Forall (Cons ((TVar "t_2")) (Cons ((TVar "t_3")) (Nil))) (TypArr (AD (TTuple (Cons ((TypVar  (TVar "t_2"))) (Cons ((TypVar  (TVar "t_3"))) (Nil))))) (TypVar  (TVar "t_3")))))
  testInfer "Binding Tuple 3" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c"])]) (App (aname "a") (toList [aname "b", aname "c"])))
    inferDef (Right (Forall (Cons ((TVar "t_3")) (Cons ((TVar "t_4")) (Cons ((TVar "t_5")) (Nil)))) (TypArr (AD (TTuple (Cons ((TypArr (TypVar  (TVar "t_3")) (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_5"))))) (Cons ((TypVar  (TVar "t_3"))) (Cons ((TypVar  (TVar "t_4"))) (Nil)))))) (TypVar  (TVar "t_5")))))
  testInfer "ListLit Binding" (Def "list" (toList [ListLit (toList [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c"])]) (App (aname "a") (toList [aname "b", aname "c"])))
    inferDef (Left ((InfiniteType (TVar "t_3") (TypArr (TypVar  (TVar "t_3")) (TypVar  (TVar "t_6"))))))
  testInfer "NTupleLit Binding LetExp"  (LetExpr (NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])) (NTuple (toList [(Lambda (toList [Lit $ Name "f"]) (aname "f")), (Atom $ Char "Hello")])) (App (aname "a") (toList [aname "b"])))
    inferType (Right (Forall (Nil) (TypCon "Char")))
  testInfer "Lambda App" (App (Lambda (Cons (Lit (Name "f")) (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "a")) (Cons (Atom (Name "b")) (Nil))))) (Cons (PrefixOp Add) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))))
    inferType (Right (Forall (Nil) (TypCon "Int")))

  testInfer "zipWith - Group" (toList [Def "zipWith" (toList [Lit $ Name "f", ConsLit (Lit $ Name "x") (Lit $ Name "xs"), ConsLit (Lit $ Name "y") (Lit $ Name "ys")])
      (App (PrefixOp Colon) (toList [App (aname "f") (toList [aname "x",aname "y"]), App (aname "zipWith") (toList [aname "f",aname"xs",aname "ys"])])),
      Def "zipWith" (toList [Lit $ Name "_",ListLit Nil,Lit $ Name "_"]) (List Nil),
      Def "zipWith" (toList [Lit $ Name "_",Lit $ Name "_",ListLit Nil]) (List Nil)])
    inferGroup (Right (Forall (Cons ((TVar "t_23")) (Cons ((TVar "t_33")) (Cons ((TVar "t_34")) (Nil)))) (TypArr (TypArr (TypVar  (TVar "t_23")) (TypArr (TypVar  (TVar "t_33")) (TypVar  (TVar "t_34")))) (TypArr (AD (TList (TypVar  (TVar "t_23")))) (TypArr (AD (TList (TypVar  (TVar "t_33")))) (AD (TList (TypVar  (TVar "t_34")))))))))

  testInfer "real foldr - Group" (toList [(Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ListLit (Nil)) (Nil)))) (Atom (Name "ini"))),
      (Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "x")) (Cons (App (Atom (Name "foldr")) (Cons (Atom (Name "f")) (Cons (Atom (Name "ini")) (Cons (Atom (Name "xs")) (Nil))))) (Nil)))))])
    inferGroup ((Right (Forall ((Cons ((TVar "t_4")) (Cons ((TVar "t_7")) Nil))) (TypArr (TypArr (TypVar  (TVar "t_7")) (TypArr (TypVar  (TVar "t_4")) (TypVar  (TVar "t_4")))) (TypArr (TypVar  (TVar "t_4")) (TypArr (AD (TList (TypVar  (TVar "t_7")))) (TypVar  (TVar "t_4"))))))))

  testInfer "scanl - Group" (toList [Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ListLit (Nil)) (Nil)))) (List (Cons (Atom (Name "b")) (Nil))),
                                     Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (Binary Colon (Atom (Name "b")) (App (Atom (Name "scanl")) (Cons (Atom (Name "f")) (Cons (App (Atom (Name "f")) (Cons (Atom (Name "b")) (Cons (Atom (Name "x")) (Nil)))) (Cons (Atom (Name "xs")) (Nil))))))])
          inferGroup (Right (Forall (Cons ((TVar "t_39")) (Cons ((TVar "t_48")) (Nil))) (TypArr (TypArr (TypVar  (TVar "t_48")) (TypArr (TypVar  (TVar "t_39")) (TypVar  (TVar "t_48")))) (TypArr (TypVar  (TVar "t_48")) (TypArr (AD (TList (TypVar  (TVar "t_39")))) (AD (TList (TypVar  (TVar "t_48")))))))))

  testProgramm "Prelude with exp" Test.Parser.parsedPrelude
    ((App (Atom (Name "sum")) (Cons (App (Atom (Name "map")) (Cons (SectR Power (Atom (AInt 2))) (Cons (List (Cons (Atom (AInt 1)) (Cons (Atom (AInt 2)) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))))) (Nil)))) (Nil))))
    (Right (Forall (Nil) (TypCon "Int")))


Improve initializer setup

Improve initializer setup

module Halogen.VirtualDOM.Driver
  ( Driver
  , runUI
  ) where

import Prelude

import Control.Applicative.Free (hoistAp, lowerAp)
import Control.Coroutine (await)
import Control.Coroutine.Stalling (($$?))
import Control.Coroutine.Stalling as SCR
import Control.Monad.Aff (Aff, runAff, forkAff)
import Control.Monad.Aff.AVar (AVar, AVAR, modifyVar, putVar, takeVar, makeVar')
import Control.Monad.Aff.Unsafe (unsafeCoerceAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error, throwException)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Free (foldFree)
import Control.Monad.Fork (fork)
import Control.Monad.Rec.Class (forever)
import Control.Monad.Trans.Class (lift)
import Control.Parallel (sequential, parallel)

import Data.Lazy (force)
import Data.List (List, (:), (\\))
import Data.List as L
import Data.Map as M
import Data.Traversable (for_, sequence)
import Data.Maybe (Maybe(..), maybe)

import DOM.HTML.Types (HTMLElement, htmlElementToNode)
import DOM.Node.Node (appendChild)

import Halogen.Component (Component, ComponentSlot, unComponent, unComponentSlot)
import Halogen.Data.OrdBox (OrdBox, unOrdBox)
import Halogen.VirtualDOM.Driver.State (DriverStateX, DriverState(..), unDriverStateX, initDriverState)
import Halogen.Effects (HalogenEffects)
import Halogen.HTML.Core (HTML)
import Halogen.VirtualDOM.Renderer (renderHTML)
import Halogen.VirtualDOM.Internal as V
import Halogen.Query.ChildQuery (ChildQuery, unChildQuery)
import Halogen.Query.EventSource (runEventSource)
import Halogen.Query.ForkF as FF
import Halogen.Query.HalogenM (HalogenM(..), HalogenF(..), HalogenAp(..))
import Halogen.Query.StateF (StateF(..))

-- | Type alias for driver functions generated by `runUI` - a driver takes an
-- | input of the query algebra (`f`) and returns an `Aff` that returns when
-- | query has been fulfilled.
type Driver f eff = f ~> Aff (HalogenEffects eff)

type DSL s f g eff p o = HalogenF s f g p o (Aff (HalogenEffects eff))

type LifecycleHandlers eff =
  { initializers :: List (Aff (HalogenEffects eff) Unit)
  , finalizers :: List (Aff (HalogenEffects eff) Unit)
  }

addInitializer
  :: forall g eff
   . AVar (LifecycleHandlers eff)
  -> DriverStateX g eff
  -> Aff (HalogenEffects eff) Unit
addInitializer var dsx =
  for_ (unDriverStateX (\st -> evalF st.selfRef <$> st.component.initializer) dsx) \i ->
    modifyVar (\lchs ->
      { initializers: i : lchs.initializers
      , finalizers: lchs.finalizers
      }) var

addFinalizer
  :: forall f eff
   . AVar (LifecycleHandlers eff)
  -> DriverStateX f eff
  -> Aff (HalogenEffects eff) Unit
addFinalizer var =
  unDriverStateX \st -> do
    for_ (evalF st.selfRef <$> st.component.finalizer) \f ->
      modifyVar (\lchs ->
        { initializers: lchs.initializers
        , finalizers: f : lchs.finalizers
        }) var
    for_ st.children (addFinalizer var <=< peekVar)

handleLifecycle
  :: forall eff r
   . (AVar (LifecycleHandlers eff) -> Aff (HalogenEffects eff) r)
  -> Aff (HalogenEffects eff) r
handleLifecycle f = do
  lchs <- makeVar' { initializers: L.Nil, finalizers: L.Nil }
  result <- f lchs
  { initializers, finalizers } <- peekVar lchs
  sequence $ L.reverse initializers
  sequence finalizers
  pure result

-- | This function is the main entry point for a Halogen based UI, taking a root
-- | component, initial state, and HTML element to attach the rendered component
-- | to.
-- |
-- | The returned "driver" function can be used to send actions and requests
-- | into the component hierarchy, allowing the outside world to communicate
-- | with the UI.
runUI
  :: forall f eff o
   . Component HTML f o (Aff (HalogenEffects eff))
  -> HTMLElement
  -> Aff (HalogenEffects eff) (Driver f eff)
runUI component element = _.driver <$> do
  fresh <- makeVar' 0
  handleLifecycle \lchs -> do
    var <- runComponent (const (pure unit)) fresh lchs component
    peekVar var >>= unDriverStateX \st -> do
      liftEff $ appendChild (htmlElementToNode st.node) (htmlElementToNode element)
      -- The record here is a hack around a skolem escape issue. If the typing
      -- rules for records change so this no longer works it may also be fixable
      -- with copious type annotations.
      pure { driver: evalF st.selfRef }

runComponent
  :: forall f eff o
   . (o -> Aff (HalogenEffects eff) Unit)
  -> AVar Int
  -> AVar (LifecycleHandlers eff)
  -> Component HTML f o (Aff (HalogenEffects eff))
  -> Aff (HalogenEffects eff) (AVar (DriverStateX f eff))
runComponent handler fresh lchs = unComponent \component -> do
  keyId <- peekVar fresh
  modifyVar (_ + 1) fresh
  var <- initDriverState component handler keyId fresh
  unDriverStateX (render lchs <<< _.selfRef) =<< peekVar var
  addInitializer lchs =<< peekVar var
  pure var

eval
  :: forall s f g eff p o
   . AVar (DriverState s f g eff p o)
  -> DSL s f g eff p o
  ~> Aff (HalogenEffects eff)
eval ref = case _ of
  State i -> do
    case i of
      Get k -> do
        DriverState { state } <- peekVar ref
        pure (k state)
      Modify f next -> do
        modifyVar (\(DriverState st) -> DriverState (st { state = f st.state })) ref
        handleLifecycle \lchs -> render lchs ref
        pure next
  Subscribe es next -> do
    let consumer = forever (lift <<< evalM ref =<< await)
    forkAff $ SCR.runStallingProcess (runEventSource es $$? consumer)
    pure next
  Lift aff ->
    aff
  Halt msg ->
    throwError (error msg)
  GetSlots k -> do
    DriverState { children } <- peekVar ref
    pure $ k $ map unOrdBox $ M.keys children
  CheckSlot p k -> do
    DriverState { mkOrdBox, children } <- peekVar ref
    pure $ k $ M.member (mkOrdBox p) children
  ChildQuery cq ->
    evalChildQuery ref cq
  Raise o a -> do
    DriverState { handler } <- peekVar ref
    handler o
    pure a
  Par (HalogenAp p) ->
    sequential $ lowerAp $ hoistAp (parallel <<< evalM ref) p
  Fork f ->
    FF.unFork (\(FF.ForkF fx k) →
      k <<< map unsafeCoerceAff <$> fork (evalM ref fx)) f

evalChildQuery
  :: forall s f g eff p o
   . AVar (DriverState s f g eff p o)
  -> ChildQuery g (Aff (HalogenEffects eff)) p
  ~> Aff (HalogenEffects eff)
evalChildQuery ref = unChildQuery \p k -> do
  DriverState st <- peekVar ref
  case M.lookup (st.mkOrdBox p) st.children of
    Just var -> do
      dsx <- peekVar var
      k (unDriverStateX (\ds q -> evalF ds.selfRef q) dsx)
    Nothing -> throwError (error "Slot lookup failed for child query")

evalF
  :: forall s f g eff p o
   . AVar (DriverState s f g eff p o)
  -> f
  ~> Aff (HalogenEffects eff)
evalF ref q = do
  DriverState st <- peekVar ref
  case st.component.eval q of
    HalogenM fx -> foldFree (eval ref) fx

evalM
  :: forall s f g eff p o
   . AVar (DriverState s f g eff p o)
  -> HalogenM s f g p o (Aff (HalogenEffects eff))
  ~> Aff (HalogenEffects eff)
evalM ref (HalogenM q) = foldFree (eval ref) q

render
  :: forall s f g eff p o
   . AVar (LifecycleHandlers eff)
  -> AVar (DriverState s f g eff p o)
  -> Aff (HalogenEffects eff) Unit
render lchs var = takeVar var >>= \(DriverState ds) -> do
  childrenVar <- makeVar' (M.empty :: M.Map (OrdBox p) (AVar (DriverStateX g eff)))
  let selfEval = evalF ds.selfRef
  vtree' <-
    renderHTML
      (handleAff <<< selfEval)
      (renderChild selfEval ds.fresh ds.mkOrdBox ds.children childrenVar lchs)
      (ds.component.render ds.state)
  node' <- liftEff $ V.patch (V.diff ds.vtree vtree') ds.node
  children <- takeVar childrenVar
  for_ (M.keys ds.children \\ M.keys children) \p ->
    for_ (M.lookup p ds.children) (addFinalizer lchs <=< peekVar)
  putVar var $
    DriverState
      { node: node'
      , vtree: vtree'
      , component: ds.component
      , state: ds.state
      , children
      , mkOrdBox: ds.mkOrdBox
      , selfRef: ds.selfRef
      , handler: ds.handler
      , keyId: ds.keyId
      , fresh: ds.fresh
      }

renderChild
  :: forall f g eff p
   . (f ~> Aff (HalogenEffects eff))
  -> AVar Int
  -> (p -> OrdBox p)
  -> M.Map (OrdBox p) (AVar (DriverStateX g eff))
  -> AVar (M.Map (OrdBox p) (AVar (DriverStateX g eff)))
  -> AVar (LifecycleHandlers eff)
  -> ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit)
  -> Aff (HalogenEffects eff) V.VTree
renderChild handler fresh mkOrdBox childrenIn childrenOut lchs =
  unComponentSlot \p ctor k -> do
    var <- case M.lookup (mkOrdBox p) childrenIn of
      Just existing -> pure existing
      Nothing -> runComponent (maybe (pure unit) handler <<< k) fresh lchs (force ctor)
    modifyVar (M.insert (mkOrdBox p) var) childrenOut
    pure <<< unDriverStateX (\st -> V.widget st.keyId st.node) =<< peekVar var

-- | TODO: we could do something more intelligent now this isn't baked into the
-- | virtual-dom rendering. Perhaps write to an avar when an error occurs...
-- | something other than a runtime exception anyway.
handleAff
  :: forall eff a
   . Aff (HalogenEffects eff) a
  -> Eff (HalogenEffects eff) Unit
handleAff = void <<< runAff throwException (const (pure unit))

peekVar :: forall eff a. AVar a -> Aff (avar :: AVAR | eff) a
peekVar v = do
  a <- takeVar v
  putVar v a
  pure a

module Halogen.VirtualDOM.Driver
  ( Driver
  , runUI
  ) where

import Prelude

import Control.Applicative.Free (hoistAp, lowerAp)
import Control.Coroutine (await)
import Control.Coroutine.Stalling (($$?))
import Control.Coroutine.Stalling as SCR
import Control.Monad.Aff (Aff, runAff, forkAff)
import Control.Monad.Aff.AVar (AVar, modifyVar, putVar, takeVar, makeVar', peekVar)
import Control.Monad.Aff.Unsafe (unsafeCoerceAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error, throwException)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Free (foldFree)
import Control.Monad.Fork (fork)
import Control.Monad.Rec.Class (forever)
import Control.Monad.Trans.Class (lift)
import Control.Parallel (sequential, parallel)

import Data.Lazy (force)
import Data.List (List, (:), (\\))
import Data.List as L
import Data.Map as M
import Data.Traversable (for_, sequence)
import Data.Maybe (Maybe(..), maybe)

import DOM.HTML.Types (HTMLElement, htmlElementToNode)
import DOM.Node.Node (appendChild)

import Halogen.Component (Component, ComponentSlot, unComponent, unComponentSlot)
import Halogen.Data.OrdBox (OrdBox, unOrdBox)
import Halogen.VirtualDOM.Driver.State (DriverStateX, DriverState(..), unDriverStateX, initDriverState)
import Halogen.Effects (HalogenEffects)
import Halogen.HTML.Core (HTML)
import Halogen.VirtualDOM.Renderer (renderHTML)
import Halogen.VirtualDOM.Internal as V
import Halogen.Query.ChildQuery (ChildQuery, unChildQuery)
import Halogen.Query.EventSource (runEventSource)
import Halogen.Query.ForkF as FF
import Halogen.Query.HalogenM (HalogenM(..), HalogenF(..), HalogenAp(..))
import Halogen.Query.StateF (StateF(..))

-- | Type alias for driver functions generated by `runUI` - a driver takes an
-- | input of the query algebra (`f`) and returns an `Aff` that returns when
-- | query has been fulfilled.
type Driver f eff = f ~> Aff (HalogenEffects eff)

type DSL s f g eff p o = HalogenF s f g p o (Aff (HalogenEffects eff))

type LifecycleHandlers eff =
  { initializers :: List (Aff (HalogenEffects eff) Unit)
  , finalizers :: List (Aff (HalogenEffects eff) Unit)
  }

addInitializer
  :: forall g eff
   . AVar (LifecycleHandlers eff)
  -> DriverStateX g eff
  -> Aff (HalogenEffects eff) Unit
addInitializer var dsx =
  for_ (unDriverStateX (\st -> evalF st.selfRef <$> st.component.initializer) dsx) \i ->
    modifyVar (\lchs -> { initializers: i : lchs.initializers, finalizers: lchs.finalizers }) var

addFinalizer
  :: forall f eff
   . AVar (LifecycleHandlers eff)
  -> DriverStateX f eff
  -> Aff (HalogenEffects eff) Unit
addFinalizer var =
  unDriverStateX \st -> do
    for_ (evalF st.selfRef <$> st.component.finalizer) \f ->
      modifyVar (\lchs -> { initializers: lchs.initializers, finalizers: f : lchs.finalizers }) var
    for_ st.children (addFinalizer var <=< peekVar)

handleLifecycle
  :: forall eff r
   . (AVar (LifecycleHandlers eff) -> Aff (HalogenEffects eff) r)
  -> Aff (HalogenEffects eff) r
handleLifecycle f = do
  lchs <- makeVar' { initializers: L.Nil, finalizers: L.Nil }
  result <- f lchs
  { initializers, finalizers } <- peekVar lchs
  sequence $ L.reverse initializers
  sequence finalizers
  pure result

-- | This function is the main entry point for a Halogen based UI, taking a root
-- | component, initial state, and HTML element to attach the rendered component
-- | to.
-- |
-- | The returned "driver" function can be used to send actions and requests
-- | into the component hierarchy, allowing the outside world to communicate
-- | with the UI.
runUI
  :: forall f eff o
   . Component HTML f o (Aff (HalogenEffects eff))
  -> HTMLElement
  -> Aff (HalogenEffects eff) (Driver f eff)
runUI component element = _.driver <$> do
  fresh <- makeVar' 0
  handleLifecycle \lchs -> do
    var <- runComponent (const (pure unit)) fresh lchs component
    dsx <- peekVar var
    addInitializer lchs dsx
    unDriverStateX (\st -> do
      liftEff $ appendChild (htmlElementToNode st.node) (htmlElementToNode element)
      -- The record here is a hack around a skolem escape issue. If the typing
      -- rules for records change so this no longer works it may also be fixable
      -- with copious type annotations.
      pure { driver: evalF st.selfRef }) dsx

runComponent
  :: forall f eff o
   . (o -> Aff (HalogenEffects eff) Unit)
  -> AVar Int
  -> AVar (LifecycleHandlers eff)
  -> Component HTML f o (Aff (HalogenEffects eff))
  -> Aff (HalogenEffects eff) (AVar (DriverStateX f eff))
runComponent handler fresh lchs = unComponent \component -> do
  keyId <- peekVar fresh
  modifyVar (_ + 1) fresh
  var <- initDriverState component handler keyId fresh
  unDriverStateX (render lchs <<< _.selfRef) =<< peekVar var
  pure var

eval
  :: forall s f g eff p o
   . AVar (DriverState s f g eff p o)
  -> DSL s f g eff p o
  ~> Aff (HalogenEffects eff)
eval ref = case _ of
  State i -> do
    case i of
      Get k -> do
        DriverState { state } <- peekVar ref
        pure (k state)
      Modify f next -> do
        modifyVar (\(DriverState st) -> DriverState (st { state = f st.state })) ref
        handleLifecycle \lchs -> render lchs ref
        pure next
  Subscribe es next -> do
    let consumer = forever (lift <<< evalM ref =<< await)
    forkAff $ SCR.runStallingProcess (runEventSource es $$? consumer)
    pure next
  Lift aff ->
    aff
  Halt msg ->
    throwError (error msg)
  GetSlots k -> do
    DriverState { children } <- peekVar ref
    pure $ k $ map unOrdBox $ M.keys children
  CheckSlot p k -> do
    DriverState { mkOrdBox, children } <- peekVar ref
    pure $ k $ M.member (mkOrdBox p) children
  ChildQuery cq ->
    evalChildQuery ref cq
  Raise o a -> do
    DriverState { handler } <- peekVar ref
    handler o
    pure a
  Par (HalogenAp p) ->
    sequential $ lowerAp $ hoistAp (parallel <<< evalM ref) p
  Fork f ->
    FF.unFork (\(FF.ForkF fx k) →
      k <<< map unsafeCoerceAff <$> fork (evalM ref fx)) f

evalChildQuery
  :: forall s f g eff p o
   . AVar (DriverState s f g eff p o)
  -> ChildQuery g (Aff (HalogenEffects eff)) p
  ~> Aff (HalogenEffects eff)
evalChildQuery ref = unChildQuery \p k -> do
  DriverState st <- peekVar ref
  case M.lookup (st.mkOrdBox p) st.children of
    Just var -> do
      dsx <- peekVar var
      k (unDriverStateX (\ds q -> evalF ds.selfRef q) dsx)
    Nothing -> throwError (error "Slot lookup failed for child query")

evalF
  :: forall s f g eff p o
   . AVar (DriverState s f g eff p o)
  -> f
  ~> Aff (HalogenEffects eff)
evalF ref q = do
  DriverState st <- peekVar ref
  case st.component.eval q of
    HalogenM fx -> foldFree (eval ref) fx

evalM
  :: forall s f g eff p o
   . AVar (DriverState s f g eff p o)
  -> HalogenM s f g p o (Aff (HalogenEffects eff))
  ~> Aff (HalogenEffects eff)
evalM ref (HalogenM q) = foldFree (eval ref) q

render
  :: forall s f g eff p o
   . AVar (LifecycleHandlers eff)
  -> AVar (DriverState s f g eff p o)
  -> Aff (HalogenEffects eff) Unit
render lchs var = takeVar var >>= \(DriverState ds) -> do
  childrenVar <- makeVar' (M.empty :: M.Map (OrdBox p) (AVar (DriverStateX g eff)))
  let selfEval = evalF ds.selfRef
  vtree' <-
    renderHTML
      (handleAff <<< selfEval)
      (renderChild selfEval ds.fresh ds.mkOrdBox ds.children childrenVar lchs)
      (ds.component.render ds.state)
  node' <- liftEff $ V.patch (V.diff ds.vtree vtree') ds.node
  children <- takeVar childrenVar
  let
    newSlots = M.keys children
    oldSlots = M.keys ds.children
    removed = oldSlots \\ newSlots
    added = newSlots \\ oldSlots
  for_ added \p ->
    for_ (M.lookup p children) (addInitializer lchs <=< peekVar)
  for_ removed \p ->
    for_ (M.lookup p ds.children) (addFinalizer lchs <=< peekVar)
  putVar var $
    DriverState
      { node: node'
      , vtree: vtree'
      , component: ds.component
      , state: ds.state
      , children
      , mkOrdBox: ds.mkOrdBox
      , selfRef: ds.selfRef
      , handler: ds.handler
      , keyId: ds.keyId
      , fresh: ds.fresh
      }

renderChild
  :: forall f g eff p
   . (f ~> Aff (HalogenEffects eff))
  -> AVar Int
  -> (p -> OrdBox p)
  -> M.Map (OrdBox p) (AVar (DriverStateX g eff))
  -> AVar (M.Map (OrdBox p) (AVar (DriverStateX g eff)))
  -> AVar (LifecycleHandlers eff)
  -> ComponentSlot HTML g (Aff (HalogenEffects eff)) p (f Unit)
  -> Aff (HalogenEffects eff) V.VTree
renderChild handler fresh mkOrdBox childrenIn childrenOut lchs =
  unComponentSlot \p ctor k -> do
    var <- case M.lookup (mkOrdBox p) childrenIn of
      Just existing -> pure existing
      Nothing -> runComponent (maybe (pure unit) handler <<< k) fresh lchs (force ctor)
    modifyVar (M.insert (mkOrdBox p) var) childrenOut
    pure <<< unDriverStateX (\st -> V.widget st.keyId st.node) =<< peekVar var

-- | TODO: we could do something more intelligent now this isn't baked into the
-- | virtual-dom rendering. Perhaps write to an avar when an error occurs...
-- | something other than a runtime exception anyway.
handleAff
  :: forall eff a
   . Aff (HalogenEffects eff) a
  -> Eff (HalogenEffects eff) Unit
handleAff = void <<< runAff throwException (const (pure unit))


Add ComonadAsk

Add ComonadAsk

-- | This module defines the `ComonadEnv` type class and its instances.

module Control.Comonad.Env.Class where

import Control.Comonad (class Comonad)
import Control.Comonad.Env.Trans (EnvT(..))

import Data.Tuple (Tuple(..), fst)

-- | The `ComonadEnv` type class represents those comonads which support a
-- | global environment that can be provided via the `ask` function.
-- |
-- | An implementation is provided for `EnvT`.
class Comonad w <= ComonadAsk e w | w -> e where
  ask :: forall a. w a -> e

-- | Get a value which depends on the environment.
asks :: forall e1 e2 w. ComonadEnv e1 w => (e1 -> e2) -> w e1 -> e2
asks f x = f (ask x)

-- | The `ComonadEnv` type class extends `ComonadAsk` with a function
-- | `local f x` that allows the value of the local context to be modified for
-- | the duration of the execution of action `x`.
-- |
-- | An implementation is provided for `EnvT`.
-- |
-- | Laws:
-- |
-- | - `ask (local f x) = f (ask x)`
-- | - `extract (local _ x) = extract a`
-- | - `extend g (local f x) = extend (g <<< local f) x`
class ComonadAsk e w <= ComonadEnv e w | w -> e where
  local :: forall a. (e -> e) -> w a -> w a

instance comonadAskTuple :: ComonadAsk e (Tuple e) where
  ask = fst

instance comonadEnvTuple :: ComonadEnv e (Tuple e) where
  local f (Tuple x y) = Tuple (f x) y

instance comonadAskEnvT :: Comonad w => ComonadAsk e (EnvT e w) where
  ask (EnvT x) = fst x

instance comonadEnvEnvT :: Comonad w => ComonadEnv e (EnvT e w) where
  local f (EnvT x) = EnvT case x of
    Tuple x y -> Tuple (f x) y

-- | This module defines the `ComonadEnv` type class and its instances.

module Control.Comonad.Env.Class where

import Control.Comonad (class Comonad)
import Control.Comonad.Env.Trans (EnvT(..))

import Data.Tuple (Tuple(..), fst)

-- | The `ComonadEnv` type class represents those monads which support a global environment via
-- | `ask` and `local`.
-- |
-- | - `ask` reads the current environment from the context.
-- | - `local` changes the value of the global environment.
-- |
-- | An implementation is provided for `EnvT`.
-- |
-- | Laws:
-- |
-- | - `ask (local f x) = f (ask x)`
-- | - `extract (local _ x) = extract a`
-- | - `extend g (local f x) = extend (g <<< local f) x`
class Comonad w <= ComonadEnv e w | w -> e where
  ask :: forall a. w a -> e
  local :: forall a. (e -> e) -> w a -> w a

-- | Get a value which depends on the environment.
asks :: forall e1 e2 w. ComonadEnv e1 w => (e1 -> e2) -> w e1 -> e2
asks f x = f (ask x)

instance comonadEnvTuple :: ComonadEnv e (Tuple e) where
  ask = fst
  local f (Tuple x y) = Tuple (f x) y

instance comonadEnvEnvT :: Comonad w => ComonadEnv e (EnvT e w) where
  ask (EnvT x) = fst x
  local f (EnvT x) = EnvT case x of
    Tuple x y -> Tuple (f x) y