Cosmetics

Cosmetics

module Main where

import Pux.Routing.Bob.Component as Pux.Routing.Bob.Component
import Routing.Bob as Routing.Bob
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import DOM (DOM)
import Data.Bifunctor (class Bifunctor, bimap)
import Data.Generic (class Generic)
import Data.Maybe (Maybe(Just, Nothing))
import Partial.Unsafe (unsafePartial)
import Pux (renderToDOM, start, noEffects, Update)
import Pux.Html (Html, div, ul, text, br, a, li)
import Pux.Html.Attributes (href, className)
import Pux.Html.Elements (p)
import Pux.Html.Events (onClick)
import Pux.Routing.Bob (RoutingAction(RoutingError, Routed), setInitialRoute)
import Pux.Routing.Bob.Component (View, Action(RawAction, RoutingAction), link', sampleUrl)
import Routing.Bob (Router)
import Signal.Channel (CHANNEL)
import Type.Proxy (Proxy(Proxy))
import Prelude hiding (div)

-- Main window component

data MainWindowRoute
  = Profile
  | Inbox
  | Settings
derive instance genericMainWindowRoute :: Generic MainWindowRoute
derive instance eqMainWindowRoute :: Eq MainWindowRoute

data MainWindowRawAction
  = ProfileClick
  | InboxClick
  | SettingsClick

type MainWindowState =
  { activeTab :: MainWindowRoute
  -- clicks counters - just to include other state and actions
  , profileCounter :: Int
  , inboxCounter :: Int
  , settingsCounter :: Int
  }

type MainWindowAction = Action MainWindowRoute MainWindowRawAction

mainWindowUpdate :: (Router MainWindowRoute) -> Update MainWindowState MainWindowAction (dom :: DOM)
mainWindowUpdate _ (RawAction ProfileClick) state =
  noEffects $ state { profileCounter = state.profileCounter + 1 }
mainWindowUpdate _ (RawAction InboxClick) state =
  noEffects $ state { inboxCounter = state.inboxCounter + 1 }
mainWindowUpdate _ (RawAction SettingsClick) state =
  noEffects $ state { settingsCounter = state.settingsCounter + 1 }
mainWindowUpdate _ (RoutingAction (Routed r)) state =
  noEffects $ state { activeTab = r }
mainWindowUpdate _ (RoutingAction (RoutingError _)) state = noEffects state
mainWindowUpdate router (RoutingAction a) state =
  Pux.Routing.Bob.Component.update router a state

mainWindowView :: View MainWindowState MainWindowRoute MainWindowRawAction
mainWindowView router mapAction state =
  div []
    [ ul []
        [ tabHeader Profile "profile"
        , tabHeader Inbox "inbox"
        , tabHeader Settings "settings"
        ]
    , div []
        case state.activeTab of
          Profile -> [ tabBody (mapAction (RawAction ProfileClick)) state.profileCounter "profile" ]
          Inbox -> [ tabBody (mapAction (RawAction InboxClick)) state.inboxCounter "inbox" ]
          Settings -> [ tabBody (mapAction (RawAction SettingsClick)) state.settingsCounter "settings" ]
    ]
 where
  link'' = link' mapAction router
  tabHeader route label =
    li
      (if state.activeTab == route
        then [className "active"]
        else [])
      [ link''
          route
          []
          [ text label ]
      ]
  tabBody action counter label =
    a [ href "#", onClick $ const action]
      [ text (label <> " action"), br [] [], text <<< show $ counter ]

-- Sidebar component

data SideBarRoute
  = Expanded
  | Minimized
derive instance genericSideBarRoute :: Generic SideBarRoute
derive instance eqSideBarRoute :: Eq SideBarRoute

type SideBarState = SideBarRoute

type SideBarRawAction = Unit

type SideBarAction = Action SideBarRoute SideBarRawAction

-- | This is how you can cheat to cleanup your subcomponent
-- | `update` API a bit and make subcomponent more self-contained.
-- | I've left this example here, side by side with default,
-- | safe implementation of `Router MainWidowRoute` construction,
-- | just for comparison.
sideBarRouter :: Router SideBarRoute
sideBarRouter =
  unsafePartial
    (case (Routing.Bob.router (Proxy :: Proxy SideBarRoute)) of Just r -> r)

sideBarUpdate :: forall eff. Update SideBarState SideBarAction (dom :: DOM | eff)
sideBarUpdate (RawAction _) state = noEffects state
-- current state is just given route, because State = SideBarRoute ;-)
sideBarUpdate (RoutingAction (Routed r)) _ = noEffects r
sideBarUpdate (RoutingAction (RoutingError _)) state = noEffects state
sideBarUpdate (RoutingAction a) state =
  Pux.Routing.Bob.Component.update sideBarRouter a state

sideBarView :: View SideBarState SideBarRoute SideBarRawAction
sideBarView router mapAction state =
  p []
    if state == Expanded
      then
        [ text "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat."
        , br [] []
        , link'' Minimized [] [ text "hide"]
        ]
      else
        [ text "Lorem ipsum..."
        , link'' Expanded [] [ text "show more" ]
        ]
 where
  link'' = link' mapAction router

-- Application

data AppRoute =
  AppRoute MainWindowRoute SideBarRoute
derive instance genericAppRoute :: Generic AppRoute

getMainWindowRoute :: AppRoute -> MainWindowRoute
getMainWindowRoute (AppRoute m _) = m

getSideBarRoute :: AppRoute -> SideBarRoute
getSideBarRoute (AppRoute _ s) = s

type AppState =
  { mainWindowState :: MainWindowState
  , sideBarState :: SideBarState
  }

data AppRawAction
  = MainWindowRawAction MainWindowRawAction
  | SideBarRawAction SideBarRawAction

type AppAction = Action AppRoute AppRawAction

-- To be honest I'm using: unsafePartial (router RouteType)
-- for Router generation when it's tested, because route type
-- doesn't change over runtime. This simplifies API
-- a lot - you can avoid all this routers passing clutter...
appUpdate :: (Router MainWindowRoute) ->
             (Router AppRoute) ->
             Update AppState AppAction (dom :: DOM)
appUpdate mr _ (RawAction (MainWindowRawAction a)) state =
  let r = mainWindowUpdate mr (RawAction a) state.mainWindowState
  in
    { state: state { mainWindowState = r.state }
    , effects: (bimap mapRoute MainWindowRawAction <$> _) <$> r.effects
    }
 where
  mapRoute mainWindowRoute = AppRoute mainWindowRoute state.sideBarState
-- this branch could be avoided as sideBarUpdate doesn't perform anything
appUpdate _ _ (RawAction (SideBarRawAction a)) state =
  let r = sideBarUpdate (RawAction a) state.sideBarState
  in
    { state: state { sideBarState = r.state }
    , effects: (bimap mapRoute SideBarRawAction <$> _) <$> r.effects
    }
 where
  mapRoute sideBarRoute = AppRoute state.mainWindowState.activeTab sideBarRoute
appUpdate mRouter
          _
          (RoutingAction (Routed (AppRoute mainWindowRoute sideBarRoute)))
          state =
  let sr = sideBarUpdate (RoutingAction (Routed sideBarRoute)) state.sideBarState
      mr = mainWindowUpdate mRouter (RoutingAction (Routed mainWindowRoute)) state.mainWindowState
      mapSideBarRoute sideBarRoute = AppRoute mr.state.activeTab sideBarRoute
      mapMainWindowRoute mainWindowRoute = AppRoute mainWindowRoute sr.state
  in
    { state: state { sideBarState = sr.state
                   , mainWindowState = mr.state
                   }
    , effects: ((bimap mapSideBarRoute SideBarRawAction <$> _) <$> sr.effects) <>
               ((bimap mapMainWindowRoute MainWindowRawAction <$> _) <$> mr.effects)
    }
appUpdate _ _ (RoutingAction (RoutingError _)) state = noEffects state
appUpdate _ aRouter (RoutingAction a) state =
  Pux.Routing.Bob.Component.update aRouter a state

appView :: Router AppRoute -> AppState -> Html AppAction
appView router state =
  div []
    [ mainWindowView
        router
        (bimap (\r -> AppRoute r state.sideBarState) MainWindowRawAction)
        state.mainWindowState
    , sideBarView router mapSideBarAction state.sideBarState
    ]
 where
  -- Helper with type signature, which is necessary in this case
  mapSideBarAction :: forall b. (Bifunctor b) =>
                      b SideBarRoute SideBarRawAction ->
                      b AppRoute AppRawAction
  mapSideBarAction = bimap (\r -> AppRoute state.mainWindowState.activeTab r) SideBarRawAction

main :: Eff ( dom :: DOM , channel :: CHANNEL , err :: EXCEPTION ) Unit
main = do
  sampleUrlSignal <- sampleUrl
  let
    routers = do
      mainWindowRouter <- Routing.Bob.router (Proxy :: Proxy MainWindowRoute)
      appRouter <- Routing.Bob.router (Proxy :: Proxy AppRoute)
      pure
        { appRouter: appRouter
        , mainWindowRouter: mainWindowRouter
        }

  case routers of
    Just rs ->
      do
        currRoute <- setInitialRoute rs.appRouter (AppRoute Profile Minimized)
        let
          view = appView rs.appRouter
          update = appUpdate rs.mainWindowRouter rs.appRouter
          initialState =
            { mainWindowState:
              { activeTab: getMainWindowRoute currRoute
              , profileCounter: 0
              , inboxCounter: 0
              , settingsCounter: 0
              }
            , sideBarState: getSideBarRoute currRoute
            }
          config =
            { update: update
            , view: view
            , inputs: [ sampleUrlSignal ]
            , initialState: initialState
            }
        app <- start config
        renderToDOM "#app" app.html
    Nothing -> pure unit

