scheduler: Support RESCIND events

scheduler: Support RESCIND events

module Mesos.Scheduler where

import Prelude
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, Error, throw, throwException)
import Control.Monad.Except (runExcept)
import Control.Monad.Error.Class (class MonadError, throwError)
import Control.Monad.State (execState, modify)
import Data.Either (either)
import Data.Foreign (Foreign, writeObject, toForeign, ForeignError(..))
import Data.Foreign.Class (class AsForeign, class IsForeign, readProp, write, (.=))
import Data.Foreign.Index (prop)
import Data.List.NonEmpty as NEL
import Data.Maybe (maybe')
import Data.Options (Options, (:=))
import Data.StrMap (lookup)
import Data.StrMap as SM
import Node.Encoding as Encoding
import Node.HTTP as HTTP
import Node.HTTP.Client (RequestHeaders(..), RequestOptions, Response, request, method, path, requestAsStream, responseHeaders, responseAsStream, statusCode, headers)
import Node.Process (stdout)
import Mesos.Raw (FrameworkID, FrameworkInfo, Offer, OfferID)
import Mesos.RecordIO (onRecordIO)
import Mesos.Util (jsonStringify, fromJSON, throwErrorS)
import Node.Stream (end, writeString, pipe)

newtype Subscribed = Subscribed { frameworkId :: FrameworkID
                                , heartbeatIntervalSeconds :: Int
                                }

instance subscribedAsForeign :: AsForeign Subscribed where
    write (Subscribed obj) = writeObject props where
        props = [ "framework_id" .= write obj.frameworkId
                , "heartbeat_interval_seconds" .= write obj.heartbeatIntervalSeconds
                ]

instance subscribedIsForeign :: IsForeign Subscribed where
    read value = do
        frameworkId <- readProp "framework_id" value
        heartbeatIntervalSeconds <- readProp "heartbeat_interval_seconds" value
        pure $ Subscribed { frameworkId: frameworkId
                          , heartbeatIntervalSeconds: heartbeatIntervalSeconds
                          }

newtype Subscribe = Subscribe { frameworkInfo :: FrameworkInfo
                              }

instance subscribeAsForeign :: AsForeign Subscribe where
    write (Subscribe obj) = writeObject props where
        props = [ "framework_info" .= write obj.frameworkInfo
                ]

-- | Represents a single RecordIO message
data Message = SubscribeMessage Subscribe
             | SubscribedMessage Subscribed
             | OffersMessage (Array Offer)
             | RescindMessage OfferID
             | HeartbeatMessage

-- | Utility for Writing a mesos subscribe-style recordio message
writeMessage :: forall a. (AsForeign a) => String -> String -> a -> Foreign
writeMessage t k d = writeObject props where
    props = [ "type" .= toForeign t
            , k .= write d
            ]

instance messageAsForeign :: AsForeign Message where
    write (SubscribeMessage subscribeInfo) = writeMessage "SUBSCRIBE" "subscribe" subscribeInfo
    write (SubscribedMessage subscribedInfo) = writeMessage "SUBSCRIBED" "subscribed" subscribedInfo
    write (OffersMessage offers) = writeMessage "OFFERS" "offers" offers
    write (RescindMessage offerId) = toForeign $
        { type: "RESCIND"
        , rescind: { offer_id: write offerId }
        }
    write HeartbeatMessage = toForeign $ { type: "HEARTBEAT" }

instance messageIsForeign :: IsForeign Message where
    read value = readProp "type" value >>= readMessageType where
        readMessageType "SUBSCRIBE" = throwError $ NEL.singleton $ ForeignError "Unimplemented!" -- TODO: implement
        readMessageType "SUBSCRIBED" = SubscribedMessage <$> readProp "subscribed" value
        readMessageType "OFFERS" = OffersMessage <$> readProp "offers" value
        readMessageType "RESCIND" = RescindMessage <$> (prop "rescind" value >>= readProp "offer_id")
        readMessageType "HEARTBEAT" = pure HeartbeatMessage
        readMessageType _ = throwError $ NEL.singleton $ ErrorAtProperty "type" (ForeignError "Unknown message type")

-- | List of common headers to include in a call to the mesos scheduler subscribe api
subscribeHeaders :: RequestHeaders
subscribeHeaders =
    SM.insert "Content-Type" "application/json" >>>
    SM.insert "Accept" "application/json" >>>
    SM.insert "Connection" "close" >>>
    RequestHeaders $
    SM.empty

-- | Make a call to `/api/v1/subscribe`, taking an action for each message
subscribe :: forall eff. Options RequestOptions
          -> Subscribe
          -> (Message -> Eff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit)
          -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit
subscribe userReqOpts subscribeInfo callback = do
    res <- makeAff \_ onS -> do
        req <- request reqOpts onS
        let reqStream = requestAsStream req
            reqData = jsonStringify <<< write $ SubscribeMessage subscribeInfo
        writeString reqStream Encoding.UTF8 reqData $ end reqStream (pure unit)
        pure unit
    handleRes res
    where
        handleRes :: Response -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit
        handleRes res
          | statusCode res == 200 = do
              mesosStreamId <- requiredHeader "mesos-stream-id"
              liftEff <<< log $ "mesos-stream-id: " <> mesosStreamId
              liftEff $ onRecordIO resStream throwException handleRecord
              where
                  handleRecord =
                      either (throw <<< show) callback <<<
                      runExcept <<<
                      fromJSON
                  headers = responseHeaders res
                  resStream = responseAsStream res
                  requiredHeader :: forall m. (MonadError Error m) => String -> m String
                  requiredHeader key =
                      maybe' (throwErrorS <<< e) pure $ lookup key headers where
                          e _ = "Header \"" <> key <> "\" not found"
          | otherwise = do
              liftEff do
                  log $ "Reponse status error (" <> (show <<< statusCode) res <> "):"
                  pipe (responseAsStream res) stdout
                  log ""
              pure unit
        reqOpts :: Options RequestOptions
        reqOpts = flip execState userReqOpts do
            overrideOption $ method := "POST"
            overrideOption $ path := "/api/v1/scheduler"
            overrideOption $ headers := subscribeHeaders
            where
                overrideOption o = modify $ flip (<>) o

module Mesos.Scheduler where

import Prelude
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, Error, throw, throwException)
import Control.Monad.Except (runExcept)
import Control.Monad.Error.Class (class MonadError, throwError)
import Control.Monad.State (execState, modify)
import Data.Either (either)
import Data.Foreign (Foreign, writeObject, toForeign, ForeignError(..))
import Data.Foreign.Class (class AsForeign, class IsForeign, readProp, write, (.=))
import Data.List.NonEmpty as NEL
import Data.Maybe (maybe')
import Data.Options (Options, (:=))
import Data.StrMap (lookup)
import Data.StrMap as SM
import Node.Encoding as Encoding
import Node.HTTP as HTTP
import Node.HTTP.Client (RequestHeaders(..), RequestOptions, Response, request, method, path, requestAsStream, responseHeaders, responseAsStream, statusCode, headers)
import Node.Process (stdout)
import Mesos.Raw (FrameworkID, FrameworkInfo, Offer)
import Mesos.RecordIO (onRecordIO)
import Mesos.Util (jsonStringify, fromJSON, throwErrorS)
import Node.Stream (end, writeString, pipe)

newtype Subscribed = Subscribed { frameworkId :: FrameworkID
                                , heartbeatIntervalSeconds :: Int
                                }

instance subscribedAsForeign :: AsForeign Subscribed where
    write (Subscribed obj) = writeObject props where
        props = [ "framework_id" .= write obj.frameworkId
                , "heartbeat_interval_seconds" .= write obj.heartbeatIntervalSeconds
                ]

instance subscribedIsForeign :: IsForeign Subscribed where
    read value = do
        frameworkId <- readProp "framework_id" value
        heartbeatIntervalSeconds <- readProp "heartbeat_interval_seconds" value
        pure $ Subscribed { frameworkId: frameworkId
                          , heartbeatIntervalSeconds: heartbeatIntervalSeconds
                          }

newtype Subscribe = Subscribe { frameworkInfo :: FrameworkInfo
                              }

instance subscribeAsForeign :: AsForeign Subscribe where
    write (Subscribe obj) = writeObject props where
        props = [ "framework_info" .= write obj.frameworkInfo
                ]

-- | Represents a single RecordIO message
data Message = SubscribeMessage Subscribe
             | SubscribedMessage Subscribed
             | OffersMessage (Array Offer)
             | HeartbeatMessage

-- | Utility for Writing a mesos subscribe-style recordio message
writeMessage :: forall a. (AsForeign a) => String -> String -> a -> Foreign
writeMessage t k d = writeObject props where
    props = [ "type" .= toForeign t
            , k .= write d
            ]

instance messageAsForeign :: AsForeign Message where
    write (SubscribeMessage subscribeInfo) = writeMessage "SUBSCRIBE" "subscribe" subscribeInfo
    write (SubscribedMessage subscribedInfo) = writeMessage "SUBSCRIBED" "subscribed" subscribedInfo
    write (OffersMessage offers) = writeMessage "OFFERS" "offers" offers
    write HeartbeatMessage = toForeign $ { type: "HEARTBEAT" }

instance messageIsForeign :: IsForeign Message where
    read value = readProp "type" value >>= readMessageType where
        readMessageType "SUBSCRIBE" = throwError $ NEL.singleton $ ForeignError "Unimplemented!" -- TODO: implement
        readMessageType "SUBSCRIBED" = SubscribedMessage <$> readProp "subscribed" value
        readMessageType "OFFERS" = OffersMessage <$> readProp "offers" value
        readMessageType "HEARTBEAT" = pure HeartbeatMessage
        readMessageType _ = throwError $ NEL.singleton $ ErrorAtProperty "type" (ForeignError "Unknown message type")

-- | List of common headers to include in a call to the mesos scheduler subscribe api
subscribeHeaders :: RequestHeaders
subscribeHeaders =
    SM.insert "Content-Type" "application/json" >>>
    SM.insert "Accept" "application/json" >>>
    SM.insert "Connection" "close" >>>
    RequestHeaders $
    SM.empty

-- | Make a call to `/api/v1/subscribe`, taking an action for each message
subscribe :: forall eff. Options RequestOptions
          -> Subscribe
          -> (Message -> Eff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit)
          -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit
subscribe userReqOpts subscribeInfo callback = do
    res <- makeAff \_ onS -> do
        req <- request reqOpts onS
        let reqStream = requestAsStream req
            reqData = jsonStringify <<< write $ SubscribeMessage subscribeInfo
        writeString reqStream Encoding.UTF8 reqData $ end reqStream (pure unit)
        pure unit
    handleRes res
    where
        handleRes :: Response -> Aff (avar :: AVAR, err :: EXCEPTION, http :: HTTP.HTTP, console :: CONSOLE | eff) Unit
        handleRes res
          | statusCode res == 200 = do
              mesosStreamId <- requiredHeader "mesos-stream-id"
              liftEff <<< log $ "mesos-stream-id: " <> mesosStreamId
              liftEff $ onRecordIO resStream throwException handleRecord
              where
                  handleRecord =
                      either (throw <<< show) callback <<<
                      runExcept <<<
                      fromJSON
                  headers = responseHeaders res
                  resStream = responseAsStream res
                  requiredHeader :: forall m. (MonadError Error m) => String -> m String
                  requiredHeader key =
                      maybe' (throwErrorS <<< e) pure $ lookup key headers where
                          e _ = "Header \"" <> key <> "\" not found"
          | otherwise = do
              liftEff do
                  log $ "Reponse status error (" <> (show <<< statusCode) res <> "):"
                  pipe (responseAsStream res) stdout
                  log ""
              pure unit
        reqOpts :: Options RequestOptions
        reqOpts = flip execState userReqOpts do
            overrideOption $ method := "POST"
            overrideOption $ path := "/api/v1/scheduler"
            overrideOption $ headers := subscribeHeaders
            where
                overrideOption o = modify $ flip (<>) o


Tidied up somewhat

Tidied up somewhat

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Quasar.Auth.Reauthentication
  (reauthentication, ReauthEffects, EIdToken, AuthenticationError, RequestIdTokenBus)
  where

import Data.Foldable as F
import Data.Foreign as Foreign
import Data.Traversable as T
import Data.Nullable as Nullable
import Control.Apply as Apply
import Control.Coroutine as Coroutine
import Control.Coroutine.Stalling (($$?))
import Control.Coroutine.Stalling as StallingCoroutine
import Control.Monad.Aff (Aff)
import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (AVar, AVAR, AffAVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus (BusRW, BusW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.Class (liftAff)
import Control.Parallel.Class (race)
import Control.Monad.Aff.Promise (Promise)
import Control.Monad.Aff.Promise as Promise
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (Ref, REF)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Except.Trans (ExceptT(..), runExceptT)
import Control.Monad.Rec.Class (forever)
import Control.UI.Browser as Browser
import SlamData.Prelude
import DOM (DOM)
import DOM.Node.Node as DOMNode
import DOM.Node.Document as DOMNodeDocument
import DOM.HTML as DOMHTML
import DOM.Node.Types (Node, Element)
import DOM.HTML.Types as DOMHTMLTypes
import DOM.HTML.Types (HTMLIFrameElement)
import DOM.HTML.Document as DOMHTMLDocument
import DOM.HTML.HTMLIFrameElement as DOMHTMLIFrameElement
import DOM.HTML.Window as DOMHTMLWindow
import OIDC.Aff as OIDCAff
import OIDC.Crypt as OIDCCrypt
import OIDC.Crypt (RSASIGNTIME)
import OIDC.Crypt.Types (IdToken(..), UnhashedNonce(..))
import OIDC.Crypt.JSONWebKey (JSONWebKey)
import Quasar.Advanced.Types as QAT
import SlamData.Config as Config
import SlamData.Quasar.Auth.IdTokenStorageEvents (getIdTokenStorageEvents)
import SlamData.Quasar.Auth.Keys as AuthKeys
import SlamData.Quasar.Auth.Store as AuthStore
import Text.Parsing.StringParser (ParseError(..))
import Utils.DOM as DOMUtils
import Utils.LocalStorage as LocalStorage
import Utils as Utils

data AuthenticationError
  = IdTokenInvalid
  | IdTokenUnavailable String
  | DOMError String
  | NoAuthProviderInLocalStorage

instance semigroupAuthenticationError ∷ Semigroup AuthenticationError where
  append x y = y

type RequestIdTokenBus = BusW (AVar EIdToken)

type EIdToken = Either AuthenticationError IdToken

type ReauthEffects eff =
  ( rsaSignTime ∷ RSASIGNTIME
  , avar ∷ AVAR
  , ref ∷ REF
  , dom ∷ DOM
  , random ∷ RANDOM
  | eff)

firstValueFromStallingProducer
  ∷ forall o eff
  . StallingCoroutine.StallingProducer o (Aff (avar ∷ AVAR | eff)) Unit
  → AffAVar eff o
firstValueFromStallingProducer producer = do
  firstValue ← AVar.makeVar
  Aff.forkAff
    $ StallingCoroutine.runStallingProcess
        (producer $$? (Coroutine.consumer \o → liftAff (AVar.putVar firstValue o) $> Just unit))
  AVar.takeVar firstValue

writeOnlyBus ∷ ∀ a. BusRW a → BusW a
writeOnlyBus = snd ∘ Bus.split

-- | Write an AVar to the returned bus to get a valid OIDC id token from the given provider.
reauthentication ∷ ∀ eff. Aff (ReauthEffects eff) RequestIdTokenBus
reauthentication = do
  stateRef ← liftEff $ Ref.newRef Nothing
  requestBus ← Bus.make
  Aff.forkAff $ forever (authenticate stateRef =<< Bus.read requestBus)
  pure $ writeOnlyBus requestBus

authenticate
  ∷ ∀ eff
  . Ref (Maybe (Promise EIdToken))
  → AVar EIdToken
  → Aff (ReauthEffects eff) Unit
authenticate stateRef replyAvar = do
  state ← liftEff $ Ref.readRef stateRef
  case state of
    Nothing → do
      idTokenPromise ← requestIdToken
      writeState $ Just idTokenPromise
      void $ Aff.forkAff $ reply idTokenPromise *> writeState Nothing
    Just idTokenPromise → do
      void $ Aff.forkAff $ reply idTokenPromise
  where
  writeState ∷ Maybe (Promise EIdToken) → Aff (ReauthEffects eff) Unit
  writeState = liftEff ∘ Ref.writeRef stateRef

  reply ∷ Promise EIdToken → Aff (ReauthEffects eff) Unit
  reply = AVar.putVar replyAvar <=< Promise.wait

requestReauthenticationSilently
  ∷ ∀ eff. Aff (ReauthEffects eff) EIdToken
requestReauthenticationSilently = do
  either (pure ∘ Left) await =<< request
  where
  await reauthenticationIFrameNode = do
    idToken ← retrieveIdTokenFromLSOnChange
    liftEff $ removeBodyChild reauthenticationIFrameNode
    pure idToken
  request =
    either
      (const $ pure $ Left $ NoAuthProviderInLocalStorage)
      (liftEff ∘ map (lmap DOMError) ∘ appendHiddenIFrameToBody)
      =<< requestReauthenticationURI OIDCAff.None

requestPromptedAuthentication ∷ ∀ eff. Aff (ReauthEffects eff) EIdToken
requestPromptedAuthentication =
  request *> retrieveIdTokenFromLSOnChange
  where
  request =
    either
      (const $ pure $ Left $ NoAuthProviderInLocalStorage)
      (map Right ∘ liftEff ∘ DOMUtils.openPopup)
      =<< requestReauthenticationURI OIDCAff.Login

appendHiddenIFrameToBody ∷ ∀ eff. String → Eff (ReauthEffects eff) (Either String Node)
appendHiddenIFrameToBody uri =
  either
    (pure ∘ Left)
    (appendIFrameToBody <=< configureHiddenIFrame uri)
    =<< createIFrameElement

configureHiddenIFrame
  ∷ ∀ eff
  . String
  → HTMLIFrameElement
  → Eff (ReauthEffects eff) HTMLIFrameElement
configureHiddenIFrame uri iFrameElement = do
  DOMHTMLIFrameElement.setSrc uri iFrameElement
  DOMHTMLIFrameElement.setWidth "0" iFrameElement
  DOMHTMLIFrameElement.setHeight "0" iFrameElement
  pure iFrameElement

appendIFrameToBody
  ∷ ∀ eff
  . HTMLIFrameElement
  → Eff (ReauthEffects eff) (Either String Node)
appendIFrameToBody iFrameElement =
  traverse (appendIFrameToNode iFrameElement) =<< getBodyNode

appendIFrameToNode
  ∷ ∀ eff
  . HTMLIFrameElement
  → Node
  → Eff (ReauthEffects eff) Node
appendIFrameToNode iFrameElement node =
  Utils.passover (flip DOMNode.appendChild node)
    $ DOMHTMLTypes.htmlElementToNode
    $ DOMHTMLTypes.htmlIFrameElementToHTMLElement iFrameElement

createIFrameElement ∷ ∀ eff. Eff (ReauthEffects eff) (Either String HTMLIFrameElement)
createIFrameElement =
  (lmap show ∘ DOMHTMLTypes.readHTMLIFrameElement ∘ Foreign.toForeign)
    <$> createElement "iframe"

createElement ∷ ∀ eff.  String → Eff (ReauthEffects eff) Element
createElement name =
  DOMNodeDocument.createElement name
    ∘ DOMHTMLTypes.htmlDocumentToDocument
    =<< DOMHTMLWindow.document
    =<< DOMHTML.window

removeBodyChild ∷ ∀ eff.  Node → Eff (ReauthEffects eff) (Either String Node)
removeBodyChild child =
  either (pure ∘ Left) (map Right ∘ DOMNode.removeChild child) =<< getBodyNode

getBodyNode ∷ ∀ eff. Eff (ReauthEffects eff) (Either String Node)
getBodyNode =
  toEitherStringNode
    <$> (DOMHTMLDocument.body =<< DOMHTMLWindow.document =<< DOMHTML.window)
  where
  toEitherStringNode =
    maybe
      (Left "Couldn't find body element.")
      Right
      ∘ map DOMHTMLTypes.htmlElementToNode
      ∘ Nullable.toMaybe

requestIdToken ∷ ∀ eff. Aff (ReauthEffects eff) (Promise EIdToken)
requestIdToken = Promise.defer do
  startIdToken ← retrieveIdTokenFromLS
  provider ← liftEff $ retrieveProvider
  idToken ← case startIdToken of
    Left (IdTokenUnavailable _) | isJust provider →
      runExceptT
        $ ExceptT requestReauthenticationSilently
        <|> ExceptT requestPromptedAuthentication
    Left IdTokenInvalid →
      requestReauthenticationSilently
    _ ->
      pure startIdToken
  either (const $ liftEff AuthStore.clearProvider) (const $ pure unit) idToken
  pure idToken

retrieveIdTokenFromLSOnChange ∷ ∀ eff. Aff (ReauthEffects eff) EIdToken
retrieveIdTokenFromLSOnChange =
  race
    (validTokenIdFromIdTokenStorageEvent
      =<< firstValueFromStallingProducer
      =<< liftEff getIdTokenStorageEvents)
    (Aff.later'
      Config.reauthenticationTimeout
      $ pure $ Left $ IdTokenUnavailable "No id token received before timeout.")

validTokenIdFromIdTokenStorageEvent
  ∷ ∀ eff
  . LocalStorage.StorageEvent (Either String IdToken)
  → Aff (ReauthEffects eff) EIdToken
validTokenIdFromIdTokenStorageEvent =
  either (pure ∘ Left) verify ∘ lmap IdTokenUnavailable ∘ _.newValue

retrieveIdTokenFromLS ∷ ∀ eff. Aff (ReauthEffects eff) EIdToken
retrieveIdTokenFromLS =
  either
    (pure ∘ Left ∘ IdTokenUnavailable)
    verify
    =<< (flip bind (map IdToken) <$> retrieveRaw)
  where
  retrieveRaw ∷ Aff (ReauthEffects eff) (Either String (Either String String))
  retrieveRaw = LocalStorage.getLocalStorage AuthKeys.idTokenLocalStorageKey

retrieveProviderRFromLS ∷ ∀ eff. Eff (ReauthEffects eff) (Either String QAT.ProviderR)
retrieveProviderRFromLS =
  map QAT.runProvider <$> LocalStorage.getLocalStorage AuthKeys.providerLocalStorageKey

appendAuthPath ∷ String → String
appendAuthPath s = (s <> _) Config.redirectURIString

runParseError ∷ ParseError → String
runParseError (ParseError s) = s

requestReauthenticationURI
  ∷ ∀ eff
  . OIDCAff.Prompt
  → Aff (ReauthEffects eff) (Either String String)
requestReauthenticationURI prompt =
  liftEff do
    redirectUri ← appendAuthPath <$> Browser.locationString
    runExceptT
      $ ExceptT ∘ request redirectUri
      =<< ExceptT retrieveProviderRFromLS
  where
  request redirectUri =
    map (bimap runParseError id)
      ∘ flip (OIDCAff.requestAuthenticationURI prompt) redirectUri

verify ∷ ∀ eff. IdToken → Aff (ReauthEffects eff) EIdToken
verify idToken = do
  verified ← liftEff $ verifyBoolean idToken
  if verified
    then pure $ Right idToken
    else pure $ Left IdTokenInvalid

verifyBoolean ∷ ∀ eff. IdToken → Eff (ReauthEffects eff) Boolean
verifyBoolean idToken = do
  jwks ← map (fromMaybe []) retrieveJwks
  F.or <$> T.traverse (verifyBooleanWithJwk idToken) jwks

verifyBooleanWithJwk ∷ ∀ eff. IdToken → JSONWebKey → Eff (ReauthEffects eff) Boolean
verifyBooleanWithJwk idToken jwk = do
  issuer ← retrieveIssuer
  clientId ← retrieveClientID
  nonce ← retrieveNonce
  fromMaybe (pure false)
    $ Apply.lift4 (OIDCCrypt.verifyIdToken idToken) issuer clientId nonce (Just jwk)

retrieveProvider ∷ ∀ eff. Eff (ReauthEffects eff) (Maybe QAT.Provider)
retrieveProvider =
  LocalStorage.getLocalStorage AuthKeys.providerLocalStorageKey <#> fromEither

retrieveProviderR ∷ ∀ eff. Eff (ReauthEffects eff) (Maybe QAT.ProviderR)
retrieveProviderR = map QAT.runProvider <$> retrieveProvider

retrieveIssuer ∷ ∀ eff. Eff (ReauthEffects eff) (Maybe OIDCCrypt.Issuer)
retrieveIssuer =
  map (_.issuer <<< _.openIDConfiguration) <$> retrieveProviderR

retrieveJwks ∷ ∀ eff. Eff (ReauthEffects eff) (Maybe (Array JSONWebKey))
retrieveJwks =
  map (_.jwks <<< _.openIDConfiguration) <$> retrieveProviderR

retrieveClientID ∷ ∀ eff. Eff (ReauthEffects eff) (Maybe OIDCCrypt.ClientID)
retrieveClientID =
  map _.clientID <$> retrieveProviderR

retrieveNonce ∷ ∀ eff. Eff (ReauthEffects eff) (Maybe UnhashedNonce)
retrieveNonce =
  LocalStorage.getLocalStorage AuthKeys.nonceLocalStorageKey <#>
    either (\_ → Nothing) (Just <<< UnhashedNonce)

ifFalseLeft ∷ ∀ a b. a → b → Boolean → Either a b
ifFalseLeft x y boolean = if boolean then Right y else Left x

fromEither ∷ ∀ a b. Either a b → Maybe b
fromEither = either (\_ → Nothing) (Just)

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Quasar.Auth.Reauthentication
  (reauthentication, ReauthEffects, EIdToken, AuthenticationError, RequestIdTokenBus)
  where

import Data.Foldable as F
import Data.Foreign as Foreign
import Data.Traversable as T
import Data.Nullable as Nullable
import Control.Apply as Apply
import Control.Coroutine as Coroutine
import Control.Coroutine.Stalling (($$?))
import Control.Coroutine.Stalling as StallingCoroutine
import Control.Monad.Aff (Aff)
import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (AVar, AVAR, AffAVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus (BusRW, BusW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.Class (liftAff)
import Control.Parallel.Class (race)
import Control.Monad.Aff.Promise (Promise)
import Control.Monad.Aff.Promise as Promise
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (Ref, REF)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Except.Trans (ExceptT(..), runExceptT)
import Control.Monad.Rec.Class (forever)
import Control.UI.Browser as Browser
import SlamData.Prelude
import DOM (DOM)
import DOM.Node.Node as DOMNode
import DOM.Node.Document as DOMNodeDocument
import DOM.HTML as DOMHTML
import DOM.Node.Types as DOMNodeTypes
import DOM.HTML.Types as DOMHTMLTypes
import DOM.HTML.Document as DOMHTMLDocument
import DOM.HTML.HTMLIFrameElement as DOMHTMLIFrameElement
import DOM.HTML.Window as DOMHTMLWindow
import OIDC.Aff as OIDCAff
import OIDC.Crypt as OIDCCrypt
import OIDC.Crypt (RSASIGNTIME)
import OIDC.Crypt.Types (IdToken(..), UnhashedNonce(..))
import OIDC.Crypt.JSONWebKey (JSONWebKey)
import Quasar.Advanced.Types as QAT
import SlamData.Config as Config
import SlamData.Quasar.Auth.IdTokenStorageEvents (getIdTokenStorageEvents)
import SlamData.Quasar.Auth.Keys as AuthKeys
import SlamData.Quasar.Auth.Store as AuthStore
import Text.Parsing.StringParser (ParseError(..))
import Utils.DOM as DOMUtils
import Utils.LocalStorage as LocalStorage
import Utils as Utils

data AuthenticationError =
  IdTokenInvalid | IdTokenUnavailable String | DOMError String | NoAuthProviderInLocalStorage

instance semigroupAuthenticationError ∷ Semigroup AuthenticationError where
  append x y = y

type RequestIdTokenBus = BusW (AVar EIdToken)

type EIdToken = Either AuthenticationError IdToken

type ReauthEffects eff =
  ( rsaSignTime ∷ RSASIGNTIME
  , avar ∷ AVAR
  , ref ∷ REF
  , dom ∷ DOM
  , random ∷ RANDOM
  | eff)

firstValueFromStallingProducer
  ∷ forall o eff
  . StallingCoroutine.StallingProducer o (Aff (avar ∷ AVAR | eff)) Unit
  → AffAVar eff o
firstValueFromStallingProducer producer = do
  firstValue ← AVar.makeVar
  Aff.forkAff
    $ StallingCoroutine.runStallingProcess
        (producer $$? (Coroutine.consumer \o → liftAff (AVar.putVar firstValue o) $> Just unit))
  AVar.takeVar firstValue

writeOnlyBus ∷ ∀ a. BusRW a → BusW a
writeOnlyBus = snd ∘ Bus.split

-- | Write an AVar to the returned bus to get a valid OIDC id token from the given provider.
reauthentication ∷ ∀ eff. Aff (ReauthEffects eff) RequestIdTokenBus
reauthentication = do
  stateRef ← liftEff $ Ref.newRef Nothing
  requestBus ← Bus.make
  Aff.forkAff $ forever (authenticate stateRef =<< Bus.read requestBus)
  pure $ writeOnlyBus requestBus

authenticate
  ∷ ∀ eff
  . Ref (Maybe (Promise EIdToken))
  → AVar EIdToken
  → Aff (ReauthEffects eff) Unit
authenticate stateRef replyAvar = do
  state ← liftEff $ Ref.readRef stateRef
  case state of
    Nothing → do
      idTokenPromise ← requestIdToken
      writeState $ Just idTokenPromise
      void $ Aff.forkAff $ reply idTokenPromise *> writeState Nothing
    Just idTokenPromise → do
      void $ Aff.forkAff $ reply idTokenPromise
  where
  writeState ∷ Maybe (Promise EIdToken) → Aff (ReauthEffects eff) Unit
  writeState = liftEff ∘ Ref.writeRef stateRef

  reply ∷ Promise EIdToken → Aff (ReauthEffects eff) Unit
  reply = AVar.putVar replyAvar <=< Promise.wait

  requestReauthenticationSilently ∷ Aff (ReauthEffects eff) (Either AuthenticationError DOMNodeTypes.Node)
  requestReauthenticationSilently =
    either
      (const $ pure $ Left $ NoAuthProviderInLocalStorage)
      (liftEff ∘ map (lmap DOMError) ∘ appendHiddenIFrameToBody)
      =<< requestReauthenticationURI OIDCAff.None

  requestPromptedAuthentication ∷ Aff (ReauthEffects eff) (Either AuthenticationError Unit)
  requestPromptedAuthentication =
    either
      (const $ pure $ Left $ NoAuthProviderInLocalStorage)
      (map Right ∘ liftEff ∘ DOMUtils.openPopup)
      =<< requestReauthenticationURI OIDCAff.Login

  appendHiddenIFrameToBody ∷ String → Eff (ReauthEffects eff) (Either String DOMNodeTypes.Node)
  appendHiddenIFrameToBody uri =
    either
      (pure ∘ Left)
      (appendIFrameToBody <=< configureHiddenIFrame uri)
      =<< createIFrameElement

  configureHiddenIFrame uri iFrameElement = do
    DOMHTMLIFrameElement.setSrc uri iFrameElement
    DOMHTMLIFrameElement.setWidth "0" iFrameElement
    DOMHTMLIFrameElement.setHeight "0" iFrameElement
    pure iFrameElement

  appendIFrameToBody iFrameElement =
    traverse (appendIFrameToNode iFrameElement) =<< getBodyNode

  appendIFrameToNode iFrameElement node =
    Utils.passover (flip DOMNode.appendChild node)
      $ DOMHTMLTypes.htmlElementToNode
      $ DOMHTMLTypes.htmlIFrameElementToHTMLElement iFrameElement

  createIFrameElement ∷ Eff (ReauthEffects eff) (Either String DOMHTMLTypes.HTMLIFrameElement)
  createIFrameElement =
    (lmap show ∘ DOMHTMLTypes.readHTMLIFrameElement ∘ Foreign.toForeign)
      <$> createElement "iframe"

  createElement ∷ String → Eff (ReauthEffects eff) DOMNodeTypes.Element
  createElement name =
    DOMNodeDocument.createElement name
      ∘ DOMHTMLTypes.htmlDocumentToDocument
      =<< DOMHTMLWindow.document
      =<< DOMHTML.window

  removeBodyChild ∷ DOMNodeTypes.Node → Eff (ReauthEffects eff) (Either String DOMNodeTypes.Node)
  removeBodyChild child = either (pure ∘ Left) (map Right ∘ DOMNode.removeChild child) =<< getBodyNode

  getBodyNode ∷ Eff (ReauthEffects eff) (Either String DOMNodeTypes.Node)
  getBodyNode =
    (maybe (Left "Couldn't find body element.") Right ∘ map DOMHTMLTypes.htmlElementToNode ∘ Nullable.toMaybe)
      <$> (DOMHTMLDocument.body =<< DOMHTMLWindow.document =<< DOMHTML.window)

  requestIdToken ∷ Aff (ReauthEffects eff) (Promise EIdToken)
  requestIdToken = Promise.defer do
    idToken ← retrieveIdTokenFromLS
    provider ← liftEff $ retrieveProvider
    (case idToken of
      Left (IdTokenUnavailable _) | isJust provider →
        runExceptT
          $ ExceptT (either (pure ∘ Left) reauthenticate =<< requestReauthenticationSilently)
          <|> ExceptT (requestPromptedAuthentication *> retrieveIdTokenFromLSOnChange)
      Left IdTokenInvalid →
        (either (pure ∘ Left) reauthenticate =<< requestReauthenticationSilently)
      _ ->
        pure idToken) >>= Utils.passover (either (const $ liftEff AuthStore.clearProvider) (const $ pure unit))

  reauthenticate ∷ DOMNodeTypes.Node → Aff (ReauthEffects eff) EIdToken
  reauthenticate iFrameNode =
    -- Failures to remove the IFrame are not returned.
    Utils.passover (const $ liftEff $ removeBodyChild iFrameNode) =<< retrieveIdTokenFromLSOnChange

  retrieveIdTokenFromLSOnChange ∷ Aff (ReauthEffects eff) EIdToken
  retrieveIdTokenFromLSOnChange =
    race
      (validTokenIdFromIdTokenStorageEvent =<< firstValueFromStallingProducer =<< liftEff getIdTokenStorageEvents)
      (Aff.later' Config.reauthenticationTimeout $ pure $ Left $ IdTokenUnavailable "No id token received before timeout.")

  validTokenIdFromIdTokenStorageEvent ∷ LocalStorage.StorageEvent (Either String IdToken) -> Aff (ReauthEffects eff) EIdToken
  validTokenIdFromIdTokenStorageEvent = either (pure ∘ Left) verify ∘ lmap IdTokenUnavailable ∘ _.newValue

  retrieveIdTokenFromLS ∷ Aff (ReauthEffects eff) EIdToken
  retrieveIdTokenFromLS =
    either (pure ∘ Left ∘ IdTokenUnavailable) verify =<< (flip bind (map IdToken) <$> retrieveRaw)
    where
    retrieveRaw ∷ Aff (ReauthEffects eff) (Either String (Either String String))
    retrieveRaw = LocalStorage.getLocalStorage AuthKeys.idTokenLocalStorageKey

  retrieveProviderRFromLS ∷ Eff (ReauthEffects eff) (Either String QAT.ProviderR)
  retrieveProviderRFromLS =
    map QAT.runProvider <$> LocalStorage.getLocalStorage AuthKeys.providerLocalStorageKey

  appendAuthPath ∷ String → String
  appendAuthPath s = (s <> _) Config.redirectURIString

  runParseError ∷ ParseError → String
  runParseError (ParseError s) = s

  requestReauthenticationURI ∷ OIDCAff.Prompt → Aff (ReauthEffects eff) (Either String String)
  requestReauthenticationURI prompt =
    liftEff do
      redirectUri ← appendAuthPath <$> Browser.locationString
      runExceptT
        $ (ExceptT ∘ map (bimap runParseError id) ∘ flip (OIDCAff.requestAuthenticationURI prompt) redirectUri)
        =<< ExceptT retrieveProviderRFromLS

  verify ∷ IdToken → Aff (ReauthEffects eff) EIdToken
  verify idToken = do
    verified ← liftEff $ verifyBoolean idToken
    if verified
      then pure $ Right idToken
      else pure $ Left IdTokenInvalid

  verifyBoolean ∷ IdToken → Eff (ReauthEffects eff) Boolean
  verifyBoolean idToken = do
    jwks ← map (fromMaybe []) retrieveJwks
    F.or <$> T.traverse (verifyBooleanWithJwk idToken) jwks

  verifyBooleanWithJwk ∷ IdToken → JSONWebKey → Eff (ReauthEffects eff) Boolean
  verifyBooleanWithJwk idToken jwk = do
    issuer ← retrieveIssuer
    clientId ← retrieveClientID
    nonce ← retrieveNonce
    fromMaybe (pure false)
      $ Apply.lift4 (OIDCCrypt.verifyIdToken idToken) issuer clientId nonce (Just jwk)

  retrieveProvider =
    LocalStorage.getLocalStorage AuthKeys.providerLocalStorageKey <#> fromEither

  retrieveProviderR = map QAT.runProvider <$> retrieveProvider

  retrieveIssuer =
    map (_.issuer <<< _.openIDConfiguration) <$> retrieveProviderR

  retrieveJwks =
    map (_.jwks <<< _.openIDConfiguration) <$> retrieveProviderR

  retrieveClientID =
    map _.clientID <$> retrieveProviderR

  retrieveNonce =
    LocalStorage.getLocalStorage AuthKeys.nonceLocalStorageKey <#>
      either (\_ → Nothing) (Just <<< UnhashedNonce)

  ifFalseLeft ∷ ∀ a b. a → b → Boolean → Either a b
  ifFalseLeft x y boolean = if boolean then Right y else Left x

  fromEither ∷ ∀ a b. Either a b → Maybe b
  fromEither = either (\_ → Nothing) (Just)


Use `forall proxy. proxy sym` to make current SProxy code still compile

module Data.Symbol
  ( class IsSymbol
  , reflectSymbol
  , reifySymbol
  , SProxy(..)
  ) where

import Type.Proxy (Proxy(..))

-- | A value-level proxy for a type-level symbol.
data SProxy (sym :: Symbol) = SProxy

-- | A class for known symbols
class IsSymbol (sym :: Symbol) where
  reflectSymbol :: forall proxy. proxy sym -> String

-- local definition for use in `reifySymbol`
foreign import unsafeCoerce :: forall a b. a -> b

reifySymbol :: forall r. String -> (forall sym. IsSymbol sym => Proxy sym -> r) -> r
reifySymbol s f = coerce f { reflectSymbol: \_ -> s } Proxy where
  coerce
    :: (forall sym1. IsSymbol sym1              => Proxy sym1 -> r)
    -> { reflectSymbol :: Proxy "" -> String } -> Proxy ""   -> r
  coerce = unsafeCoerce

module Data.Symbol
  ( class IsSymbol
  , reflectSymbol
  , reifySymbol
  , SProxy(..)
  ) where

import Type.Proxy (Proxy(..))

-- | A value-level proxy for a type-level symbol.
data SProxy (sym :: Symbol) = SProxy

-- | A class for known symbols
class IsSymbol (sym :: Symbol) where
  reflectSymbol :: Proxy sym -> String

-- local definition for use in `reifySymbol`
foreign import unsafeCoerce :: forall a b. a -> b

reifySymbol :: forall r. String -> (forall sym. IsSymbol sym => Proxy sym -> r) -> r
reifySymbol s f = coerce f { reflectSymbol: \_ -> s } Proxy where
  coerce
    :: (forall sym1. IsSymbol sym1              => Proxy sym1 -> r)
    -> { reflectSymbol :: Proxy "" -> String } -> Proxy ""   -> r
  coerce = unsafeCoerce


Whitespace

Whitespace

-- | This module provides a low-level wrapper for the Node Stream API.

module Node.Stream
  ( Stream()
  , Read()
  , Readable()
  , Write()
  , Writable()
  , Duplex()
  , setEncoding
  , onData
  , onEnd
  , onClose
  , onError
  , resume
  , pause
  , isPaused
  , pipe
  , write
  , writeString
  , cork
  , uncork
  , setDefaultEncoding
  , end
  ) where

import Prelude

import Node.Encoding

import Control.Monad.Eff

-- | A stream.
-- |
-- | The type arguments track, in order:
-- |
-- | - Whether reading and/or writing from/to the stream are allowed.
-- | - Effects associated with reading/writing from/to this stream.
-- | - The type of chunks which will be read from/written to this stream (`String` or `Buffer`).
foreign import data Stream :: # * -> # ! -> * -> *

-- | A phantom type associated with _readable streams_.
data Read

-- | A readable stream.
type Readable r = Stream (read :: Read | r)

-- | A phantom type associated with _writable streams_.
data Write

-- | A writable stream.
type Writable r = Stream (write :: Write | r)

-- | A duplex (readable _and_ writable stream)
type Duplex = Stream (read :: Read, write :: Write)

foreign import setEncodingImpl :: forall w eff. Readable w eff String -> String -> Eff eff Unit

-- | Set the encoding used to read chunks from the stream.
setEncoding :: forall w eff. Readable w eff String -> Encoding -> Eff eff Unit
setEncoding r enc = setEncodingImpl r (show enc)

-- | Listen for `data` events.
foreign import onData :: forall w eff a. Readable w eff a -> (a -> Eff eff Unit) -> Eff eff Unit

-- | Listen for `end` events.
foreign import onEnd :: forall w eff a. Readable w eff a -> Eff eff Unit -> Eff eff Unit

-- | Listen for `close` events.
foreign import onClose :: forall w eff a. Readable w eff a -> Eff eff Unit -> Eff eff Unit

-- | Listen for `error` events.
foreign import onError :: forall w eff a. Readable w eff a -> Eff eff Unit -> Eff eff Unit

-- | Resume reading from the stream.
foreign import resume :: forall w eff a. Readable w eff a -> Eff eff Unit

-- | Pause reading from the stream.
foreign import pause :: forall w eff a. Readable w eff a -> Eff eff Unit

-- | Check whether or not a stream is paused for reading.
foreign import isPaused :: forall w eff a. Readable w eff a -> Eff eff Boolean

-- | Read chunks from a readable stream and write them to a writable stream.
foreign import pipe :: forall r w eff a. Readable w eff a -> Writable r eff a -> Eff eff (Writable r eff a)

-- | Write a chunk to a writable stream.
foreign import write :: forall r eff a. Writable r eff String -> a -> Eff eff Unit -> Eff eff Boolean

foreign import writeStringImpl :: forall r eff. Writable r eff String -> String -> String -> Eff eff Unit -> Eff eff Boolean

-- | Write a string in the specified encoding to a writable stream.
writeString :: forall r eff. Writable r eff String -> Encoding -> String -> Eff eff Unit -> Eff eff Boolean
writeString w enc = writeStringImpl w (show enc)

-- | Force buffering of writes.
foreign import cork :: forall r eff a. Writable r eff a -> Eff eff Unit

-- | Flush buffered data.
foreign import uncork :: forall r eff a. Writable r eff a -> Eff eff Unit

foreign import setDefaultEncodingImpl :: forall r eff. Writable r eff String -> String -> Eff eff Unit

-- | Set the default encoding used to write chunks to the stream.
setDefaultEncoding :: forall r eff. Writable r eff String -> Encoding -> Eff eff Unit
setDefaultEncoding r enc = setDefaultEncodingImpl r (show enc)

-- | End writing data to the stream.
foreign import end :: forall r eff a. Writable r eff a -> Eff eff Unit -> Eff eff Unit


rename log => logF, info => infoF, warn => warnF, error => errorF so name clashing doesn't occur with standard Console module

--| Support for logging native javascript objects to the console using
--| the `AsForeign` class.
module Control.Monad.Eff.Console.Foreign
       ( logF
       , infoF
       , warnF
       , errorF) where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Semigroupoid ((<<<))
import Data.Foreign (Foreign)
import Data.Foreign.Class (class AsForeign, write)
import Data.Unit (Unit)

-- | Write a message to the native console using `console.log`.
logF :: forall a e. AsForeign a => a -> Eff (console :: CONSOLE | e) Unit
logF = _log <<< write

-- | Write an info message to the native console using `console.info`.
infoF :: forall a e. AsForeign a => a -> Eff (console :: CONSOLE | e) Unit
infoF = _info <<< write

-- | Write a warning message to the native console using `console.warn`.
warnF :: forall a e. AsForeign a => a -> Eff (console :: CONSOLE | e) Unit
warnF = _warn <<< write

-- | Write an error message to the native console using `console.error`.
errorF :: forall a e. AsForeign a => a -> Eff (console :: CONSOLE | e) Unit
errorF = _error <<< write

foreign import _log :: forall e. Foreign -> Eff (console :: CONSOLE | e) Unit
foreign import _info :: forall e. Foreign -> Eff (console :: CONSOLE | e) Unit
foreign import _warn :: forall e. Foreign -> Eff (console :: CONSOLE | e) Unit
foreign import _error :: forall e. Foreign -> Eff (console :: CONSOLE | e) Unit

--| Support for logging native javascript objects to the console using
--| the `AsForeign` class.
module Control.Monad.Eff.Console.Foreign
       ( log
       , info
       , warn
       , error) where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Semigroupoid ((<<<))
import Data.Foreign (Foreign)
import Data.Foreign.Class (class AsForeign, write)
import Data.Unit (Unit)

-- | Write a message to the native console using `console.log`.
log :: forall a e. AsForeign a => a -> Eff (console :: CONSOLE | e) Unit
log = _log <<< write

-- | Write an info message to the native console using `console.info`.
info :: forall a e. AsForeign a => a -> Eff (console :: CONSOLE | e) Unit
info = _info <<< write

-- | Write a warning message to the native console using `console.warn`.
warn :: forall a e. AsForeign a => a -> Eff (console :: CONSOLE | e) Unit
warn = _warn <<< write

-- | Write an error message to the native console using `console.error`.
error :: forall a e. AsForeign a => a -> Eff (console :: CONSOLE | e) Unit
error = _error <<< write

foreign import _log :: forall e. Foreign -> Eff (console :: CONSOLE | e) Unit
foreign import _info :: forall e. Foreign -> Eff (console :: CONSOLE | e) Unit
foreign import _warn :: forall e. Foreign -> Eff (console :: CONSOLE | e) Unit
foreign import _error :: forall e. Foreign -> Eff (console :: CONSOLE | e) Unit


Correct definition of `Tree`

Correct definition of `Tree`

module AST where

import Prelude
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe)
import Data.Tuple (Tuple)

-- | Operators
-- |
-- | Primitive infix operators that are evaluated directly by the `Evaluator`.
-- | (`Colon` is `Cons` but clashes with `Data.List.Cons`)
data Op = Composition
        | Power
        | Mul
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar
        | InfixFunc String

derive instance eqOp :: Eq Op

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Add    -> "Add"
    Sub    -> "Sub"
    Colon  -> "Colon"
    Append -> "Append"
    Equ    -> "Equ"
    Neq    -> "Neq"
    Lt     -> "Lt"
    Leq    -> "Leq"
    Gt     -> "Gt"
    Geq    -> "Geq"
    And    -> "And"
    Or     -> "Or"
    Dollar -> "Dollar"
    InfixFunc name -> "(InfixFunc " <> name <> ")"

pPrintOp :: Op -> String
pPrintOp op = case op of
  Composition -> "."
  Power  -> "^"
  Mul    -> "*"
  Add    -> "+"
  Sub    -> "-"
  Colon  -> ":"
  Append -> "++"
  Equ    -> "=="
  Neq    -> "/="
  Lt     -> "<"
  Leq    -> "<="
  Gt     -> ">"
  Geq    -> ">="
  And    -> "&&"
  Or     -> "||"
  Dollar -> "$"
  InfixFunc n -> "`" <> n <> "`"

-- | Atoms
-- |
-- | Primitive data types
data Atom = AInt Int
          | Bool Boolean
          | Char String
          | Name String

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

-- | Expressions
-- |
-- | The basic expressions the `Parser` and `Evaluator` recognize.

data Tree a b c =
    Atom      c a
  | List      c (List (Tree a b c))
  | NTuple    c (List (Tree a b c))
  | Binary    c Op (Tree a b c) (Tree a b c)
  | Unary     c Op (Tree a b c)
  | SectL     c (Tree a b c) Op
  | SectR     c Op (Tree a b c)
  | PrefixOp  c Op
  | IfExpr    c (Tree a b c) (Tree a b c) (Tree a b c)
  | ArithmSeq c (Tree a b c) (Maybe (Tree a b c)) (Maybe (Tree a b c))
  | LetExpr   c (List (Tuple b (Tree a b c))) (Tree a b c)
  | Lambda    c (List b) (Tree a b c)
  | App       c (Tree a b c) (List (Tree a b c))
  | ListComp  c (Tree a b c) (List (Qual b (Tree a b c)))

derive instance eqTree :: (Eq a, Eq b, Eq c) => Eq (Tree a b c)

type Expr = Tree Atom Binding Unit

data Qual b e = Gen b e | Let b e | Guard e

data QualTree b e t = TGen b e t
                    | TLet b e t
                    | TGuard e t

type ExprQual = Qual Binding Expr

-- last type para is type of expr at this level
-- e.x. Binary (Op_Type) (Exp1_TypeTree) (Exp2_TypeTree)

type TypeTree = Tree Unit TypeBinding Type

type IndexTree = Tree Unit IBinding Int

type TypeQual  = QualTree TypeBinding TypeTree Type

type IndexQual = QualTree IBinding IndexTree Int

data TypeBinding  = TLit                              Type
                  | TConsLit TypeBinding TypeBinding  Type
                  | TListLit (List TypeBinding)       Type
                  | TNTupleLit (List TypeBinding)     Type

data IBinding  = ILit                       Int
               | IConsLit IBinding IBinding  Int
               | IListLit (List IBinding)    Int
               | INTupleLit (List IBinding)  Int

type TVar = String

data Type
    = TypVar TVar -- Typ Variables e.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | AD AD
    | TypeError TypeError

data AD
    = TList Type
    | TTuple (List Type)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable String
  | UnknownError String
  | NoInstanceOfEnum Type

derive instance eqQual :: (Eq b, Eq e) => Eq (Qual b e)

derive instance eqQualTree :: (Eq a, Eq b, Eq c) => Eq (QualTree a b c)

-- | Bindings
-- |
-- | Binding forms for pattern matching on lists and tuples
data Binding = Lit Atom
             | ConsLit Binding Binding
             | ListLit (List Binding)
             | NTupleLit (List Binding)

derive instance eqBinding :: Eq Binding

-- | Definitions
-- |
-- | Definitions for functions and constants
data Definition = Def String (List Binding) Expr

derive instance eqDefintion :: Eq Definition

type Output = {
    expr :: Expr,
    typ :: TypeTree,
    idTree :: IndexTree
  }

instance showAtom :: Show Atom where
  show atom = case atom of
    AInt number -> "AInt " <> show number
    Bool bool   -> "Bool " <> show bool
    Char string -> "Char " <> show string
    Name string -> "Name " <> show string

instance showQual :: (Show b, Show e) => Show (Qual b e) where
  show q = case q of
    Gen b e -> "Gen (" <> show b <> " " <> show e <> ")"
    Let b e -> "Let (" <> show b <> " " <> show e <> ")"
    Guard e -> "Guard (" <> show e <> ")"

instance showQualTree :: (Show a, Show b, Show c) => Show (QualTree a b c) where
  show (TGen a b c) = "TGen (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (TLet a b c) = "TLet (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (TGuard a c)  = "TGuard (" <> show a <> " " <> show c <> ")"

instance showTree :: (Show a, Show b, Show c) => Show (Tree a b c) where
  show tree = case tree of
    Atom c atom         -> "(Atom " <> show c <> " "<> show atom <> ")"
    List c ls           -> "(List " <> show c <> " "<> show ls <>  ")"
    NTuple c ls         -> "(NTuple " <> show c <> " "<> show ls <>  ")"
    Binary c op e1 e2   -> "(Binary " <> show c <> " "<> show op <> " " <> show e1 <> " " <> show e2 <>  ")"
    Unary c op e        -> "(Unary " <> show c <> " "<> show op <> " " <> show e <>  ")"
    SectL c expr op     -> "(SectL " <> show c <> " "<> show expr <> " " <> show op <>  ")"
    SectR c op expr     -> "(SectR " <> show c <> " "<> show op <> " " <> show expr <>  ")"
    PrefixOp c op       -> "(PrefixOp " <> show c <> " " <> show op <> ")"
    IfExpr c ce te ee   -> "(IfExpr " <> show c <> " "<> show ce <> " " <> show te <> " " <> show ee <>  ")"
    ArithmSeq c s by e  -> "(ArithmSeq " <> show c <> "(" <> show s <> ")" <> show by <> ".." <> show e <> ")"
    LetExpr c bs e     -> "(LetExpr " <> show c <> " (" <> show bs <> ") " <> " " <> show e <>  ")"
    Lambda c binds body -> "(Lambda " <> show c <> " " <> show binds <> " " <> show body <>  ")"
    App c func args     -> "(App " <> show c <> " "<> show func <> " " <> show args <>  ")"
    ListComp c expr quals -> "(ListComp " <> show c <> "(" <> show expr <> ")" <> "(" <> show quals <> "))"

instance showBinding :: Show Binding where
  show binding = case binding of
    Lit atom     -> "Lit (" <> show atom <> ")"
    ConsLit b bs -> "ConsLit (" <> show b <> ") (" <> show bs <> ")"
    ListLit bs   -> "ListLit (" <> show bs <> ")"
    NTupleLit ls -> "NTupleLit (" <> show ls <> ")"

instance showDefinition :: Show Definition where
  show (Def name bindings body) = "Def " <> show name <> " (" <> show bindings <> ") (" <> show body <> ")"

instance showType :: Show Type where
  show (TypVar var) = "(TypVar  " <> show var <> ")"
  show (TypCon con) = "(TypCon " <> show con <> ")"
  show (TypArr t1 t2) = "(TypArr "<> show t1 <>" " <> show t2 <> ")"
  show (AD ad) = "(AD "<> show ad <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

instance showAD :: Show AD where
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"

derive instance eqAD :: Eq AD

instance showTypeError :: Show TypeError where
  show (UnificationFail a b) = "(UnificationFail "<> show a <> " " <> show b <>")"
  show (InfiniteType a b ) = "(InfiniteType " <> show a <> " " <> show b <> ")"
  show (UnboundVariable a) = "(UnboundVariable " <> show a <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (NoInstanceOfEnum t) = "(" <> show t <> "is no instance of Enum)"

derive instance eqTypeError :: Eq TypeError

-- instance showTypeTree :: Show TypeTree where
--   show (TAtom t) = "(TAtom " <> show t <> ")"
--   show (TListTree lt t) = "(TListTree (" <> show lt <> ") " <> show t <> ")"
--   show (TNTuple lt t) = "(TNTuple ("<> show lt <> ") " <> show t <> ")"
--   show (TBinary t1 tt1 tt2 t) = "(TBinary " <> show t1 <> " " <> show tt1 <>  " " <> show tt2 <> " " <> show t <> ")"
--   show (TUnary t1 tt t) = "(TUnary "<> show t1 <> " " <> show tt <> " " <> show t <> ")"
--   show (TSectL tt t1 t) = "(TSectL "<> show tt <> " "<> show t1 <> " " <> show t <> ")"
--   show (TSectR t1 tt t) = "(TSectR " <> show t1 <> " " <> show tt <> " " <> show t <> ")"
--   show (TPrefixOp t) = "(TPrefixOp " <> show t <> ")"
--   show (TIfExpr tt1 tt2 tt3 t) = "(TIfExpr " <> show tt1 <> " " <> show tt2 <> " " <> show tt3 <> " " <> show t <> ")"
--   show (TArithmSeq s b e t) = "(TArithmSeq " <> show s <> " " <> show b <> " " <> show e <> ".." <> show t <> ")"
--   show (TLetExpr bin tt t) = "(TLetExpr " <> show bin <> " " <> show tt <> " " <> show t <> ")"
--   show (TLambda lb tt t ) = "(TLambda " <> show lb <> " " <> show tt <> " " <> show t <> ")"
--   show (TApp tt1 tl t) = "(TApp " <> show tt1 <> " (" <> show tl <> ") " <> show t <> ")"
--   show (TListComp e qs t) = "(TListComp " <> show e <> " (" <> show qs <> ") " <> show t <> ")"

instance showTypeBinding:: Show TypeBinding where
  show (TLit t) = "(TLit "<> show t <>")"
  show (TConsLit b1 b2 t) = "(TConsLit "<> show b1 <> " " <> show b2 <> " " <> show t <>")"
  show (TListLit lb t) = "(TListLit " <> show lb <> " "<> show t <>")"
  show (TNTupleLit lb t) = "(TNTupleLit " <> show lb <> " "<> show t <>")"

prettyPrintType :: Type -> String
prettyPrintType (TypVar tvar) = tvar
prettyPrintType (TypCon str) = str
prettyPrintType (TypeError err) = prettyPrintTypeError err
prettyPrintType (TypArr t1@(TypArr _ _) t2) = "(" <> prettyPrintType t1 <> ")" <> " -> " <> prettyPrintType t2
prettyPrintType (TypArr t1 t2) = prettyPrintType t1 <> " -> " <> prettyPrintType t2
prettyPrintType (AD (TList t)) = "[" <> prettyPrintType t <> "]"
prettyPrintType (AD (TTuple ts)) = "(" <> (fold <<< separateWith ", " <<< map prettyPrintType $ ts) <> ")"
    where
    separateWith :: String -> List String -> List String
    separateWith _ Nil = "" : Nil
    separateWith sep (t:ts) = t : map ((<>) sep) ts

prettyPrintTypeError :: TypeError -> String
prettyPrintTypeError (UnificationFail t1 t2) = "UnificationFail: Can't unify " <> prettyPrintType t1 <> " with " <> prettyPrintType t2
prettyPrintTypeError (InfiniteType tvar t) = "InfiniteType: cannot construct the infinite type: " <> tvar <> " ~ " <> prettyPrintType t
prettyPrintTypeError (UnboundVariable var) = "UnboundVariable: Not in scope " <> var
prettyPrintTypeError (NoInstanceOfEnum t) = "No instance for Enum " <> prettyPrintType t <> " defined."
prettyPrintTypeError (UnknownError str) = "UnknownError: " <> str

-- extractType:: TypeTree -> Type
-- extractType (TAtom t)            = t
-- extractType (TListTree _ t)      = t
-- extractType (TNTuple _ t)        = t
-- extractType (TBinary _ _ _ t)    = t
-- extractType (TUnary _ _ t)       = t
-- extractType (TSectL _ _ t)       = t
-- extractType (TSectR _ _ t)       = t
-- extractType (TPrefixOp t)        = t
-- extractType (TIfExpr _ _ _ t)    = t
-- extractType (TArithmSeq _ _ _ t) = t
-- extractType (TLetExpr _ _ t)     = t
-- extractType (TLambda _ _ t)      = t
-- extractType (TApp _ _ t)         = t
-- extractType (TListComp _ _ t)    = t

-- extractIndex :: IndexTree -> Int
-- extractIndex (IAtom i)            = i
-- extractIndex (IListTree _ i)      = i
-- extractIndex (INTuple _ i)        = i
-- extractIndex (IBinary _ _ _ i)    = i
-- extractIndex (IUnary _ _ i)       = i
-- extractIndex (ISectL _ _ i)       = i
-- extractIndex (ISectR _ _ i)       = i
-- extractIndex (IPrefixOp i)        = i
-- extractIndex (IIfExpr _ _ _ i)    = i
-- extractIndex (IArithmSeq _ _ _ i) = i
-- extractIndex (ILetExpr _ _ i)     = i
-- extractIndex (ILambda _ _ i)      = i
-- extractIndex (IApp _ _ i)         = i
-- extractIndex (IListComp _ _ i)    = i

-- extractBindingType:: TypeBinding -> Type
-- extractBindingType (TLit t)         = t
-- extractBindingType (TConsLit _ _ t) = t
-- extractBindingType (TListLit _ t)   = t
-- extractBindingType (TNTupleLit _ t) = t

module AST where

import Prelude
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe)
import Data.Tuple (Tuple)

-- | Operators
-- |
-- | Primitive infix operators that are evaluated directly by the `Evaluator`.
-- | (`Colon` is `Cons` but clashes with `Data.List.Cons`)
data Op = Composition
        | Power
        | Mul
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar
        | InfixFunc String

derive instance eqOp :: Eq Op

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Add    -> "Add"
    Sub    -> "Sub"
    Colon  -> "Colon"
    Append -> "Append"
    Equ    -> "Equ"
    Neq    -> "Neq"
    Lt     -> "Lt"
    Leq    -> "Leq"
    Gt     -> "Gt"
    Geq    -> "Geq"
    And    -> "And"
    Or     -> "Or"
    Dollar -> "Dollar"
    InfixFunc name -> "(InfixFunc " <> name <> ")"

pPrintOp :: Op -> String
pPrintOp op = case op of
  Composition -> "."
  Power  -> "^"
  Mul    -> "*"
  Add    -> "+"
  Sub    -> "-"
  Colon  -> ":"
  Append -> "++"
  Equ    -> "=="
  Neq    -> "/="
  Lt     -> "<"
  Leq    -> "<="
  Gt     -> ">"
  Geq    -> ">="
  And    -> "&&"
  Or     -> "||"
  Dollar -> "$"
  InfixFunc n -> "`" <> n <> "`"

-- | Atoms
-- |
-- | Primitive data types
data Atom = AInt Int
          | Bool Boolean
          | Char String
          | Name String

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

-- | Expressions
-- |
-- | The basic expressions the `Parser` and `Evaluator` recognize.

data Tree a b c =
    Atom      c a
  | List      c (List (Tree a b c))
  | NTuple    c (List (Tree a b c))
  | Binary    c Op (Tree a b c) (Tree a b c)
  | Unary     c Op (Tree a b c)
  | SectL     c (Tree a b c) Op
  | SectR     c Op (Tree a b c)
  | PrefixOp  c Op
  | IfExpr    c (Tree a b c) (Tree a b c) (Tree a b c)
  | ArithmSeq c (Tree a b c) (Maybe (Tree a b c)) (Maybe (Tree a b c))
  | LetExpr   c (List (Tuple Binding (Tree a b c))) (Tree a b c)
  | Lambda    c (List b) (Tree a b c)
  | App       c (Tree a b c) (List (Tree a b c))
  | ListComp  c (Tree a b c) (List (Qual b (Tree a b c)))

derive instance eqTree :: (Eq a, Eq b, Eq c) => Eq (Tree a b c)

type Expr = Tree Atom Binding Unit

data Qual b e = Gen b e | Let b e | Guard e

data QualTree b e t = TGen b e t
                    | TLet b e t
                    | TGuard e t

type ExprQual = Qual Binding Expr

-- last type para is type of expr at this level
-- e.x. Binary (Op_Type) (Exp1_TypeTree) (Exp2_TypeTree)

type TypeTree = Tree Unit TypeBinding Type

type IndexTree = Tree Unit IBinding Int

type TypeQual  = QualTree TypeBinding TypeTree Type

type IndexQual = QualTree IBinding IndexTree Int

data TypeBinding  = TLit                              Type
                  | TConsLit TypeBinding TypeBinding  Type
                  | TListLit (List TypeBinding)       Type
                  | TNTupleLit (List TypeBinding)     Type

data IBinding  = ILit                       Int
               | IConsLit IBinding IBinding  Int
               | IListLit (List IBinding)    Int
               | INTupleLit (List IBinding)  Int

type TVar = String

data Type
    = TypVar TVar -- Typ Variables e.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | AD AD
    | TypeError TypeError

data AD
    = TList Type
    | TTuple (List Type)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable String
  | UnknownError String
  | NoInstanceOfEnum Type

derive instance eqQual :: (Eq b, Eq e) => Eq (Qual b e)

derive instance eqQualTree :: (Eq a, Eq b, Eq c) => Eq (QualTree a b c)

-- | Bindings
-- |
-- | Binding forms for pattern matching on lists and tuples
data Binding = Lit Atom
             | ConsLit Binding Binding
             | ListLit (List Binding)
             | NTupleLit (List Binding)

derive instance eqBinding :: Eq Binding

-- | Definitions
-- |
-- | Definitions for functions and constants
data Definition = Def String (List Binding) Expr

derive instance eqDefintion :: Eq Definition

type Output = {
    expr :: Expr,
    typ :: TypeTree,
    idTree :: IndexTree
  }

instance showAtom :: Show Atom where
  show atom = case atom of
    AInt number -> "AInt " <> show number
    Bool bool   -> "Bool " <> show bool
    Char string -> "Char " <> show string
    Name string -> "Name " <> show string

instance showQual :: (Show b, Show e) => Show (Qual b e) where
  show q = case q of
    Gen b e -> "Gen (" <> show b <> " " <> show e <> ")"
    Let b e -> "Let (" <> show b <> " " <> show e <> ")"
    Guard e -> "Guard (" <> show e <> ")"

instance showQualTree :: (Show a, Show b, Show c) => Show (QualTree a b c) where
  show (TGen a b c) = "TGen (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (TLet a b c) = "TLet (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (TGuard a c)  = "TGuard (" <> show a <> " " <> show c <> ")"

instance showTree :: (Show a, Show b, Show c) => Show (Tree a b c) where
  show tree = case tree of
    Atom c atom         -> "(Atom " <> show c <> " "<> show atom <> ")"
    List c ls           -> "(List " <> show c <> " "<> show ls <>  ")"
    NTuple c ls         -> "(NTuple " <> show c <> " "<> show ls <>  ")"
    Binary c op e1 e2   -> "(Binary " <> show c <> " "<> show op <> " " <> show e1 <> " " <> show e2 <>  ")"
    Unary c op e        -> "(Unary " <> show c <> " "<> show op <> " " <> show e <>  ")"
    SectL c expr op     -> "(SectL " <> show c <> " "<> show expr <> " " <> show op <>  ")"
    SectR c op expr     -> "(SectR " <> show c <> " "<> show op <> " " <> show expr <>  ")"
    PrefixOp c op       -> "(PrefixOp " <> show c <> " " <> show op <> ")"
    IfExpr c ce te ee   -> "(IfExpr " <> show c <> " "<> show ce <> " " <> show te <> " " <> show ee <>  ")"
    ArithmSeq c s by e  -> "(ArithmSeq " <> show c <> "(" <> show s <> ")" <> show by <> ".." <> show e <> ")"
    LetExpr c bs e     -> "(LetExpr " <> show c <> " (" <> show bs <> ") " <> " " <> show e <>  ")"
    Lambda c binds body -> "(Lambda " <> show c <> " " <> show binds <> " " <> show body <>  ")"
    App c func args     -> "(App " <> show c <> " "<> show func <> " " <> show args <>  ")"
    ListComp c expr quals -> "(ListComp " <> show c <> "(" <> show expr <> ")" <> "(" <> show quals <> "))"

instance showBinding :: Show Binding where
  show binding = case binding of
    Lit atom     -> "Lit (" <> show atom <> ")"
    ConsLit b bs -> "ConsLit (" <> show b <> ") (" <> show bs <> ")"
    ListLit bs   -> "ListLit (" <> show bs <> ")"
    NTupleLit ls -> "NTupleLit (" <> show ls <> ")"

instance showDefinition :: Show Definition where
  show (Def name bindings body) = "Def " <> show name <> " (" <> show bindings <> ") (" <> show body <> ")"

instance showType :: Show Type where
  show (TypVar var) = "(TypVar  " <> show var <> ")"
  show (TypCon con) = "(TypCon " <> show con <> ")"
  show (TypArr t1 t2) = "(TypArr "<> show t1 <>" " <> show t2 <> ")"
  show (AD ad) = "(AD "<> show ad <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

instance showAD :: Show AD where
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"

derive instance eqAD :: Eq AD

instance showTypeError :: Show TypeError where
  show (UnificationFail a b) = "(UnificationFail "<> show a <> " " <> show b <>")"
  show (InfiniteType a b ) = "(InfiniteType " <> show a <> " " <> show b <> ")"
  show (UnboundVariable a) = "(UnboundVariable " <> show a <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (NoInstanceOfEnum t) = "(" <> show t <> "is no instance of Enum)"

derive instance eqTypeError :: Eq TypeError

-- instance showTypeTree :: Show TypeTree where
--   show (TAtom t) = "(TAtom " <> show t <> ")"
--   show (TListTree lt t) = "(TListTree (" <> show lt <> ") " <> show t <> ")"
--   show (TNTuple lt t) = "(TNTuple ("<> show lt <> ") " <> show t <> ")"
--   show (TBinary t1 tt1 tt2 t) = "(TBinary " <> show t1 <> " " <> show tt1 <>  " " <> show tt2 <> " " <> show t <> ")"
--   show (TUnary t1 tt t) = "(TUnary "<> show t1 <> " " <> show tt <> " " <> show t <> ")"
--   show (TSectL tt t1 t) = "(TSectL "<> show tt <> " "<> show t1 <> " " <> show t <> ")"
--   show (TSectR t1 tt t) = "(TSectR " <> show t1 <> " " <> show tt <> " " <> show t <> ")"
--   show (TPrefixOp t) = "(TPrefixOp " <> show t <> ")"
--   show (TIfExpr tt1 tt2 tt3 t) = "(TIfExpr " <> show tt1 <> " " <> show tt2 <> " " <> show tt3 <> " " <> show t <> ")"
--   show (TArithmSeq s b e t) = "(TArithmSeq " <> show s <> " " <> show b <> " " <> show e <> ".." <> show t <> ")"
--   show (TLetExpr bin tt t) = "(TLetExpr " <> show bin <> " " <> show tt <> " " <> show t <> ")"
--   show (TLambda lb tt t ) = "(TLambda " <> show lb <> " " <> show tt <> " " <> show t <> ")"
--   show (TApp tt1 tl t) = "(TApp " <> show tt1 <> " (" <> show tl <> ") " <> show t <> ")"
--   show (TListComp e qs t) = "(TListComp " <> show e <> " (" <> show qs <> ") " <> show t <> ")"

instance showTypeBinding:: Show TypeBinding where
  show (TLit t) = "(TLit "<> show t <>")"
  show (TConsLit b1 b2 t) = "(TConsLit "<> show b1 <> " " <> show b2 <> " " <> show t <>")"
  show (TListLit lb t) = "(TListLit " <> show lb <> " "<> show t <>")"
  show (TNTupleLit lb t) = "(TNTupleLit " <> show lb <> " "<> show t <>")"

prettyPrintType :: Type -> String
prettyPrintType (TypVar tvar) = tvar
prettyPrintType (TypCon str) = str
prettyPrintType (TypeError err) = prettyPrintTypeError err
prettyPrintType (TypArr t1@(TypArr _ _) t2) = "(" <> prettyPrintType t1 <> ")" <> " -> " <> prettyPrintType t2
prettyPrintType (TypArr t1 t2) = prettyPrintType t1 <> " -> " <> prettyPrintType t2
prettyPrintType (AD (TList t)) = "[" <> prettyPrintType t <> "]"
prettyPrintType (AD (TTuple ts)) = "(" <> (fold <<< separateWith ", " <<< map prettyPrintType $ ts) <> ")"
    where
    separateWith :: String -> List String -> List String
    separateWith _ Nil = "" : Nil
    separateWith sep (t:ts) = t : map ((<>) sep) ts

prettyPrintTypeError :: TypeError -> String
prettyPrintTypeError (UnificationFail t1 t2) = "UnificationFail: Can't unify " <> prettyPrintType t1 <> " with " <> prettyPrintType t2
prettyPrintTypeError (InfiniteType tvar t) = "InfiniteType: cannot construct the infinite type: " <> tvar <> " ~ " <> prettyPrintType t
prettyPrintTypeError (UnboundVariable var) = "UnboundVariable: Not in scope " <> var
prettyPrintTypeError (NoInstanceOfEnum t) = "No instance for Enum " <> prettyPrintType t <> " defined."
prettyPrintTypeError (UnknownError str) = "UnknownError: " <> str

-- extractType:: TypeTree -> Type
-- extractType (TAtom t)            = t
-- extractType (TListTree _ t)      = t
-- extractType (TNTuple _ t)        = t
-- extractType (TBinary _ _ _ t)    = t
-- extractType (TUnary _ _ t)       = t
-- extractType (TSectL _ _ t)       = t
-- extractType (TSectR _ _ t)       = t
-- extractType (TPrefixOp t)        = t
-- extractType (TIfExpr _ _ _ t)    = t
-- extractType (TArithmSeq _ _ _ t) = t
-- extractType (TLetExpr _ _ t)     = t
-- extractType (TLambda _ _ t)      = t
-- extractType (TApp _ _ t)         = t
-- extractType (TListComp _ _ t)    = t

-- extractIndex :: IndexTree -> Int
-- extractIndex (IAtom i)            = i
-- extractIndex (IListTree _ i)      = i
-- extractIndex (INTuple _ i)        = i
-- extractIndex (IBinary _ _ _ i)    = i
-- extractIndex (IUnary _ _ i)       = i
-- extractIndex (ISectL _ _ i)       = i
-- extractIndex (ISectR _ _ i)       = i
-- extractIndex (IPrefixOp i)        = i
-- extractIndex (IIfExpr _ _ _ i)    = i
-- extractIndex (IArithmSeq _ _ _ i) = i
-- extractIndex (ILetExpr _ _ i)     = i
-- extractIndex (ILambda _ _ i)      = i
-- extractIndex (IApp _ _ i)         = i
-- extractIndex (IListComp _ _ i)    = i

-- extractBindingType:: TypeBinding -> Type
-- extractBindingType (TLit t)         = t
-- extractBindingType (TConsLit _ _ t) = t
-- extractBindingType (TListLit _ t)   = t
-- extractBindingType (TNTupleLit _ t) = t


Pretty.Values mostly working

Pretty.Values mostly working

module Language.PureScript.Pretty.Values
  ( prettyPrintValue
  , prettyPrintBinder
  ) where

import Control.Apply
import Control.Arrow ((<+>))
import Control.Arrow.Kleisli (runKleisli)
import Control.Monad.State
import Control.Monad.State.Trans
import Data.Array (map)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.String (joinWith)
import Data.Traversable (sequence, traverse)
import Data.Tuple
import Text.Pretty.PatternArrows

import Language.PureScript.Declarations
import Language.PureScript.Errors (theImpossibleHappened)
import Language.PureScript.Pretty.Common
import Language.PureScript.Pretty.Types (prettyPrintType)

literals :: Unit -> Pattern PrinterState Value String
literals _ = mkPattern' match
  where
  match :: Value -> StateT PrinterState Maybe String
  match (NumericLiteral n) = return $ show n
  match (StringLiteral s) = return $ show s
  match (BooleanLiteral true) = return "true"
  match (BooleanLiteral false) = return "false"
  match (ArrayLiteral xs) = joinWith "" <$> sequence
    [ return "[ "
    , withIndent $ prettyPrintMany prettyPrintValue' xs
    , return " ]"
    ]
  match (ObjectLiteral []) = return "{}"
  match (ObjectLiteral ps) = joinWith "" <$> sequence
    [ return "{\n"
    , withIndent $ prettyPrintMany prettyPrintObjectProperty ps
    , return "\n"
    , currentIndent
    , return "}"
    ]
  match (Constructor name) = return $ show name
  match (Case values binders) = joinWith "" <$> sequence
    [ return "case "
    --, joinWith " " <$> traverse values prettyPrintValue'
    , return " of\n"
    , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders
    , currentIndent
    ]
  match (Let ds val) = joinWith "" <$> sequence
    [ return "let\n"
    , withIndent $ prettyPrintMany prettyPrintDeclaration ds
    , return "\n"
    , currentIndent
    , return "in "
    , prettyPrintValue' val
    ]
  match (Var ident) = return $ show ident
  match (Do els) = joinWith "" <$> sequence
    [ return "do "
    , withIndent $ prettyPrintMany prettyPrintDoNotationElement els
    , currentIndent
    ]
  match (TypeClassDictionary _ _ _) = return "<<dict>>"
  match (SuperClassDictionary _ _) = return "<<superclass dict>>"
  match (TypedValue _ val _) = prettyPrintValue' val
  match (PositionedValue _ val) = prettyPrintValue' val
  match _ = return ""

prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String
prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty
prettyPrintDeclaration (ValueDeclaration ident _ [] Nothing val) = joinWith "" <$> sequence
  [ return $ show ident ++ " = "
  , prettyPrintValue' val
  ]
prettyPrintDeclaration (PositionedDeclaration _ d) = prettyPrintDeclaration d
prettyPrintDeclaration _ = theImpossibleHappened "Invalid argument to prettyPrintDeclaration"

prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String
prettyPrintCaseAlternative (CaseAlternative { binders = binders, guard = grd, result = val }) =
  joinWith "" <$> sequence
    [
    {-joinWith ", " <$> traverse binders prettyPrintBinder'
    , -}
    maybe (return "") ((<$>) ((++) "| ") <<< prettyPrintValue') grd
    , return " -> "
    , prettyPrintValue' val
    ]

prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String
prettyPrintDoNotationElement (DoNotationValue val) =
  prettyPrintValue' val
prettyPrintDoNotationElement (DoNotationBind binder val) =
  joinWith "" <$> sequence
    [ prettyPrintBinder' binder
    , return " <- "
    , prettyPrintValue' val
    ]
prettyPrintDoNotationElement (DoNotationLet ds) =
  joinWith "" <$> sequence
    [ return "let "
    , withIndent $ prettyPrintMany prettyPrintDeclaration ds
    ]
prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el

ifThenElse :: Pattern PrinterState Value (Tuple (Tuple Value Value) Value)
ifThenElse = mkPattern match
  where
  match (IfThenElse cond th el) = Just (Tuple (Tuple th el) cond)
  match _ = Nothing

accessor :: Pattern PrinterState Value (Tuple String Value)
accessor = mkPattern match
  where
  match (Accessor prop val) = Just (Tuple prop val)
  match _ = Nothing

objectUpdate :: Unit -> Pattern PrinterState Value (Tuple [String] Value)
objectUpdate _ = mkPattern match
  where
  match (ObjectUpdate o ps) = Just (Tuple (flip map ps $ \(Tuple key val) -> key ++ " = " ++ prettyPrintValue val) o)
  match _ = Nothing

app :: Unit -> Pattern PrinterState Value (Tuple String Value)
app _ = mkPattern match
  where
  match (App val arg) = Just (Tuple (prettyPrintValue arg) val)
  match _ = Nothing

lam :: Pattern PrinterState Value (Tuple String Value)
lam = mkPattern match
  where
  match (Abs (Left arg) val) = Just (Tuple (show arg) val)
  match _ = Nothing

-- |
-- Generate a pretty-printed string representing an expression
--
prettyPrintValue :: Value -> String
prettyPrintValue p = runPretty (flip evalStateT (PrinterState { indent: 0 }) <<< prettyPrintValue') p

prettyPrintValue' :: Value -> StateT PrinterState Maybe String
prettyPrintValue' v = runPattern matchValue v
  where
  matchValue :: Pattern PrinterState Value String
  matchValue = fix $ \p -> buildPrettyPrinter operators (literals unit <+> (parens <$> p))
  operators :: OperatorTable PrinterState Value String
  operators =
    OperatorTable [ [ Operator (wrap accessor $ \prop val -> val ++ "." ++ prop) ]
                  , [ Operator (wrap (objectUpdate unit) $ \ps val -> val ++ "{ " ++ joinWith ", " ps ++ " }") ]
                  , [ Operator (wrap (app unit) $ \arg val -> val ++ "(" ++ arg ++ ")") ]
                  , [ Operator (split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val) ]
                  , [ Operator (wrap ifThenElse $ \(Tuple th el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el) ]
                  ]

prettyPrintBinderAtom :: Unit -> Pattern PrinterState Binder String
prettyPrintBinderAtom _ = mkPattern' match
  where
  match :: Binder -> StateT PrinterState Maybe String
  match NullBinder = return "_"
  match (StringBinder str) = return $ show str
  match (NumberBinder num) = return $ show num
  match (BooleanBinder true) = return "true"
  match (BooleanBinder false) = return "false"
  match (VarBinder ident) = return $ show ident
  match (ConstructorBinder ctor args) = joinWith "" <$> sequence
    [ return $ show ctor ++ " "
    --, joinWith " " <$> traverse args match
    ]
  match (ObjectBinder bs) = joinWith "" <$> sequence
    [ return "{\n"
    , withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs
    , currentIndent
    , return "}"
    ]
  match (ArrayBinder bs) = joinWith "" <$> sequence
    [ return "["
    , joinWith " " <$> traverse prettyPrintBinder' bs
    , return "]"
    ]
  match (NamedBinder ident binder) = ((++) (show ident ++ "@")) <$> prettyPrintBinder' binder
  match (PositionedBinder _ binder) = prettyPrintBinder' binder
  match _ = return ""

-- |
-- Generate a pretty-printed string representing a Binder
--
prettyPrintBinder :: Binder -> String
prettyPrintBinder b = runPretty (flip evalStateT (PrinterState { indent: 0 }) <<< prettyPrintBinder') b

prettyPrintBinder' :: Binder -> StateT PrinterState Maybe String
prettyPrintBinder' b = runPattern matchBinder b
  where
  matchBinder :: Pattern PrinterState Binder String
  matchBinder = fix $ \p -> buildPrettyPrinter operators (prettyPrintBinderAtom unit <+> (parens <$> p))
  operators :: OperatorTable PrinterState Binder String
  operators =
    OperatorTable [ [ Operator (assocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2)) ] ]

matchConsBinder :: Pattern PrinterState Binder (Tuple Binder Binder)
matchConsBinder = mkPattern match'
  where
  match' (ConsBinder b1 b2) = Just (Tuple b1 b2)
  match' _ = Nothing

prettyPrintObjectPropertyBinder :: (Tuple String Binder) -> StateT PrinterState Maybe String
prettyPrintObjectPropertyBinder (Tuple key binder) = joinWith "" <$> sequence
  [ return $ prettyPrintObjectKey key ++ ": "
  , prettyPrintBinder' binder
  ]

prettyPrintObjectProperty :: (Tuple String Value) -> StateT PrinterState Maybe String
prettyPrintObjectProperty (Tuple key value) = joinWith "" <$> sequence
  [ return $ prettyPrintObjectKey key ++ ": "
  , prettyPrintValue' value
  ]

module Language.PureScript.Pretty.Values
  ( prettyPrintValue
  , prettyPrintBinder
  ) where

import Control.Apply
import Control.Arrow ((<+>))
import Control.Arrow.Kleisli (runKleisli)
import Control.Monad.State
import Control.Monad.State.Trans
import Data.Array (concat, map)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.String (joinWith)
import Data.Traversable (sequence, traverse)
import Data.Tuple
import Text.Pretty.PatternArrows

import Language.PureScript.Declarations
import Language.PureScript.Errors (theImpossibleHappened)
import Language.PureScript.Pretty.Common
import Language.PureScript.Pretty.Types (prettyPrintType)

literals :: Pattern PrinterState Value String
literals = mkPattern' match
  where
  match :: Value -> StateT PrinterState Maybe String
  match (NumericLiteral n) = return $ either show show n
  match (StringLiteral s) = return $ show s
  match (BooleanLiteral true) = return "true"
  match (BooleanLiteral false) = return "false"
  match (ArrayLiteral xs) = concat <$> sequence
    [ return "[ "
    , withIndent $ prettyPrintMany prettyPrintValue' xs
    , return " ]"
    ]
  match (ObjectLiteral []) = return "{}"
  match (ObjectLiteral ps) = concat <$> sequence
    [ return "{\n"
    , withIndent $ prettyPrintMany prettyPrintObjectProperty ps
    , return "\n"
    , currentIndent
    , return "}"
    ]
  match (Constructor name) = return $ show name
  match (Case values binders) = concat <$> sequence
    [ return "case "
    , joinWith " " <$> traverse values prettyPrintValue'
    , return " of\n"
    , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders
    , currentIndent
    ]
  match (Let ds val) = concat <$> sequence
    [ return "let\n"
    , withIndent $ prettyPrintMany prettyPrintDeclaration ds
    , return "\n"
    , currentIndent
    , return "in "
    , prettyPrintValue' val
    ]
  match (Var ident) = return $ show ident
  match (Do els) = concat <$> sequence
    [ return "do "
    , withIndent $ prettyPrintMany prettyPrintDoNotationElement els
    , currentIndent
    ]
  match (TypeClassDictionary _ _ _) = return "<<dict>>"
  match (SuperClassDictionary _ _) = return "<<superclass dict>>"
  match (TypedValue _ val _) = prettyPrintValue' val
  match (PositionedValue _ val) = prettyPrintValue' val
  match _ = return ""

prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String
prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty
prettyPrintDeclaration (ValueDeclaration ident _ [] Nothing val) = concat <$> sequence
  [ return $ show ident ++ " = "
  , prettyPrintValue' val
  ]
prettyPrintDeclaration (PositionedDeclaration _ d) = prettyPrintDeclaration d
prettyPrintDeclaration _ = theImpossibleHappened "Invalid argument to prettyPrintDeclaration"

prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String
prettyPrintCaseAlternative (CaseAlternative binders grd val) =
  concat <$> sequence
    [ joinWith ", " <$> traverse binders prettyPrintBinder'
    , maybe (return "") ((<$>) ((++) "| ") <<< prettyPrintValue') grd
    , return " -> "
    , prettyPrintValue' val
    ]

prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String
prettyPrintDoNotationElement (DoNotationValue val) =
  prettyPrintValue' val
prettyPrintDoNotationElement (DoNotationBind binder val) =
  concat <$> sequence
    [ prettyPrintBinder' binder
    , return " <- "
    , prettyPrintValue' val
    ]
prettyPrintDoNotationElement (DoNotationLet ds) =
  concat <$> sequence
    [ return "let "
    , withIndent $ prettyPrintMany prettyPrintDeclaration ds
    ]
prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el

ifThenElse :: Pattern PrinterState Value (Tuple (Tuple Value Value) Value)
ifThenElse = mkPattern match
  where
  match (IfThenElse cond th el) = Just (Tuple (Tuple th el) cond)
  match _ = Nothing

accessor :: Pattern PrinterState Value (Tuple String Value)
accessor = mkPattern match
  where
  match (Accessor prop val) = Just (Tuple prop val)
  match _ = Nothing

objectUpdate :: Pattern PrinterState Value (Tuple [String] Value)
objectUpdate = mkPattern match
  where
  match (ObjectUpdate o ps) = Just (flip map ps $ \(Tuple key val) -> Tuple (key ++ " = " ++ prettyPrintValue val) o)
  match _ = Nothing

app :: Pattern PrinterState Value (Tuple String Value)
app = mkPattern match
  where
  match (App val arg) = Just (Tuple (prettyPrintValue arg) val)
  match _ = Nothing

lam :: Pattern PrinterState Value (Tuple String Value)
lam = mkPattern match
  where
  match (Abs (Left arg) val) = Just (Tuple (show arg) val)
  match _ = Nothing

-- |
-- Generate a pretty-printed string representing an expression
--
prettyPrintValue :: Value -> String
prettyPrintValue p = runPretty (flip evalStateT (PrinterState 0) <<< prettyPrintValue') p

prettyPrintValue' :: Value -> StateT PrinterState Maybe String
prettyPrintValue' v = runKleisli (runPattern matchValue) v
  where
  matchValue :: Pattern PrinterState Value String
  matchValue = buildPrettyPrinter operators (literals <+> (parens <$> matchValue))
  operators :: OperatorTable PrinterState Value String
  operators =
    OperatorTable [ [ Operator (wrap accessor $ \prop val -> val ++ "." ++ prop) ]
                  , [ Operator (wrap objectUpdate $ \ps val -> val ++ "{ " ++ joinWith ", " ps ++ " }") ]
                  , [ Operator (wrap app $ \arg val -> val ++ "(" ++ arg ++ ")") ]
                  , [ Operator (split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val) ]
                  , [ Operator (wrap ifThenElse $ \(Tuple th el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el) ]
                  ]

prettyPrintBinderAtom :: Pattern PrinterState Binder String
prettyPrintBinderAtom = mkPattern' match
  where
  match :: Binder -> StateT PrinterState Maybe String
  match NullBinder = return "_"
  match (StringBinder str) = return $ show str
  match (NumberBinder num) = return $ either show show num
  match (BooleanBinder true) = return "true"
  match (BooleanBinder false) = return "false"
  match (VarBinder ident) = return $ show ident
  match (ConstructorBinder ctor args) = concat <$> sequence
    [ return $ show ctor ++ " "
    , joinWith " " <$> traverse args match
    ]
  match (ObjectBinder bs) = concat <$> sequence
    [ return "{\n"
    , withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs
    , currentIndent
    , return "}"
    ]
  match (ArrayBinder bs) = concat <$> sequence
    [ return "["
    , joinWith " " <$> traverse prettyPrintBinder' bs
    , return "]"
    ]
  match (NamedBinder ident binder) = ((++) (show ident ++ "@")) <$> prettyPrintBinder' binder
  match (PositionedBinder _ binder) = prettyPrintBinder' binder
  match _ = return ""

-- |
-- Generate a pretty-printed string representing a Binder
--
prettyPrintBinder :: Binder -> String
prettyPrintBinder b = runPretty (flip evalStateT (PrinterState 0) <<< prettyPrintBinder') b

prettyPrintBinder' :: Binder -> StateT PrinterState Maybe String
prettyPrintBinder' b = runKleisli (runPattern matchBinder) b
  where
  matchBinder :: Pattern PrinterState Binder String
  matchBinder = fix $ \p -> buildPrettyPrinter operators (prettyPrintBinderAtom <+> (parens <$> p))
  operators :: OperatorTable PrinterState Binder String
  operators =
    OperatorTable [ [ Operator (assocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2)) ] ]

matchConsBinder :: Pattern PrinterState Binder (Tuple Binder Binder)
matchConsBinder = mkPattern match'
  where
  match' (ConsBinder b1 b2) = Just (Tuple b1 b2)
  match' _ = Nothing

prettyPrintObjectPropertyBinder :: (Tuple String Binder) -> StateT PrinterState Maybe String
prettyPrintObjectPropertyBinder (Tuple key binder) = concat <$> sequence
  [ return $ prettyPrintObjectKey key ++ ": "
  , prettyPrintBinder' binder
  ]

prettyPrintObjectProperty :: (Tuple String Value) -> StateT PrinterState Maybe String
prettyPrintObjectProperty (Tuple key value) = concat <$> sequence
  [ return $ prettyPrintObjectKey key ++ ": "
  , prettyPrintValue' value
  ]


Add examples for alt (#58)

Add examples for alt (#58)

module Control.Alt
  ( class Alt, alt, (<|>)
  , module Data.Functor
  ) where

import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Semigroup (append)

-- | The `Alt` type class identifies an associative operation on a type
-- | constructor.  It is similar to `Semigroup`, except that it applies to
-- | types of kind `* -> *`, like `Array` or `List`, rather than concrete types
-- | `String` or `Number`.
-- |
-- | `Alt` instances are required to satisfy the following laws:
-- |
-- | - Associativity: `(x <|> y) <|> z == x <|> (y <|> z)`
-- | - Distributivity: `f <$> (x <|> y) == (f <$> x) <|> (f <$> y)`
-- |
-- | For example, the `Array` (`[]`) type is an instance of `Alt`, where
-- | `(<|>)` is defined to be concatenation.
-- |
-- | A common use case is to select the first "valid" item, or, if all items
-- | are "invalid", the last "invalid" item.
-- |
-- | For example:
-- |
-- | ```purescript
-- | import Control.Alt ((<|>))
-- | import Data.Maybe (Maybe(..)
-- | import Data.Either (Either(..))
-- |
-- | Nothing <|> Just 1 <|> Just 2 == Just 1
-- | Left "err" <|> Right 1 <|> Right 2 == Right 1
-- | Left "err 1" <|> Left "err 2" <|> Left "err 3" == Left "err 3"
-- | ```
class Functor f <= Alt f where
  alt :: forall a. f a -> f a -> f a

infixl 3 alt as <|>

instance altArray :: Alt Array where
  alt = append

module Control.Alt
  ( class Alt, alt, (<|>)
  , module Data.Functor
  ) where

import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Semigroup (append)

-- | The `Alt` type class identifies an associative operation on a type
-- | constructor.  It is similar to `Semigroup`, except that it applies to
-- | types of kind `* -> *`, like `Array` or `List`, rather than concrete types
-- | `String` or `Number`.
-- |
-- | `Alt` instances are required to satisfy the following laws:
-- |
-- | - Associativity: `(x <|> y) <|> z == x <|> (y <|> z)`
-- | - Distributivity: `f <$> (x <|> y) == (f <$> x) <|> (f <$> y)`
-- |
-- | For example, the `Array` (`[]`) type is an instance of `Alt`, where
-- | `(<|>)` is defined to be concatenation.
class Functor f <= Alt f where
  alt :: forall a. f a -> f a -> f a

infixl 3 alt as <|>

instance altArray :: Alt Array where
  alt = append


Data.Functionify the `every` function.

Data.Functionify the `every` function.

module Signal.Time
  ( Time(..)
  , every
  , millisecond
  , now
  , second
  ) where

import Control.Monad.Eff (Eff(..))
import Control.Timer (Timer(..))
import Data.Function
import Signal (constant, Signal(..))

type Time = Number

millisecond :: Time
millisecond = 1

second :: Time
second = 1000

foreign import everyP """
  function everyP(constant, now, t) {
    var out = constant(now());
    setInterval(function() {
      out.set(now());
    }, t);
    return out;
  }""" :: forall c e. Fn3 (c -> Signal c) (Eff (timer :: Timer | e) Time) Time (Signal Time)

every :: Time -> Signal Time
every = runFn3 everyP constant now

-- |Returns the number of milliseconds since an arbitrary, but constant, time in the past.
foreign import now """
  function now() {
    var perf = typeof performance !== 'undefined' ? performance : null;
    return (
      perf && (perf.now || perf.webkitNow || perf.msNow || perf.oNow || perf.mozNow) ||
      (process && process.hrtime && function() {
        var t = process.hrtime();
        return (t[0] * 1e9 + t[1]) / 1e6;
      }) ||
      Date.now
    ).call(perf);
  }""" :: forall e. Eff (timer :: Timer | e) Time

module Signal.Time
  ( Time(..)
  , every
  , millisecond
  , now
  , second
  ) where

import Control.Monad.Eff (Eff(..))

import Signal (constant, Signal(..))
import Control.Timer (Timer(..))

type Time = Number

millisecond :: Time
millisecond = 1

second :: Time
second = 1000

foreign import everyP """
  function everyP(constant) {
  return function(now) {
  return function(t) {
    var out = constant(now());
    setInterval(function() {
      out.set(now());
    }, t);
    return out;
  };};}""" :: forall c e. (c -> Signal c) -> (Eff (timer :: Timer | e) Time) -> Time -> Signal Time

every = everyP constant now

-- |Returns the number of milliseconds since an arbitrary, but constant, time in the past.
foreign import now """
  function now() {
    var perf = typeof performance !== 'undefined' ? performance : null;
    return (
      perf && (perf.now || perf.webkitNow || perf.msNow || perf.oNow || perf.mozNow) ||
      (process && process.hrtime && function() {
        var t = process.hrtime();
        return (t[0] * 1e9 + t[1]) / 1e6;
      }) ||
      Date.now
    ).call(perf);
  }""" :: forall e. Eff (timer :: Timer | e) Time