module Main where

import Pux.Routing.Bob.Component as Pux.Routing.Bob.Component
import Routing.Bob as Routing.Bob
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import DOM (DOM)
import Data.Bifunctor (class Bifunctor, bimap)
import Data.Generic (class Generic)
import Data.Maybe (Maybe(Just, Nothing))
import Partial.Unsafe (unsafePartial)
import Pux (renderToDOM, start, noEffects, Update)
import Pux.Html (Html, div, ul, text, br, a, li)
import Pux.Html.Attributes (href, className)
import Pux.Html.Elements (p)
import Pux.Html.Events (onClick)
import Pux.Routing.Bob (RoutingAction(RoutingError, Routed), setInitialRoute)
import Pux.Routing.Bob.Component (View, Action(RawAction, RoutingAction), link', sampleUrl)
import Routing.Bob (Router)
import Signal.Channel (CHANNEL)
import Type.Proxy (Proxy(Proxy))
import Prelude hiding (div)

-- Main window component

data MainWindowRoute
  = Profile
  | Inbox
  | Settings
derive instance genericMainWindowRoute :: Generic MainWindowRoute
derive instance eqMainWindowRoute :: Eq MainWindowRoute

data MainWindowRawAction
  = ProfileClick
  | InboxClick
  | SettingsClick

type MainWindowState =
  { activeTab :: MainWindowRoute
  -- clicks counters - just to include other state and actions
  , profileCounter :: Int
  , inboxCounter :: Int
  , settingsCounter :: Int
  }

type MainWindowAction = Action MainWindowRoute MainWindowRawAction

mainWindowUpdate :: (Router MainWindowRoute) -> Update MainWindowState MainWindowAction (dom :: DOM)
mainWindowUpdate _ (RawAction ProfileClick) state =
  noEffects $ state { profileCounter = state.profileCounter + 1 }
mainWindowUpdate _ (RawAction InboxClick) state =
  noEffects $ state { inboxCounter = state.inboxCounter + 1 }
mainWindowUpdate _ (RawAction SettingsClick) state =
  noEffects $ state { settingsCounter = state.settingsCounter + 1 }
mainWindowUpdate _ (RoutingAction (Routed r)) state =
  noEffects $ state { activeTab = r }
mainWindowUpdate _ (RoutingAction (RoutingError _)) state = noEffects state
mainWindowUpdate router (RoutingAction a) state =
  Pux.Routing.Bob.Component.update router a state

mainWindowView :: View MainWindowState MainWindowRoute MainWindowRawAction
mainWindowView router mapAction state =
  div []
    [ ul []
        [ tabHeader Profile "profile"
        , tabHeader Inbox "inbox"
        , tabHeader Settings "settings"
        ]
    , div []
        case state.activeTab of
          Profile -> [ tabBody (mapAction (RawAction ProfileClick)) state.profileCounter "profile" ]
          Inbox -> [ tabBody (mapAction (RawAction InboxClick)) state.inboxCounter "inbox" ]
          Settings -> [ tabBody (mapAction (RawAction SettingsClick)) state.settingsCounter "settings" ]
    ]
 where
  link'' = link' mapAction router
  tabHeader route label =
    li
      (if state.activeTab == route
        then [className "active"]
        else [])
      [ link''
          route
          []
          [ text label ]
      ]
  tabBody action counter label =
    a [ href "#", onClick $ const action]
      [ text (label <> " action"), br [] [], text <<< show $ counter ]

-- Sidebar component

data SideBarRoute
  = Expanded
  | Minimized
derive instance genericSideBarRoute :: Generic SideBarRoute
derive instance eqSideBarRoute :: Eq SideBarRoute

type SideBarState = SideBarRoute

type SideBarRawAction = Unit

type SideBarAction = Action SideBarRoute SideBarRawAction

-- | This is how you can cheat to cleanup your subcomponent
-- | `update` API a bit and make subcomponent more self-contained.
-- | I've left this example here, side by side with default,
-- | safe implementation of `Router MainWidowRoute` construction,
-- | just for comparison.
sideBarRouter :: Router SideBarRoute
sideBarRouter =
  unsafePartial
    (case (Routing.Bob.router (Proxy :: Proxy SideBarRoute)) of Just r -> r)

sideBarUpdate :: forall eff. Update SideBarState SideBarAction (dom :: DOM | eff)
sideBarUpdate (RawAction _) state = noEffects state
sideBarUpdate (RoutingAction (Routed r)) state | r == Expanded = noEffects Expanded
                                               | r == Minimized = noEffects Minimized
sideBarUpdate (RoutingAction (RoutingError _)) state = noEffects state
sideBarUpdate (RoutingAction a) state =
  Pux.Routing.Bob.Component.update sideBarRouter a state

sideBarView :: View SideBarState SideBarRoute SideBarRawAction
sideBarView router mapAction state =
  p []
    if state == Expanded
      then
        [ text "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat."
        , br [] []
        , link'' Minimized [] [ text "hide"]
        ]
      else
        [ text "Lorem ipsum..."
        , link'' Expanded [] [ text "show more" ]
        ]
 where
  link'' = link' mapAction router

-- Application

data AppRoute =
  AppRoute MainWindowRoute SideBarRoute
derive instance genericAppRoute :: Generic AppRoute

getMainWindowRoute :: AppRoute -> MainWindowRoute
getMainWindowRoute (AppRoute m _) = m

getSideBarRoute :: AppRoute -> SideBarRoute
getSideBarRoute (AppRoute _ s) = s

type AppState =
  { mainWindowState :: MainWindowState
  , sideBarState :: SideBarState
  }

data AppRawAction
  = MainWindowRawAction MainWindowRawAction
  | SideBarRawAction SideBarRawAction

type AppAction = Action AppRoute AppRawAction

-- To be honest I'm using: unsafePartial (router RouteType)
-- for Router generation when it's tested, because route type
-- doesn't change over runtime. This simplifies API
-- a lot - you can avoid all this routers passing clutter...
appUpdate :: (Router MainWindowRoute) ->
             (Router AppRoute) ->
             Update AppState AppAction (dom :: DOM)
appUpdate mr _ (RawAction (MainWindowRawAction a)) state =
  let r = mainWindowUpdate mr (RawAction a) state.mainWindowState
  in
    { state: state { mainWindowState = r.state }
    , effects: (bimap mapRoute MainWindowRawAction <$> _) <$> r.effects
    }
 where
  mapRoute mainWindowRoute = AppRoute mainWindowRoute state.sideBarState
-- this branch could be avoided as sideBarUpdate doesn't perform anything
appUpdate _ _ (RawAction (SideBarRawAction a)) state =
  let r = sideBarUpdate (RawAction a) state.sideBarState
  in
    { state: state { sideBarState = r.state }
    , effects: (bimap mapRoute SideBarRawAction <$> _) <$> r.effects
    }
 where
  mapRoute sideBarRoute = AppRoute state.mainWindowState.activeTab sideBarRoute
appUpdate mRouter
          _
          (RoutingAction (Routed (AppRoute mainWindowRoute sideBarRoute)))
          state =
  let sr = sideBarUpdate (RoutingAction (Routed sideBarRoute)) state.sideBarState
      mr = mainWindowUpdate mRouter (RoutingAction (Routed mainWindowRoute)) state.mainWindowState
      mapSideBarRoute sideBarRoute = AppRoute mr.state.activeTab sideBarRoute
      mapMainWindowRoute mainWindowRoute = AppRoute mainWindowRoute sr.state
  in
    { state: state { sideBarState = sr.state
                   , mainWindowState = mr.state
                   }
    , effects: ((bimap mapSideBarRoute SideBarRawAction <$> _) <$> sr.effects) <>
               ((bimap mapMainWindowRoute MainWindowRawAction <$> _) <$> mr.effects)
    }
appUpdate _ _ (RoutingAction (RoutingError _)) state = noEffects state
appUpdate _ aRouter (RoutingAction a) state =
  Pux.Routing.Bob.Component.update aRouter a state

appView :: Router AppRoute -> AppState -> Html AppAction
appView router state =
  div []
    [ mainWindowView
        router
        (bimap (\r -> AppRoute r state.sideBarState) MainWindowRawAction)
        state.mainWindowState
    , sideBarView router mapSideBarAction state.sideBarState
    ]
 where
  -- Helper with type signature, which is necessary in this case
  mapSideBarAction :: forall b. (Bifunctor b) =>
                      b SideBarRoute SideBarRawAction ->
                      b AppRoute AppRawAction
  mapSideBarAction = bimap (\r -> AppRoute state.mainWindowState.activeTab r) SideBarRawAction

main :: Eff ( dom :: DOM , channel :: CHANNEL , err :: EXCEPTION ) Unit
main = do
  sampleUrlSignal <- sampleUrl
  let
    routers = do
      mainWindowRouter <- Routing.Bob.router (Proxy :: Proxy MainWindowRoute)
      appRouter <- Routing.Bob.router (Proxy :: Proxy AppRoute)
      pure
        { appRouter: appRouter
        , mainWindowRouter: mainWindowRouter
        }

  case routers of
    Just rs ->
      do
        currRoute <- setInitialRoute rs.appRouter (AppRoute Profile Minimized)
        let
          view = appView rs.appRouter
          update = appUpdate rs.mainWindowRouter rs.appRouter
          initialState =
            { mainWindowState:
              { activeTab: getMainWindowRoute currRoute
              , profileCounter: 0
              , inboxCounter: 0
              , settingsCounter: 0
              }
            , sideBarState: getSideBarRoute currRoute
            }
          config =
            { update: update
            , view: view
            , inputs: [ sampleUrlSignal ]
            , initialState: initialState
            }
        app <- start config
        renderToDOM "#app" app.html
    Nothing -> pure unit


single method example

single method example

module D3HOAS.Selection where

import Prelude (Unit)
import D3HOAS.Base

class Selection repr where
    d3Select    :: Selector -> repr
    -- d3SelectAll :: Selector -> repr
    -- select      :: Selector -> repr -> repr
    -- selectAll   :: Selector -> repr -> repr
    -- merge       :: repr -> repr -> repr
    -- insert      :: D3ElementType -> repr -> repr
    -- append      :: D3ElementType -> repr -> repr
    -- remove      :: repr -> Unit
    -- enter       :: repr -> repr
    -- exit        :: repr -> repr
    -- transition  :: D3Transition -> repr -> repr
    -- attrs       :: ∀ d. Array (Attr d) -> repr -> repr
    -- dataA       :: ∀ d. Array d -> repr -> repr
    -- dataH       :: ∀ d. Array d -> repr -> repr
    -- dataAI      :: ∀ d i. Array d -> (d -> i) -> repr -> repr
    -- dataHI      :: ∀ d i. Array d -> (d -> i) -> repr -> repr

data DummySelection = DS { d3Selection :: String }

instance selectionDummySelection :: Selection DummySelection where
    d3Select selector = DS { d3Selection: selector }

module D3HOAS.Selection where

import Prelude (Unit)
import D3HOAS.Base

class Selection repr where
    d3Select    :: Selector -> repr
    d3SelectAll :: Selector -> repr
    select      :: Selector -> repr -> repr
    selectAll   :: Selector -> repr -> repr
    merge       :: repr -> repr -> repr
    insert      :: D3ElementType -> repr -> repr
    append      :: D3ElementType -> repr -> repr
    remove      :: repr -> Unit
    enter       :: repr -> repr
    exit        :: repr -> repr
    transition  :: D3Transition -> repr -> repr
    attrs       :: ∀ d. Array (Attr d) -> repr -> repr
    dataA       :: ∀ d. Array d -> repr -> repr
    dataH       :: ∀ d. Array d -> repr -> repr
    dataAI      :: ∀ d i. Array d -> (d -> i) -> repr -> repr
    dataHI      :: ∀ d i. Array d -> (d -> i) -> repr -> repr


awaitLoad canceller will remove correct eventListener

module Halogen.Aff.Util
  ( awaitLoad
  , awaitBody
  , selectElement
  , runHalogenAff
  ) where

import Prelude

import Control.Monad.Aff (Aff, Canceler(..), makeAff, nonCanceler, runAff_)
import Control.Monad.Eff (kind Effect, Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (throwException, error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (runExcept)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener, removeEventListener)
import DOM.Event.Types (EventType(..))
import DOM.HTML (window)
import DOM.HTML.Document (ReadyState(..), readyState)
import DOM.HTML.Types (HTMLElement, windowToEventTarget, htmlDocumentToParentNode, readHTMLElement)
import DOM.HTML.Window (document)
import DOM.Node.ParentNode (QuerySelector(..), querySelector)
import Data.Either (Either(..), either)
import Data.Foreign (toForeign)
import Data.Maybe (Maybe(..), maybe)
import Halogen.Aff.Effects (HalogenEffects)

-- | Waits for the document to load.
awaitLoad :: forall eff. Aff (dom :: DOM | eff) Unit
awaitLoad = makeAff \callback -> liftEff do
  rs <- readyState =<< document =<< window
  case rs of
    Loading -> do
      et <- windowToEventTarget <$> window
      let listener = eventListener (\_ -> callback (Right unit))
          domContentLoaded = EventType "DOMContentLoaded"
      addEventListener domContentLoaded listener false et
      pure $ Canceler \_ -> liftEff (removeEventListener domContentLoaded listener false et)
    _ -> do
      callback (Right unit)
      pure nonCanceler

-- | Waits for the document to load and then finds the `body` element.
awaitBody :: forall eff. Aff (dom :: DOM | eff) HTMLElement
awaitBody = do
  awaitLoad
  body <- selectElement (QuerySelector "body")
  maybe (throwError (error "Could not find body")) pure body

-- | Tries to find an element in the document.
selectElement
  :: forall eff
   . QuerySelector
  -> Aff (dom :: DOM | eff) (Maybe HTMLElement)
selectElement query = do
  mel <- liftEff $
    ((querySelector query <<< htmlDocumentToParentNode <=< document) =<< window)
  pure case mel of
    Nothing -> Nothing
    Just el -> either (const Nothing) Just $ runExcept $ readHTMLElement (toForeign el)

-- | Runs an `Aff` value of the type commonly used by Halogen components. Any
-- | unhandled errors will be re-thrown as exceptions.
runHalogenAff
  :: forall eff x
   . Aff (HalogenEffects eff) x
  -> Eff (HalogenEffects eff) Unit
runHalogenAff = runAff_ (either throwException (const (pure unit)))

module Halogen.Aff.Util
  ( awaitLoad
  , awaitBody
  , selectElement
  , runHalogenAff
  ) where

import Prelude

import Control.Monad.Aff (Aff, Canceler(..), makeAff, nonCanceler, runAff_)
import Control.Monad.Eff (kind Effect, Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (throwException, error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (runExcept)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener, removeEventListener)
import DOM.Event.Types (EventType(..))
import DOM.HTML (window)
import DOM.HTML.Document (ReadyState(..), readyState)
import DOM.HTML.Event.EventTypes (load)
import DOM.HTML.Types (HTMLElement, windowToEventTarget, htmlDocumentToParentNode, readHTMLElement)
import DOM.HTML.Window (document)
import DOM.Node.ParentNode (QuerySelector(..), querySelector)
import Data.Either (Either(..), either)
import Data.Foreign (toForeign)
import Data.Maybe (Maybe(..), maybe)
import Halogen.Aff.Effects (HalogenEffects)

-- | Waits for the document to load.
awaitLoad :: forall eff. Aff (dom :: DOM | eff) Unit
awaitLoad = makeAff \callback -> liftEff do
  rs <- readyState =<< document =<< window
  case rs of
    Loading -> do
      et <- windowToEventTarget <$> window
      let listener = eventListener (\_ -> callback (Right unit))
      addEventListener (EventType "DOMContentLoaded") listener false et
      pure $ Canceler \_ -> liftEff (removeEventListener load listener false et)
    _ -> do
      callback (Right unit)
      pure nonCanceler

-- | Waits for the document to load and then finds the `body` element.
awaitBody :: forall eff. Aff (dom :: DOM | eff) HTMLElement
awaitBody = do
  awaitLoad
  body <- selectElement (QuerySelector "body")
  maybe (throwError (error "Could not find body")) pure body

-- | Tries to find an element in the document.
selectElement
  :: forall eff
   . QuerySelector
  -> Aff (dom :: DOM | eff) (Maybe HTMLElement)
selectElement query = do
  mel <- liftEff $
    ((querySelector query <<< htmlDocumentToParentNode <=< document) =<< window)
  pure case mel of
    Nothing -> Nothing
    Just el -> either (const Nothing) Just $ runExcept $ readHTMLElement (toForeign el)

-- | Runs an `Aff` value of the type commonly used by Halogen components. Any
-- | unhandled errors will be re-thrown as exceptions.
runHalogenAff
  :: forall eff x
   . Aff (HalogenEffects eff) x
  -> Eff (HalogenEffects eff) Unit
runHalogenAff = runAff_ (either throwException (const (pure unit)))


Re-export throwError, catchError

Re-export throwError, catchError

module Control.Monad.Aff
  ( Aff
  , Fiber
  , ParAff(..)
  , Canceler(..)
  , makeAff
  , launchAff
  , launchAff_
  , launchSuspendedAff
  , runAff
  , runAff_
  , runSuspendedAff
  , forkAff
  , suspendAff
  , liftEff'
  , supervise
  , attempt
  , apathize
  , delay
  , never
  , finally
  , atomically
  , killFiber
  , joinFiber
  , cancelWith
  , bracket
  , BracketConditions
  , generalBracket
  , nonCanceler
  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, error)
import Control.Monad.Eff.Exception (Error, error, message) as Exports
import Control.Monad.Eff.Unsafe (unsafeCoerceEff, unsafePerformEff)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try, throwError, catchError) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.Parallel (parSequence_, parallel)
import Control.Parallel.Class (class Parallel)
import Control.Plus (class Plus, empty)
import Data.Either (Either(..))
import Data.Function.Uncurried as Fn
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Partial.Unsafe (unsafeCrashWith)
import Unsafe.Coerce (unsafeCoerce)

-- | An `Aff eff a` is an asynchronous computation with effects `eff`. The
-- | computation may either error with an exception, or produce a result of
-- | type `a`. `Aff` effects are assembled from primitive `Eff` effects using
-- | `makeAff` or `liftEff`.
foreign import data Aff ∷ # Effect → Type → Type

instance functorAff ∷ Functor (Aff eff) where
  map = _map

instance applyAff ∷ Apply (Aff eff) where
  apply = ap

instance applicativeAff ∷ Applicative (Aff eff) where
  pure = _pure

instance bindAff ∷ Bind (Aff eff) where
  bind = _bind

instance monadAff ∷ Monad (Aff eff)

instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff eff a) where
  append = lift2 append

instance monoidAff ∷ Monoid a ⇒ Monoid (Aff eff a) where
  mempty = pure mempty

instance altAff ∷ Alt (Aff eff) where
  alt a1 a2 = catchError a1 (const a2)

instance plusAff ∷ Plus (Aff eff) where
  empty = throwError (error "Always fails")

-- | This instance is provided for compatibility. `Aff` is always stack-safe
-- | within a given fiber. This instance will just result in unnecessary
-- | bind overhead.
instance monadRecAff ∷ MonadRec (Aff eff) where
  tailRecM k = go
    where
    go a = do
      res ← k a
      case res of
        Done r → pure r
        Loop b → go b

instance monadThrowAff ∷ MonadThrow Error (Aff eff) where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error (Aff eff) where
  catchError = _catchError

instance monadEffAff ∷ MonadEff eff (Aff eff) where
  liftEff = _liftEff

-- | Applicative for running parallel effects. Any `Aff` can be coerced to a
-- | `ParAff` and back using the `Parallel` class.
foreign import data ParAff ∷ # Effect → Type → Type

instance functorParAff ∷ Functor (ParAff eff) where
  map = _parAffMap

-- | Runs effects in parallel, combining their results.
instance applyParAff ∷ Apply (ParAff eff) where
  apply = _parAffApply

instance applicativeParAff ∷ Applicative (ParAff eff) where
  pure = parallel <<< pure

instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff eff a) where
  append = lift2 append

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff a) where
  mempty = pure mempty

-- | Races effects in parallel. Returns the first successful result or the
-- | first error if all fail with an exception. Losing branches will be
-- | cancelled.
instance altParAff ∷ Alt (ParAff eff) where
  alt = _parAffAlt

instance plusParAff ∷ Plus (ParAff e) where
  empty = parallel empty

instance alternativeParAff ∷ Alternative (ParAff e)

instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where
  parallel = (unsafeCoerce ∷ ∀ a. Aff eff a → ParAff eff a)
  sequential = _sequential

type OnComplete eff a =
  { rethrow ∷ Boolean
  , handler ∷ (Either Error a → Eff eff Unit) → Eff eff Unit
  }

-- | Represents a forked computation by way of `forkAff`. `Fiber`s are
-- | memoized, so their results are only computed once.
newtype Fiber eff a = Fiber
  { run ∷ Eff eff Unit
  , kill ∷ Fn.Fn2 Error (Either Error Unit → Eff eff Unit) (Eff eff (Eff eff Unit))
  , join ∷ (Either Error a → Eff eff Unit) → Eff eff (Eff eff Unit)
  , onComplete ∷ OnComplete eff a → Eff eff (Eff eff Unit)
  }

instance functorFiber ∷ Functor (Fiber eff) where
  map f t = unsafePerformEff (makeFiber (f <$> joinFiber t))

instance applyFiber ∷ Apply (Fiber eff) where
  apply t1 t2 = unsafePerformEff (makeFiber (joinFiber t1 <*> joinFiber t2))

instance applicativeFiber ∷ Applicative (Fiber eff) where
  pure a = unsafePerformEff (makeFiber (pure a))

-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks
-- | until the fiber has fully exited.
killFiber ∷ ∀ eff a. Error → Fiber eff a → Aff eff Unit
killFiber e (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> Fn.runFn2 t.kill e k

-- | Blocks until the fiber completes, yielding the result. If the fiber
-- | throws an exception, it is rethrown in the current fiber.
joinFiber ∷ ∀ eff a. Fiber eff a → Aff eff a
joinFiber (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> t.join k

-- | A cancellation effect for actions run via `makeAff`. If a `Fiber` is
-- | killed, and an async action is pending, the canceler will be called to
-- | clean it up.
newtype Canceler eff = Canceler (Error → Aff eff Unit)

derive instance newtypeCanceler ∷ Newtype (Canceler eff) _

instance semigroupCanceler ∷ Semigroup (Canceler eff) where
  append (Canceler c1) (Canceler c2) =
    Canceler \err → parSequence_ [ c1 err, c2 err ]

-- | A no-op `Canceler` can be constructed with `mempty`.
instance monoidCanceler ∷ Monoid (Canceler eff) where
  mempty = nonCanceler

-- | A canceler which does not cancel anything.
nonCanceler ∷ ∀ eff. Canceler eff
nonCanceler = Canceler (const (pure unit))

-- | Forks an `Aff` from an `Eff` context, returning the `Fiber`.
launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchAff aff = do
  fiber ← makeFiber aff
  case fiber of Fiber f → f.run
  pure fiber

-- | Forks an `Aff` from an `Eff` context, discarding the `Fiber`.
launchAff_ ∷ ∀ eff a. Aff eff a → Eff eff Unit
launchAff_ = void <<< launchAff

-- | Suspends an `Aff` from an `Eff` context, returning the `Fiber`.
launchSuspendedAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchSuspendedAff = makeFiber

-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when
-- | it completes. Returns the pending `Fiber`.
runAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)
runAff k aff = launchAff $ liftEff <<< k =<< try aff

-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when
-- | it completes, discarding the `Fiber`.
runAff_ ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff Unit
runAff_ k aff = void $ runAff k aff

-- | Suspends an `Aff` from an `Eff` context and also takes a callback to run
-- | when it completes. Returns the suspended `Fiber`.
runSuspendedAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)
runSuspendedAff k aff = launchSuspendedAff $ liftEff <<< k =<< try aff

-- | Forks am `Aff` from within a parent `Aff` context, returning the `Fiber`.
forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
forkAff = _fork true

-- | Suspends an `Aff` from within a parent `Aff` context, returning the `Fiber`.
-- | A suspended `Aff` is not executed until a consumer observes the result
-- | with `joinFiber`.
suspendAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
suspendAff = _fork false

-- | Pauses the running fiber.
delay ∷ ∀ eff. Milliseconds → Aff eff Unit
delay (Milliseconds n) = Fn.runFn2 _delay Right n

-- | An async computation which does not resolve.
never ∷ ∀ eff a. Aff eff a
never = makeAff \_ → pure mempty

-- | All `Eff` exceptions are implicitly caught within an `Aff` context, but
-- | standard `liftEff` won't remove the effect label.
liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a
liftEff' = liftEff <<< unsafeCoerceEff

-- | A monomorphic version of `try`. Catches thrown errors and lifts them
-- | into an `Either`.
attempt ∷ ∀ eff a. Aff eff a → Aff eff (Either Error a)
attempt = try

-- | Ignores any errors.
apathize ∷ ∀ eff a. Aff eff a → Aff eff Unit
apathize = attempt >>> map (const unit)

-- | Runs the first effect after the second, regardless of whether it completed
-- | successfully or the fiber was cancelled.
finally ∷ ∀ eff a. Aff eff Unit → Aff eff a → Aff eff a
finally fin a = bracket (pure unit) (const fin) (const a)

-- | Runs an effect such that it cannot be killed.
atomically ∷ ∀ eff a. Aff eff a → Aff eff a
atomically a = bracket a (const (pure unit)) pure

-- | Attaches a custom `Canceler` to an action. If the computation is canceled,
-- | then the custom `Canceler` will be run afterwards.
cancelWith ∷ ∀ eff a. Aff eff a → Canceler eff → Aff eff a
cancelWith aff (Canceler cancel) =
  generalBracket (pure unit)
    { killed: \e _ → cancel e
    , failed: const pure
    , completed: const pure
    }
    (const aff)

-- | Guarantees resource acquisition and cleanup. The first effect may acquire
-- | some resource, while the second will dispose of it. The third effect makes
-- | use of the resource. Disposal is always run last, regardless. Neither
-- | acquisition nor disposal may be cancelled and are guaranteed to run until
-- | they complete.
bracket ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b
bracket acquire completed =
  generalBracket acquire
    { killed: const completed
    , failed: const completed
    , completed: const completed
    }

type Supervised eff a =
  { fiber ∷ Fiber eff a
  , supervisor ∷ Supervisor eff
  }

-- | Creates a new supervision context for some `Aff`, guaranteeing fiber
-- | cleanup when the parent completes. Any pending fibers forked within
-- | the context will be killed and have their cancelers run.
supervise ∷ ∀ eff a. Aff eff a → Aff eff a
supervise aff =
  generalBracket (liftEff acquire)
    { killed: \err sup → parSequence_ [ killFiber err sup.fiber, killAll err sup ]
    , failed: const (killAll killError)
    , completed: const (killAll killError)
    }
    (joinFiber <<< _.fiber)
  where
  killError ∷ Error
  killError =
    error "[Aff] Child fiber outlived parent"

  killAll ∷ Error → Supervised eff a → Aff eff Unit
  killAll err sup = makeAff \k →
    Fn.runFn3 _killAll err sup.supervisor (k (pure unit))

  acquire ∷ Eff eff (Supervised eff a)
  acquire = do
    sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff
    case sup.fiber of Fiber f → f.run
    pure sup

foreign import data Supervisor ∷ # Effect → Type
foreign import _pure ∷ ∀ eff a. a → Aff eff a
foreign import _throwError ∷ ∀ eff a. Error → Aff eff a
foreign import _catchError ∷ ∀ eff a. Aff eff a → (Error → Aff eff a) → Aff eff a
foreign import _fork ∷ ∀ eff a. Boolean → Aff eff a → Aff eff (Fiber eff a)
foreign import _map ∷ ∀ eff a b. (a → b) → Aff eff a → Aff eff b
foreign import _bind ∷ ∀ eff a b. Aff eff a → (a → Aff eff b) → Aff eff b
foreign import _delay ∷ ∀ a eff. Fn.Fn2 (Unit → Either a Unit) Number (Aff eff Unit)
foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff a
foreign import _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a
foreign import _makeFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Fiber eff a))
foreign import _makeSupervisedFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Supervised eff a))
foreign import _killAll ∷ ∀ eff. Fn.Fn3 Error (Supervisor eff) (Eff eff Unit) (Eff eff (Canceler eff))
foreign import _sequential ∷ ∀ eff a. ParAff eff a → Aff eff a

type BracketConditions eff a b =
  { killed ∷ Error → a → Aff eff Unit
  , failed ∷ Error → a → Aff eff Unit
  , completed ∷ b → a → Aff eff Unit
  }

-- | A general purpose bracket which lets you observe the status of the
-- | bracketed action. The bracketed action may have been killed with an
-- | exception, thrown an exception, or completed successfully.
foreign import generalBracket ∷ ∀ eff a b. Aff eff a → BracketConditions eff a b → (a → Aff eff b) → Aff eff b

-- | Constructs an `Aff` from low-level `Eff` effects using a callback. A
-- | `Canceler` effect should be returned to cancel the pending action. The
-- | supplied callback may be invoked only once. Subsequent invocation are
-- | ignored.
foreign import makeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a

makeFiber ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff

newtype FFIUtil = FFIUtil
  { isLeft ∷ ∀ a b. Either a b → Boolean
  , fromLeft ∷ ∀ a b. Either a b → a
  , fromRight ∷ ∀ a b. Either a b → b
  , left ∷ ∀ a b. a → Either a b
  , right ∷ ∀ a b. b → Either a b
  }

ffiUtil ∷ FFIUtil
ffiUtil = FFIUtil
  { isLeft
  , fromLeft: unsafeFromLeft
  , fromRight: unsafeFromRight
  , left: Left
  , right: Right
  }
  where
  isLeft ∷ ∀ a b. Either a b → Boolean
  isLeft = case _ of
    Left _ -> true
    Right _ → false

  unsafeFromLeft ∷ ∀ a b. Either a b → a
  unsafeFromLeft = case _ of
    Left a  → a
    Right _ → unsafeCrashWith "unsafeFromLeft: Right"

  unsafeFromRight ∷ ∀ a b. Either a b → b
  unsafeFromRight = case _ of
    Right a → a
    Left  _ → unsafeCrashWith "unsafeFromRight: Left"

module Control.Monad.Aff
  ( Aff
  , Fiber
  , ParAff(..)
  , Canceler(..)
  , makeAff
  , launchAff
  , launchAff_
  , launchSuspendedAff
  , runAff
  , runAff_
  , runSuspendedAff
  , forkAff
  , suspendAff
  , liftEff'
  , supervise
  , attempt
  , apathize
  , delay
  , never
  , finally
  , atomically
  , killFiber
  , joinFiber
  , cancelWith
  , bracket
  , BracketConditions
  , generalBracket
  , nonCanceler
  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (Error, EXCEPTION, error)
import Control.Monad.Eff.Exception (Error, error, message) as Exports
import Control.Monad.Eff.Unsafe (unsafeCoerceEff, unsafePerformEff)
import Control.Monad.Error.Class (class MonadError, class MonadThrow, throwError, catchError, try)
import Control.Monad.Error.Class (try) as Exports
import Control.Monad.Rec.Class (class MonadRec, Step(..))
import Control.Parallel (parSequence_, parallel)
import Control.Parallel.Class (class Parallel)
import Control.Plus (class Plus, empty)
import Data.Either (Either(..))
import Data.Function.Uncurried as Fn
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.Time.Duration (Milliseconds(..))
import Partial.Unsafe (unsafeCrashWith)
import Unsafe.Coerce (unsafeCoerce)

-- | An `Aff eff a` is an asynchronous computation with effects `eff`. The
-- | computation may either error with an exception, or produce a result of
-- | type `a`. `Aff` effects are assembled from primitive `Eff` effects using
-- | `makeAff` or `liftEff`.
foreign import data Aff ∷ # Effect → Type → Type

instance functorAff ∷ Functor (Aff eff) where
  map = _map

instance applyAff ∷ Apply (Aff eff) where
  apply = ap

instance applicativeAff ∷ Applicative (Aff eff) where
  pure = _pure

instance bindAff ∷ Bind (Aff eff) where
  bind = _bind

instance monadAff ∷ Monad (Aff eff)

instance semigroupAff ∷ Semigroup a ⇒ Semigroup (Aff eff a) where
  append = lift2 append

instance monoidAff ∷ Monoid a ⇒ Monoid (Aff eff a) where
  mempty = pure mempty

instance altAff ∷ Alt (Aff eff) where
  alt a1 a2 = catchError a1 (const a2)

instance plusAff ∷ Plus (Aff eff) where
  empty = throwError (error "Always fails")

-- | This instance is provided for compatibility. `Aff` is always stack-safe
-- | within a given fiber. This instance will just result in unnecessary
-- | bind overhead.
instance monadRecAff ∷ MonadRec (Aff eff) where
  tailRecM k = go
    where
    go a = do
      res ← k a
      case res of
        Done r → pure r
        Loop b → go b

instance monadThrowAff ∷ MonadThrow Error (Aff eff) where
  throwError = _throwError

instance monadErrorAff ∷ MonadError Error (Aff eff) where
  catchError = _catchError

instance monadEffAff ∷ MonadEff eff (Aff eff) where
  liftEff = _liftEff

-- | Applicative for running parallel effects. Any `Aff` can be coerced to a
-- | `ParAff` and back using the `Parallel` class.
foreign import data ParAff ∷ # Effect → Type → Type

instance functorParAff ∷ Functor (ParAff eff) where
  map = _parAffMap

-- | Runs effects in parallel, combining their results.
instance applyParAff ∷ Apply (ParAff eff) where
  apply = _parAffApply

instance applicativeParAff ∷ Applicative (ParAff eff) where
  pure = parallel <<< pure

instance semigroupParAff ∷ Semigroup a ⇒ Semigroup (ParAff eff a) where
  append = lift2 append

instance monoidParAff ∷ Monoid a ⇒ Monoid (ParAff eff a) where
  mempty = pure mempty

-- | Races effects in parallel. Returns the first successful result or the
-- | first error if all fail with an exception. Losing branches will be
-- | cancelled.
instance altParAff ∷ Alt (ParAff eff) where
  alt = _parAffAlt

instance plusParAff ∷ Plus (ParAff e) where
  empty = parallel empty

instance alternativeParAff ∷ Alternative (ParAff e)

instance parallelAff ∷ Parallel (ParAff eff) (Aff eff) where
  parallel = (unsafeCoerce ∷ ∀ a. Aff eff a → ParAff eff a)
  sequential = _sequential

type OnComplete eff a =
  { rethrow ∷ Boolean
  , handler ∷ (Either Error a → Eff eff Unit) → Eff eff Unit
  }

-- | Represents a forked computation by way of `forkAff`. `Fiber`s are
-- | memoized, so their results are only computed once.
newtype Fiber eff a = Fiber
  { run ∷ Eff eff Unit
  , kill ∷ Fn.Fn2 Error (Either Error Unit → Eff eff Unit) (Eff eff (Eff eff Unit))
  , join ∷ (Either Error a → Eff eff Unit) → Eff eff (Eff eff Unit)
  , onComplete ∷ OnComplete eff a → Eff eff (Eff eff Unit)
  }

instance functorFiber ∷ Functor (Fiber eff) where
  map f t = unsafePerformEff (makeFiber (f <$> joinFiber t))

instance applyFiber ∷ Apply (Fiber eff) where
  apply t1 t2 = unsafePerformEff (makeFiber (joinFiber t1 <*> joinFiber t2))

instance applicativeFiber ∷ Applicative (Fiber eff) where
  pure a = unsafePerformEff (makeFiber (pure a))

-- | Invokes pending cancelers in a fiber and runs cleanup effects. Blocks
-- | until the fiber has fully exited.
killFiber ∷ ∀ eff a. Error → Fiber eff a → Aff eff Unit
killFiber e (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> Fn.runFn2 t.kill e k

-- | Blocks until the fiber completes, yielding the result. If the fiber
-- | throws an exception, it is rethrown in the current fiber.
joinFiber ∷ ∀ eff a. Fiber eff a → Aff eff a
joinFiber (Fiber t) = makeAff \k → Canceler <<< const <<< liftEff <$> t.join k

-- | A cancellation effect for actions run via `makeAff`. If a `Fiber` is
-- | killed, and an async action is pending, the canceler will be called to
-- | clean it up.
newtype Canceler eff = Canceler (Error → Aff eff Unit)

derive instance newtypeCanceler ∷ Newtype (Canceler eff) _

instance semigroupCanceler ∷ Semigroup (Canceler eff) where
  append (Canceler c1) (Canceler c2) =
    Canceler \err → parSequence_ [ c1 err, c2 err ]

-- | A no-op `Canceler` can be constructed with `mempty`.
instance monoidCanceler ∷ Monoid (Canceler eff) where
  mempty = nonCanceler

-- | A canceler which does not cancel anything.
nonCanceler ∷ ∀ eff. Canceler eff
nonCanceler = Canceler (const (pure unit))

-- | Forks an `Aff` from an `Eff` context, returning the `Fiber`.
launchAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchAff aff = do
  fiber ← makeFiber aff
  case fiber of Fiber f → f.run
  pure fiber

-- | Forks an `Aff` from an `Eff` context, discarding the `Fiber`.
launchAff_ ∷ ∀ eff a. Aff eff a → Eff eff Unit
launchAff_ = void <<< launchAff

-- | Suspends an `Aff` from an `Eff` context, returning the `Fiber`.
launchSuspendedAff ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
launchSuspendedAff = makeFiber

-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when
-- | it completes. Returns the pending `Fiber`.
runAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)
runAff k aff = launchAff $ liftEff <<< k =<< try aff

-- | Forks an `Aff` from an `Eff` context and also takes a callback to run when
-- | it completes, discarding the `Fiber`.
runAff_ ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff Unit
runAff_ k aff = void $ runAff k aff

-- | Suspends an `Aff` from an `Eff` context and also takes a callback to run
-- | when it completes. Returns the suspended `Fiber`.
runSuspendedAff ∷ ∀ eff a. (Either Error a → Eff eff Unit) → Aff eff a → Eff eff (Fiber eff Unit)
runSuspendedAff k aff = launchSuspendedAff $ liftEff <<< k =<< try aff

-- | Forks am `Aff` from within a parent `Aff` context, returning the `Fiber`.
forkAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
forkAff = _fork true

-- | Suspends an `Aff` from within a parent `Aff` context, returning the `Fiber`.
-- | A suspended `Aff` is not executed until a consumer observes the result
-- | with `joinFiber`.
suspendAff ∷ ∀ eff a. Aff eff a → Aff eff (Fiber eff a)
suspendAff = _fork false

-- | Pauses the running fiber.
delay ∷ ∀ eff. Milliseconds → Aff eff Unit
delay (Milliseconds n) = Fn.runFn2 _delay Right n

-- | An async computation which does not resolve.
never ∷ ∀ eff a. Aff eff a
never = makeAff \_ → pure mempty

-- | All `Eff` exceptions are implicitly caught within an `Aff` context, but
-- | standard `liftEff` won't remove the effect label.
liftEff' ∷ ∀ eff a. Eff (exception ∷ EXCEPTION | eff) a → Aff eff a
liftEff' = liftEff <<< unsafeCoerceEff

-- | A monomorphic version of `try`. Catches thrown errors and lifts them
-- | into an `Either`.
attempt ∷ ∀ eff a. Aff eff a → Aff eff (Either Error a)
attempt = try

-- | Ignores any errors.
apathize ∷ ∀ eff a. Aff eff a → Aff eff Unit
apathize = attempt >>> map (const unit)

-- | Runs the first effect after the second, regardless of whether it completed
-- | successfully or the fiber was cancelled.
finally ∷ ∀ eff a. Aff eff Unit → Aff eff a → Aff eff a
finally fin a = bracket (pure unit) (const fin) (const a)

-- | Runs an effect such that it cannot be killed.
atomically ∷ ∀ eff a. Aff eff a → Aff eff a
atomically a = bracket a (const (pure unit)) pure

-- | Attaches a custom `Canceler` to an action. If the computation is canceled,
-- | then the custom `Canceler` will be run afterwards.
cancelWith ∷ ∀ eff a. Aff eff a → Canceler eff → Aff eff a
cancelWith aff (Canceler cancel) =
  generalBracket (pure unit)
    { killed: \e _ → cancel e
    , failed: const pure
    , completed: const pure
    }
    (const aff)

-- | Guarantees resource acquisition and cleanup. The first effect may acquire
-- | some resource, while the second will dispose of it. The third effect makes
-- | use of the resource. Disposal is always run last, regardless. Neither
-- | acquisition nor disposal may be cancelled and are guaranteed to run until
-- | they complete.
bracket ∷ ∀ eff a b. Aff eff a → (a → Aff eff Unit) → (a → Aff eff b) → Aff eff b
bracket acquire completed =
  generalBracket acquire
    { killed: const completed
    , failed: const completed
    , completed: const completed
    }

type Supervised eff a =
  { fiber ∷ Fiber eff a
  , supervisor ∷ Supervisor eff
  }

-- | Creates a new supervision context for some `Aff`, guaranteeing fiber
-- | cleanup when the parent completes. Any pending fibers forked within
-- | the context will be killed and have their cancelers run.
supervise ∷ ∀ eff a. Aff eff a → Aff eff a
supervise aff =
  generalBracket (liftEff acquire)
    { killed: \err sup → parSequence_ [ killFiber err sup.fiber, killAll err sup ]
    , failed: const (killAll killError)
    , completed: const (killAll killError)
    }
    (joinFiber <<< _.fiber)
  where
  killError ∷ Error
  killError =
    error "[Aff] Child fiber outlived parent"

  killAll ∷ Error → Supervised eff a → Aff eff Unit
  killAll err sup = makeAff \k →
    Fn.runFn3 _killAll err sup.supervisor (k (pure unit))

  acquire ∷ Eff eff (Supervised eff a)
  acquire = do
    sup ← Fn.runFn2 _makeSupervisedFiber ffiUtil aff
    case sup.fiber of Fiber f → f.run
    pure sup

foreign import data Supervisor ∷ # Effect → Type
foreign import _pure ∷ ∀ eff a. a → Aff eff a
foreign import _throwError ∷ ∀ eff a. Error → Aff eff a
foreign import _catchError ∷ ∀ eff a. Aff eff a → (Error → Aff eff a) → Aff eff a
foreign import _fork ∷ ∀ eff a. Boolean → Aff eff a → Aff eff (Fiber eff a)
foreign import _map ∷ ∀ eff a b. (a → b) → Aff eff a → Aff eff b
foreign import _bind ∷ ∀ eff a b. Aff eff a → (a → Aff eff b) → Aff eff b
foreign import _delay ∷ ∀ a eff. Fn.Fn2 (Unit → Either a Unit) Number (Aff eff Unit)
foreign import _liftEff ∷ ∀ eff a. Eff eff a → Aff eff a
foreign import _parAffMap ∷ ∀ eff a b. (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffApply ∷ ∀ eff a b. ParAff eff (a → b) → ParAff eff a → ParAff eff b
foreign import _parAffAlt ∷ ∀ eff a. ParAff eff a → ParAff eff a → ParAff eff a
foreign import _makeFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Fiber eff a))
foreign import _makeSupervisedFiber ∷ ∀ eff a. Fn.Fn2 FFIUtil (Aff eff a) (Eff eff (Supervised eff a))
foreign import _killAll ∷ ∀ eff. Fn.Fn3 Error (Supervisor eff) (Eff eff Unit) (Eff eff (Canceler eff))
foreign import _sequential ∷ ∀ eff a. ParAff eff a → Aff eff a

type BracketConditions eff a b =
  { killed ∷ Error → a → Aff eff Unit
  , failed ∷ Error → a → Aff eff Unit
  , completed ∷ b → a → Aff eff Unit
  }

-- | A general purpose bracket which lets you observe the status of the
-- | bracketed action. The bracketed action may have been killed with an
-- | exception, thrown an exception, or completed successfully.
foreign import generalBracket ∷ ∀ eff a b. Aff eff a → BracketConditions eff a b → (a → Aff eff b) → Aff eff b

-- | Constructs an `Aff` from low-level `Eff` effects using a callback. A
-- | `Canceler` effect should be returned to cancel the pending action. The
-- | supplied callback may be invoked only once. Subsequent invocation are
-- | ignored.
foreign import makeAff ∷ ∀ eff a. ((Either Error a → Eff eff Unit) → Eff eff (Canceler eff)) → Aff eff a

makeFiber ∷ ∀ eff a. Aff eff a → Eff eff (Fiber eff a)
makeFiber aff = Fn.runFn2 _makeFiber ffiUtil aff

newtype FFIUtil = FFIUtil
  { isLeft ∷ ∀ a b. Either a b → Boolean
  , fromLeft ∷ ∀ a b. Either a b → a
  , fromRight ∷ ∀ a b. Either a b → b
  , left ∷ ∀ a b. a → Either a b
  , right ∷ ∀ a b. b → Either a b
  }

ffiUtil ∷ FFIUtil
ffiUtil = FFIUtil
  { isLeft
  , fromLeft: unsafeFromLeft
  , fromRight: unsafeFromRight
  , left: Left
  , right: Right
  }
  where
  isLeft ∷ ∀ a b. Either a b → Boolean
  isLeft = case _ of
    Left _ -> true
    Right _ → false

  unsafeFromLeft ∷ ∀ a b. Either a b → a
  unsafeFromLeft = case _ of
    Left a  → a
    Right _ → unsafeCrashWith "unsafeFromLeft: Right"

  unsafeFromRight ∷ ∀ a b. Either a b → b
  unsafeFromRight = case _ of
    Right a → a
    Left  _ → unsafeCrashWith "unsafeFromRight: Left"


Support maps

Support maps

Original commit b1d950ec6e3c800a80032a306dd8e92999d33234

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (for_, intercalate, maximum)

import Data.List as L

import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.Set (Set)
import Data.Set as S

import Data.String as Str
import Data.String.Util as Str

import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util (camelCase, capitalize)

import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)
import Data.Either as Either

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> s <> "_"
        , forbiddenNames: []
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

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

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    isLetterCharacter c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "any"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion types -> renderUnion $ unionToSet types

interfaceNamify :: String -> String
interfaceNamify = Str.camelCase >>> Str.capitalize >>> legalizeIdentifier

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = "\"" <> s <> "\""
    | otherwise =
        case Str.charAt 0 s of
            Nothing -> "Empty"
            Just c | isStartCharacter c -> s
                   | otherwise -> "\"" <> s <> "\""

hasInternalSeparator :: Rx.Regex
hasInternalSeparator = unsafePartial $ Either.fromRight $ Rx.regex "[-. ]" RxFlags.noFlags

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    top <- getTopLevel >>= renderType
    line $ """// To parse this JSON data:
//
//     import * as """ <> top <> """ from "./""" <> top <> """;
//     let value = """ <> top <> """.Convert.fromJson(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank
    converter

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromSet $ unionToSet unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNothing -> pure "'undefined'" -- we can have arrays of nothing
    IRNull -> pure "'undefined'"
    IRInteger -> pure "'number'"
    IRDouble -> pure "'number'"
    IRBool -> pure "'boolean'"
    IRString -> pure "'string'"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object('" <> name <> "')"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "map(" <> rendered <> ")"
    IRUnion types -> do
        renderedTyps <- mapM renderTypeMapType $ L.fromFoldable $ unionToSet types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: IRClassData -> String -> Doc Unit
renderTypeMapClass (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = lookupName name propertyNames
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        for_ resolved \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line $ "const typeMap = {"
    indent do
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderTypeMapClass cd className
    line $ "};"

converter :: Doc Unit
converter = do
    top <- getTopLevel >>= renderType
    line """export module Convert {
    let path = [];

    export function fromJson(json: string): TopLevel {
        return cast(JSON.parse(json), "TopLevel");
    }

    export function toJson(value: TopLevel): string {
        return JSON.stringify(value);
    }

    function cast<T>(obj: any, className: string): T {
        path = [];
        if (!isValid(object(className), obj)) {
            throw `Invalid value: obj${path.join("")}`
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        if      (typ.isUnion)  return isValidUnion(typ.typs, val);
        else if (typ.isArray)  return isValidArray(typ.typ, val);
        else if (typ.isMap)    return isValidMap(typ.typ, val);
        else if (typ.isObject) return isValidObject(typ.cls, val);
        else    /*primitive*/  return isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == 'undefined') return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidMap(typ: any, val: any): boolean {
        // all values in the map must be typ
        for (let prop in val) {
            path.push(`['${prop}']`);
            if (!isValid(typ, val[prop]))
                return false;
            path.pop();
        }
        return true;
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function map(typ: any) {
        return { typ, isMap: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line """
}
"""

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (for_, intercalate, maximum)

import Data.List as L

import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.Set (Set)
import Data.Set as S

import Data.String as Str
import Data.String.Util as Str

import Data.String.Regex as Rx
import Data.String.Regex.Flags as RxFlags
import Data.String.Util (camelCase, capitalize)

import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Utils (mapM)
import Data.Either as Either

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> s <> "_"
        , forbiddenNames: []
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

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

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    isLetterCharacter c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "any" -- we can have arrays of nothing
    IRNull -> pure "any"
    IRInteger -> pure "number"
    IRDouble -> pure "number"
    IRBool -> pure "boolean"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion types -> renderUnion $ unionToSet types

interfaceNamify :: String -> String
interfaceNamify = Str.camelCase >>> Str.capitalize >>> legalizeIdentifier

propertyNamify :: String -> String
propertyNamify s
    | Rx.test hasInternalSeparator s = "\"" <> s <> "\""
    | otherwise =
        case Str.charAt 0 s of
            Nothing -> "Empty"
            Just c | isStartCharacter c -> s
                   | otherwise -> "\"" <> s <> "\""

hasInternalSeparator :: Rx.Regex
hasInternalSeparator = unsafePartial $ Either.fromRight $ Rx.regex "[-. ]" RxFlags.noFlags

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    top <- getTopLevel >>= renderType
    line $ """// To parse this JSON data:
//
//     import * as """ <> top <> """ from "./""" <> top <> """;
//     let value = """ <> top <> """.Convert.fromJson(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank
    converter

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = markNullable (lookupName name propertyNames) typ
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ "export interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        let maxWidth = resolved <#> fst <#> Str.length # maximum
        for_ resolved \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

-- If this is a nullable, add a '?'
markNullable :: String -> IRType -> String
markNullable name (IRUnion unionRep) =
    case nullableFromSet $ unionToSet unionRep of
        Just _ -> name <> "?"
        _ -> name
markNullable name _ = name

renderTypeMapType :: IRType -> Doc String
renderTypeMapType = case _ of
    IRNothing -> pure "'undefined'" -- we can have arrays of nothing
    IRNull -> pure "'undefined'"
    IRInteger -> pure "'number'"
    IRDouble -> pure "'number'"
    IRBool -> pure "'boolean'"
    IRString -> pure "'string'"
    IRArray a -> do
        rendered <- renderTypeMapType a
        pure $ "array(" <> rendered <> ")"
    IRClass i -> do
        name <- lookupClassName i
        pure $ "object('" <> name <> "')"
    IRMap t -> do
        rendered <- renderTypeMapType t
        pure $ "{ [key: string]: " <> rendered <> " }"
    IRUnion types -> do
        renderedTyps <- mapM renderTypeMapType $ L.fromFoldable $ unionToSet types
        pure $ "union(" <> intercalate ", " renderedTyps <> ")"

renderTypeMapClass :: IRClassData -> String -> Doc Unit
renderTypeMapClass (IRClassData { names, properties }) className = do
    let propertyNames = transformNames (simpleNamer propertyNamify) (_ <> "_") (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties

    let resolver name typ = lookupName name propertyNames
    let resolvePropertyNameWithType (Tuple name typ) = Tuple (resolver name typ) typ

    line $ className <> ": {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = resolvePropertyNameWithType <$> props
        for_ resolved \(Tuple pname ptype) -> do
            rendered <- renderTypeMapType ptype
            line $ pname <> ": " <> rendered <> ","
    line "},"

typemap :: Doc Unit
typemap = do
    line $ "const typeMap = {"
    indent do
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderTypeMapClass cd className
    line $ "};"

converter :: Doc Unit
converter = do
    top <- getTopLevel >>= renderType
    line """export module Convert {
    let path = [];

    export function fromJson(json: string): TopLevel {
        return cast(JSON.parse(json), "TopLevel");
    }

    export function toJson(value: TopLevel): string {
        return JSON.stringify(value);
    }

    function cast<T>(obj: any, className: string): T {
        path = [];
        if (!isValid(object(className), obj)) {
            throw `Invalid value: obj${path.join("")}`
        }
        return obj;
    }

    function isValid(typ: any, val: any): boolean {
        if      (typ.isUnion)  return isValidUnion(typ.typs, val);
        else if (typ.isArray)  return isValidArray(typ.typ, val);
        else if (typ.isObject) return isValidObject(typ.cls, val);
        else    /*primitive*/  return isValidPrimitive(typ, val);
    }

    function isValidPrimitive(typ: string, val: any) {
        if (typ == 'undefined') return !val;
        return typ === typeof val;
    }

    function isValidUnion(typs: any[], val: any): boolean {
        // val must validate against one typ in typs
        return typs.find(typ => isValid(typ, val)) !== undefined;
    }

    function isValidArray(typ: any, val: any): boolean {
        // val must be an array with no invalid elements
        return Array.isArray(val) && !val.find((val, i) => {
            path.push(`[${i}]`);
            if (isValid(typ, val)) {
                path.pop();
            } else {
                return true;
            }
        });
    }

    function isValidObject(className: string, val: any): boolean {
        let typeRep = typeMap[className];

        for (let prop in typeRep) {
            path.push(`.${prop}`);
            if (!isValid(typeRep[prop], val[prop]))
                return false;
            path.pop();
        }

        return true;
    }

    function array(typ: any) {
        return { typ, isArray: true };
    }

    function union(...typs: any[]) {
        return { typs, isUnion: true };
    }

    function object(className: string) {
        return { cls: className, isObject: true };
    }
"""
    indent typemap
    line """
}
"""


Add instances for `MaybeT` and `WriterT`

module Control.Parallel.Class
  ( class MonadPar
  , par
  , parTraverse_
  , parTraverse
  , class MonadRace
  , stall
  , race
  , Parallel
  , parallel
  , runParallel
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Monad.Cont.Trans (ContT(..), runContT)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (REF, writeRef, readRef, newRef)
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)
import Control.Monad.Except.Trans (ExceptT(..))
import Control.Monad.Reader.Trans (ReaderT(..))
import Control.Monad.Maybe.Trans (MaybeT(..))
import Control.Monad.Writer.Trans (WriterT(..))
import Control.Plus (class Plus)

import Data.Foldable (class Foldable, traverse_)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid)
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(..))

-- | The `MonadPar` class abstracts over monads which support some notion of
-- | parallel composition.
-- |
-- | The `unit` and `par` functions should correspond to `pure` and `lift2` for
-- | some valid `Applicative` instance, but that instance need not arise from
-- | the underlying `Monad`.
class Monad m <= MonadPar m where
  par :: forall a b c. (a -> b -> c) -> m a -> m b -> m c

instance monadParContT :: MonadPar (ContT Unit (Eff eff)) where
  par f ca cb = ContT \k -> do
    ra <- unsafeWithRef (newRef Nothing)
    rb <- unsafeWithRef (newRef Nothing)

    runContT ca \a -> do
      mb <- unsafeWithRef (readRef rb)
      case mb of
        Nothing -> unsafeWithRef (writeRef ra (Just a))
        Just b -> k (f a b)

    runContT cb \b -> do
      ma <- unsafeWithRef (readRef ra)
      case ma of
        Nothing -> unsafeWithRef (writeRef rb (Just b))
        Just a -> k (f a b)

instance monadParExceptT :: MonadPar m => MonadPar (ExceptT e m) where
  par f (ExceptT e1) (ExceptT e2) = ExceptT (par (lift2 f) e1 e2)

instance monadParMaybeT :: MonadPar m => MonadPar (MaybeT m) where
  par f (MaybeT m1) (MaybeT m2) = MaybeT (par (lift2 f) m1 m2)

instance monadParReaderT :: MonadPar m => MonadPar (ReaderT e m) where
  par f (ReaderT r1) (ReaderT r2) = ReaderT \r -> par f (r1 r) (r2 r)

instance monadParWriterT :: (Monoid w, MonadPar m) => MonadPar (WriterT w m) where
  par f (WriterT w1) (WriterT w2) =
    WriterT $
      par (\(Tuple a wa) (Tuple b wb) → Tuple (f a b) (wa <> wb)) w1 w2

-- | Traverse a collection in parallel, discarding any results.
parTraverse_
  :: forall m t a b
   . (MonadPar m, Foldable t)
  => (a -> m b)
  -> t a
  -> m Unit
parTraverse_ f = runParallel <<< traverse_ (Parallel <<< f)

-- | Traverse a collection in parallel.
parTraverse
  :: forall m t a b
   . (MonadPar m, Traversable t)
  => (a -> m b)
  -> t a
  -> m (t b)
parTraverse f = runParallel <<< traverse (Parallel <<< f)

-- | The `MonadRace` class extends `MonadPar` to those monads which can be
-- | _raced_. That is, monads for which two computations can be
-- |
-- | The `stall` and `race` functions should satisfy the `Alternative` laws.
class MonadPar m <= MonadRace m where
  stall :: forall a. m a
  race :: forall a. m a -> m a -> m a

unsafeWithRef :: forall eff a. Eff (ref :: REF | eff) a -> Eff eff a
unsafeWithRef = unsafeInterleaveEff

instance monadRaceContT :: MonadRace (ContT Unit (Eff eff)) where
  stall = ContT \_ -> pure unit
  race c1 c2 = ContT \k -> do
    done <- unsafeWithRef (newRef false)

    runContT c1 \a -> do
      b <- unsafeWithRef (readRef done)
      if b
        then pure unit
        else do
          unsafeWithRef (writeRef done true)
          k a

    runContT c2 \a -> do
      b <- unsafeWithRef (readRef done)
      if b
        then pure unit
        else do
          unsafeWithRef (writeRef done true)
          k a

instance monadRaceExceptT :: MonadRace m => MonadRace (ExceptT e m) where
  stall = ExceptT stall
  race (ExceptT e1) (ExceptT e2) = ExceptT (race e1 e2)

instance monadRaceMaybeT :: MonadRace m => MonadRace (MaybeT m) where
  stall = MaybeT stall
  race (MaybeT m1) (MaybeT m2) = MaybeT (race m1 m2)

instance monadRaceReaderT :: MonadRace m => MonadRace (ReaderT e m) where
  stall = ReaderT \_ -> stall
  race (ReaderT r1) (ReaderT r2) = ReaderT \r -> race (r1 r) (r2 r)

instance monadRaceWriterT :: (Monoid w, MonadRace m) => MonadRace (WriterT w m) where
  stall = WriterT stall
  race (WriterT w1) (WriterT w2) = WriterT (race w1 w2)

-- | The `Parallel` type constructor provides `Applicative` and `Alternative`
-- | instances for any type monad with `MonadPar` and `MonadRace` instances
-- | respectively.
-- |
-- | - The definition of `apply` from `Apply` runs two computations in parallel and applies
-- |   a function when both complete.
-- | - The definition of `alt` from the `Alt` type class runs two computations in parallel
-- |   and returns the result of the computation which completes first.
-- |
-- | Parallel sections of code can be embedded in sequential code by using
-- | the `parallel` and `runParallel` functions:
-- |
-- | ```purescript
-- | loadModel :: ContT Unit (Eff (ajax :: AJAX)) Model
-- | loadModel = do
-- |   token <- authenticate
-- |   runParallel $
-- |     Model <$> parallel (get "/products/popular/" token)
-- |           <*> parallel (get "/categories/all" token)
-- | ```
newtype Parallel m a = Parallel (m a)

-- | Lift a computation to be run in parallel from a computation in the
-- | corresponding `Monad`.
parallel :: forall m a. m a -> Parallel m a
parallel = Parallel

-- | Lower a parallel computation to the underlying `Monad`, so that it may be
-- | used in a larger sequential computation.
runParallel :: forall m a. Parallel m a -> m a
runParallel (Parallel ma) = ma

instance functorParallel :: Functor m => Functor (Parallel m) where
  map f = parallel <<< map f <<< runParallel

instance applyParallel :: MonadPar m => Apply (Parallel m) where
  apply f a = parallel (par ($) (runParallel f) (runParallel a))

instance applicativeParallel :: MonadPar m => Applicative (Parallel m) where
  pure = parallel <<< pure

instance altParallel :: MonadRace m => Alt (Parallel m) where
  alt a b = parallel (runParallel a `race` runParallel b)

instance plusParallel :: MonadRace m => Plus (Parallel m) where
  empty = parallel stall

instance alternativeParallel :: MonadRace m => Alternative (Parallel m)

module Control.Parallel.Class
  ( class MonadPar
  , par
  , parTraverse_
  , parTraverse
  , class MonadRace
  , stall
  , race
  , Parallel
  , parallel
  , runParallel
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Apply (lift2)
import Control.Monad.Cont.Trans (ContT(..), runContT)
import Control.Monad.Except.Trans (ExceptT(..))
import Control.Monad.Reader.Trans (ReaderT(..))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (REF, writeRef, readRef, newRef)
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)
import Control.Plus (class Plus)
import Data.Maybe (Maybe(..))
import Data.Foldable (class Foldable, traverse_)
import Data.Traversable (class Traversable, traverse)

-- | The `MonadPar` class abstracts over monads which support some notion of
-- | parallel composition.
-- |
-- | The `unit` and `par` functions should correspond to `pure` and `lift2` for
-- | some valid `Applicative` instance, but that instance need not arise from
-- | the underlying `Monad`.
class Monad m <= MonadPar m where
  par :: forall a b c. (a -> b -> c) -> m a -> m b -> m c

-- | Traverse a collection in parallel, discarding any results.
parTraverse_
  :: forall m t a b
   . (MonadPar m, Foldable t)
  => (a -> m b)
  -> t a
  -> m Unit
parTraverse_ f = runParallel <<< traverse_ (Parallel <<< f)

-- | Traverse a collection in parallel.
parTraverse
  :: forall m t a b
   . (MonadPar m, Traversable t)
  => (a -> m b)
  -> t a
  -> m (t b)
parTraverse f = runParallel <<< traverse (Parallel <<< f)

-- | The `MonadRace` class extends `MonadPar` to those monads which can be
-- | _raced_. That is, monads for which two computations can be
-- |
-- | The `stall` and `race` functions should satisfy the `Alternative` laws.
class MonadPar m <= MonadRace m where
  stall :: forall a. m a
  race :: forall a. m a -> m a -> m a

unsafeWithRef :: forall eff a. Eff (ref :: REF | eff) a -> Eff eff a
unsafeWithRef = unsafeInterleaveEff

instance monadParContT :: MonadPar (ContT Unit (Eff eff)) where
  par f ca cb = ContT \k -> do
    ra <- unsafeWithRef (newRef Nothing)
    rb <- unsafeWithRef (newRef Nothing)

    runContT ca \a -> do
      mb <- unsafeWithRef (readRef rb)
      case mb of
        Nothing -> unsafeWithRef (writeRef ra (Just a))
        Just b -> k (f a b)

    runContT cb \b -> do
      ma <- unsafeWithRef (readRef ra)
      case ma of
        Nothing -> unsafeWithRef (writeRef rb (Just b))
        Just a -> k (f a b)

instance monadParExceptT :: MonadPar m => MonadPar (ExceptT e m) where
  par f (ExceptT e1) (ExceptT e2) = ExceptT (par (lift2 f) e1 e2)

instance monadParReaderT :: MonadPar m => MonadPar (ReaderT e m) where
  par f (ReaderT r1) (ReaderT r2) = ReaderT \r -> par f (r1 r) (r2 r)

instance monadRaceContT :: MonadRace (ContT Unit (Eff eff)) where
  stall = ContT \_ -> pure unit
  race c1 c2 = ContT \k -> do
    done <- unsafeWithRef (newRef false)

    runContT c1 \a -> do
      b <- unsafeWithRef (readRef done)
      if b
        then pure unit
        else do
          unsafeWithRef (writeRef done true)
          k a

    runContT c2 \a -> do
      b <- unsafeWithRef (readRef done)
      if b
        then pure unit
        else do
          unsafeWithRef (writeRef done true)
          k a

instance monadRaceExceptT :: MonadRace m => MonadRace (ExceptT e m) where
  stall = ExceptT stall
  race (ExceptT e1) (ExceptT e2) = ExceptT (race e1 e2)

instance monadRaceReaderT :: MonadRace m => MonadRace (ReaderT e m) where
  stall = ReaderT \_ -> stall
  race (ReaderT r1) (ReaderT r2) = ReaderT \r -> race (r1 r) (r2 r)

-- | The `Parallel` type constructor provides `Applicative` and `Alternative`
-- | instances for any type monad with `MonadPar` and `MonadRace` instances
-- | respectively.
-- |
-- | - The definition of `apply` from `Apply` runs two computations in parallel and applies
-- |   a function when both complete.
-- | - The definition of `alt` from the `Alt` type class runs two computations in parallel
-- |   and returns the result of the computation which completes first.
-- |
-- | Parallel sections of code can be embedded in sequential code by using
-- | the `parallel` and `runParallel` functions:
-- |
-- | ```purescript
-- | loadModel :: ContT Unit (Eff (ajax :: AJAX)) Model
-- | loadModel = do
-- |   token <- authenticate
-- |   runParallel $
-- |     Model <$> parallel (get "/products/popular/" token)
-- |           <*> parallel (get "/categories/all" token)
-- | ```
newtype Parallel m a = Parallel (m a)

-- | Lift a computation to be run in parallel from a computation in the
-- | corresponding `Monad`.
parallel :: forall m a. m a -> Parallel m a
parallel = Parallel

-- | Lower a parallel computation to the underlying `Monad`, so that it may be
-- | used in a larger sequential computation.
runParallel :: forall m a. Parallel m a -> m a
runParallel (Parallel ma) = ma

instance functorParallel :: Functor m => Functor (Parallel m) where
  map f = parallel <<< map f <<< runParallel

instance applyParallel :: MonadPar m => Apply (Parallel m) where
  apply f a = parallel (par ($) (runParallel f) (runParallel a))

instance applicativeParallel :: MonadPar m => Applicative (Parallel m) where
  pure = parallel <<< pure

instance altParallel :: MonadRace m => Alt (Parallel m) where
  alt a b = parallel (runParallel a `race` runParallel b)

instance plusParallel :: MonadRace m => Plus (Parallel m) where
  empty = parallel stall

instance alternativeParallel :: MonadRace m => Alternative (Parallel m)