Export ChildProcessExit constructors

Export ChildProcessExit constructors

module Node.ChildProcess
  ( Handle()
  , ChildProcess()
  , CHILD_PROCESS()
  , stderr
  , stdout
  , stdin
  , pid
  , connected
  , kill
  , send
  , disconnect
  , ChildProcessError()
  , ChildProcessExit(..)
  , onExit
  , onClose
  , onDisconnect
  , onMessage
  , onError
  , spawn
  , SpawnOptions()
  , defaultSpawnOptions
  , StdIOBehaviour(..)
  , pipe
  , inherit
  , ignore
  ) where

import Prelude

import Control.Monad.Eff (Eff())

import Data.StrMap (StrMap())
import Data.Function (Fn2(), runFn2)
import Data.Nullable (Nullable(), toNullable, toMaybe)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Foreign (Foreign())
import Unsafe.Coerce (unsafeCoerce)

import Node.FS as FS
import Node.Buffer (Buffer())
import Node.Stream (Readable(), Writable(), Stream())
import Node.ChildProcess.Signal (Signal(..))

-- | A handle for inter-process communication (IPC).
foreign import data Handle :: *

-- | The effect for creating and interacting with child processes.
foreign import data CHILD_PROCESS :: !

newtype ChildProcess = ChildProcess ChildProcessRec

runChildProcess :: ChildProcess -> ChildProcessRec
runChildProcess (ChildProcess r) = r

-- | Note: some of these types are lies, and so it is unsafe to access some of
-- | these record fields directly.
type ChildProcessRec =
  { stderr     :: forall eff. Readable () (cp :: CHILD_PROCESS | eff) Buffer
  , stdin      :: forall eff. Writable () (cp :: CHILD_PROCESS | eff) Buffer
  , stdout     :: forall eff. Readable () (cp :: CHILD_PROCESS | eff) Buffer
  , pid        :: Int
  , connected  :: Boolean
  , kill       :: Signal -> Boolean
  , send       :: forall r. Fn2 { | r} Handle Boolean
  , disconnect :: forall eff. Eff eff Unit
  }

-- | The standard error stream of a child process. Note that this is only
-- | available if the process was spawned with the stderr option set to "pipe".
stderr :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS | eff) Buffer
stderr = _.stderr <<< runChildProcess

-- | The standard output stream of a child process. Note that this is only
-- | available if the process was spawned with the stdout option set to "pipe".
stdout :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS | eff) Buffer
stdout = _.stdout <<< runChildProcess

-- | The standard input stream of a child process. Note that this is only
-- | available if the process was spawned with the stdin option set to "pipe".
stdin :: forall eff. ChildProcess -> Writable () (cp :: CHILD_PROCESS | eff) Buffer
stdin = _.stdin <<< runChildProcess

-- | The process ID of a child process. Note that if the process has already
-- | exited, another process may have taken the same ID, so be careful!
pid :: ChildProcess -> Int
pid = _.pid <<< runChildProcess

connected :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
connected = pure <<< _.connected <<< runChildProcess

send :: forall eff props. { | props } -> Handle -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
send msg handle (ChildProcess cp) = pure (runFn2 cp.send msg handle)

disconnect :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Unit
disconnect = _.disconnect <<< runChildProcess

-- | Send a signal to a child process. It's an unfortunate historical decision
-- | that this function is called "kill", as sending a signal to a child
-- | process won't necessarily kill it.
kill :: forall eff. Signal -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
kill sig (ChildProcess cp) = pure (cp.kill sig)

-- | Specifies how a child process exited; normally (with an exit code), or
-- | due to a signal.
data ChildProcessExit
  = Normally Int
  | BySignal Signal

instance showChildProcessExit :: Show ChildProcessExit where
  show (Normally x) = "Normally " <> show x
  show (BySignal sig) = "BySignal " <> show sig

type SpawnOptions =
  { cwd       :: Maybe String
  , stdio     :: Array (Maybe StdIOBehaviour)
  , env       :: Maybe (StrMap String)
  , detached  :: Boolean
  , uid       :: Maybe Int
  , gid       :: Maybe Int
  }

mkChildProcessExit :: Nullable Int -> Nullable Signal -> ChildProcessExit
mkChildProcessExit code signal =
  case toMaybe code of
    Just code -> Normally code
    Nothing -> BySignal (unsafeCoerce signal)

onExit :: forall eff. ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit
onExit = mkOnExit mkChildProcessExit

foreign import mkOnExit :: forall eff.
          (Nullable Int -> Nullable Signal -> ChildProcessExit)
          -> ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit

onClose :: forall eff. ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit
onClose = mkOnClose mkChildProcessExit

foreign import mkOnClose :: forall eff.
          (Nullable Int -> Nullable Signal -> ChildProcessExit)
          -> ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit

onMessage :: forall eff.  ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit
onMessage = mkOnMessage Nothing Just

foreign import mkOnMessage :: forall a eff.
          Maybe a -> (a -> Maybe a) ->
          ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit

foreign import onDisconnect :: forall eff. ChildProcess -> Eff eff Unit -> Eff eff Unit
foreign import onError :: forall eff. ChildProcess -> (ChildProcessError -> Eff eff Unit) -> Eff eff Unit

-- | Spawn a child process. Note that, in the event that a child process could
-- | not be spawned (for example, if the executable was not found) this will
-- | not throw an error. Instead, the `ChildProcess` will be created anyway,
-- | but it will immediately emit an 'error' event.
spawn :: forall eff. String -> Array String -> SpawnOptions -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess
spawn cmd args opts = spawnImpl cmd args (convertOpts opts)
  where
  convertOpts opts =
    { cwd: fromMaybe undefined opts.cwd
    , stdio: toActualStdIOOptions opts.stdio
    , env: toNullable opts.env
    , detached: opts.detached
    , uid: fromMaybe undefined opts.uid
    , gid: fromMaybe undefined opts.gid
    }

foreign import spawnImpl :: forall opts eff. String -> Array String -> { | opts } -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess

-- There's gotta be a better way.
foreign import undefined :: forall a. a

defaultSpawnOptions :: SpawnOptions
defaultSpawnOptions =
  { cwd: Nothing
  , stdio: pipe
  , env: Nothing
  , detached: false
  , uid: Nothing
  , gid: Nothing
  }

-- | An error which occurred inside a child process.
type ChildProcessError =
  { code :: String
  , errno :: String
  , syscall :: String
  }

-- | Behaviour for standard IO streams (eg, standard input, standard output) of
-- | a child process.
-- |
-- | * `Pipe`: creates a pipe between the child and parent process, which can
-- |   then be accessed as a `Stream` via the `stdin`, `stdout`, or `stderr`
-- |   functions.
-- | * `Ignore`: ignore this stream. This will cause Node to open /dev/null and
-- |   connect it to the stream.
-- | * `ShareStream`: Connect the supplied stream to the corresponding file
-- |    descriptor in the child.
-- | * `ShareFD`: Connect the supplied file descriptor (which should be open
-- |   in the parent) to the corresponding file descriptor in the child.
data StdIOBehaviour
  = Pipe
  | Ignore
  | ShareStream (forall r eff a. Stream r eff a)
  | ShareFD FS.FileDescriptor

-- | Create pipes for each of the three standard IO streams.
pipe :: Array (Maybe StdIOBehaviour)
pipe = map Just [Pipe, Pipe, Pipe]

-- | Share stdin with stdin, stdout with stdout, and stderr with stderr.
inherit :: Array (Maybe StdIOBehaviour)
inherit = map Just
  [ ShareStream process.stdin
  , ShareStream process.stdout
  , ShareStream process.stderr
  ]

foreign import process :: forall props. { | props }

-- | Ignore all streams.
ignore :: Array (Maybe StdIOBehaviour)
ignore = map Just [Ignore, Ignore, Ignore]

foreign import data ActualStdIOBehaviour :: *

toActualStdIOBehaviour :: StdIOBehaviour -> ActualStdIOBehaviour
toActualStdIOBehaviour b = case b of
  Pipe               -> c "pipe"
  Ignore             -> c "ignore"
  ShareFD x          -> c x
  ShareStream stream -> c stream
  where
  c :: forall a. a -> ActualStdIOBehaviour
  c = unsafeCoerce

type ActualStdIOOptions = Array (Nullable ActualStdIOBehaviour)

toActualStdIOOptions :: Array (Maybe StdIOBehaviour) -> ActualStdIOOptions
toActualStdIOOptions = map (toNullable <<< map toActualStdIOBehaviour)

module Node.ChildProcess
  ( Handle()
  , ChildProcess()
  , CHILD_PROCESS()
  , stderr
  , stdout
  , stdin
  , pid
  , connected
  , kill
  , send
  , disconnect
  , ChildProcessError()
  , ChildProcessExit()
  , onExit
  , onClose
  , onDisconnect
  , onMessage
  , onError
  , spawn
  , SpawnOptions()
  , defaultSpawnOptions
  , StdIOBehaviour(..)
  , pipe
  , inherit
  , ignore
  ) where

import Prelude

import Control.Monad.Eff (Eff())

import Data.StrMap (StrMap())
import Data.Function (Fn2(), runFn2)
import Data.Nullable (Nullable(), toNullable, toMaybe)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Foreign (Foreign())
import Unsafe.Coerce (unsafeCoerce)

import Node.FS as FS
import Node.Buffer (Buffer())
import Node.Stream (Readable(), Writable(), Stream())
import Node.ChildProcess.Signal (Signal(..))

-- | A handle for inter-process communication (IPC).
foreign import data Handle :: *

-- | The effect for creating and interacting with child processes.
foreign import data CHILD_PROCESS :: !

newtype ChildProcess = ChildProcess ChildProcessRec

runChildProcess :: ChildProcess -> ChildProcessRec
runChildProcess (ChildProcess r) = r

-- | Note: some of these types are lies, and so it is unsafe to access some of
-- | these record fields directly.
type ChildProcessRec =
  { stderr     :: forall eff. Readable () (cp :: CHILD_PROCESS | eff) Buffer
  , stdin      :: forall eff. Writable () (cp :: CHILD_PROCESS | eff) Buffer
  , stdout     :: forall eff. Readable () (cp :: CHILD_PROCESS | eff) Buffer
  , pid        :: Int
  , connected  :: Boolean
  , kill       :: Signal -> Boolean
  , send       :: forall r. Fn2 { | r} Handle Boolean
  , disconnect :: forall eff. Eff eff Unit
  }

-- | The standard error stream of a child process. Note that this is only
-- | available if the process was spawned with the stderr option set to "pipe".
stderr :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS | eff) Buffer
stderr = _.stderr <<< runChildProcess

-- | The standard output stream of a child process. Note that this is only
-- | available if the process was spawned with the stdout option set to "pipe".
stdout :: forall eff. ChildProcess -> Readable () (cp :: CHILD_PROCESS | eff) Buffer
stdout = _.stdout <<< runChildProcess

-- | The standard input stream of a child process. Note that this is only
-- | available if the process was spawned with the stdin option set to "pipe".
stdin :: forall eff. ChildProcess -> Writable () (cp :: CHILD_PROCESS | eff) Buffer
stdin = _.stdin <<< runChildProcess

-- | The process ID of a child process. Note that if the process has already
-- | exited, another process may have taken the same ID, so be careful!
pid :: ChildProcess -> Int
pid = _.pid <<< runChildProcess

connected :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
connected = pure <<< _.connected <<< runChildProcess

send :: forall eff props. { | props } -> Handle -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
send msg handle (ChildProcess cp) = pure (runFn2 cp.send msg handle)

disconnect :: forall eff. ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Unit
disconnect = _.disconnect <<< runChildProcess

-- | Send a signal to a child process. It's an unfortunate historical decision
-- | that this function is called "kill", as sending a signal to a child
-- | process won't necessarily kill it.
kill :: forall eff. Signal -> ChildProcess -> Eff (cp :: CHILD_PROCESS | eff) Boolean
kill sig (ChildProcess cp) = pure (cp.kill sig)

-- | Specifies how a child process exited; normally (with an exit code), or
-- | due to a signal.
data ChildProcessExit
  = Normally Int
  | BySignal Signal

instance showChildProcessExit :: Show ChildProcessExit where
  show (Normally x) = "Normally " <> show x
  show (BySignal sig) = "BySignal " <> show sig

type SpawnOptions =
  { cwd       :: Maybe String
  , stdio     :: Array (Maybe StdIOBehaviour)
  , env       :: Maybe (StrMap String)
  , detached  :: Boolean
  , uid       :: Maybe Int
  , gid       :: Maybe Int
  }

mkChildProcessExit :: Nullable Int -> Nullable Signal -> ChildProcessExit
mkChildProcessExit code signal =
  case toMaybe code of
    Just code -> Normally code
    Nothing -> BySignal (unsafeCoerce signal)

onExit :: forall eff. ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit
onExit = mkOnExit mkChildProcessExit

foreign import mkOnExit :: forall eff.
          (Nullable Int -> Nullable Signal -> ChildProcessExit)
          -> ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit

onClose :: forall eff. ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit
onClose = mkOnClose mkChildProcessExit

foreign import mkOnClose :: forall eff.
          (Nullable Int -> Nullable Signal -> ChildProcessExit)
          -> ChildProcess -> (ChildProcessExit -> Eff eff Unit) -> Eff eff Unit

onMessage :: forall eff.  ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit
onMessage = mkOnMessage Nothing Just

foreign import mkOnMessage :: forall a eff.
          Maybe a -> (a -> Maybe a) ->
          ChildProcess -> (Foreign -> Maybe Handle -> Eff eff Unit) -> Eff eff Unit

foreign import onDisconnect :: forall eff. ChildProcess -> Eff eff Unit -> Eff eff Unit
foreign import onError :: forall eff. ChildProcess -> (ChildProcessError -> Eff eff Unit) -> Eff eff Unit

-- | Spawn a child process. Note that, in the event that a child process could
-- | not be spawned (for example, if the executable was not found) this will
-- | not throw an error. Instead, the `ChildProcess` will be created anyway,
-- | but it will immediately emit an 'error' event.
spawn :: forall eff. String -> Array String -> SpawnOptions -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess
spawn cmd args opts = spawnImpl cmd args (convertOpts opts)
  where
  convertOpts opts =
    { cwd: fromMaybe undefined opts.cwd
    , stdio: toActualStdIOOptions opts.stdio
    , env: toNullable opts.env
    , detached: opts.detached
    , uid: fromMaybe undefined opts.uid
    , gid: fromMaybe undefined opts.gid
    }

foreign import spawnImpl :: forall opts eff. String -> Array String -> { | opts } -> Eff (cp :: CHILD_PROCESS | eff) ChildProcess

-- There's gotta be a better way.
foreign import undefined :: forall a. a

defaultSpawnOptions :: SpawnOptions
defaultSpawnOptions =
  { cwd: Nothing
  , stdio: pipe
  , env: Nothing
  , detached: false
  , uid: Nothing
  , gid: Nothing
  }

-- | An error which occurred inside a child process.
type ChildProcessError =
  { code :: String
  , errno :: String
  , syscall :: String
  }

-- | Behaviour for standard IO streams (eg, standard input, standard output) of
-- | a child process.
-- |
-- | * `Pipe`: creates a pipe between the child and parent process, which can
-- |   then be accessed as a `Stream` via the `stdin`, `stdout`, or `stderr`
-- |   functions.
-- | * `Ignore`: ignore this stream. This will cause Node to open /dev/null and
-- |   connect it to the stream.
-- | * `ShareStream`: Connect the supplied stream to the corresponding file
-- |    descriptor in the child.
-- | * `ShareFD`: Connect the supplied file descriptor (which should be open
-- |   in the parent) to the corresponding file descriptor in the child.
data StdIOBehaviour
  = Pipe
  | Ignore
  | ShareStream (forall r eff a. Stream r eff a)
  | ShareFD FS.FileDescriptor

-- | Create pipes for each of the three standard IO streams.
pipe :: Array (Maybe StdIOBehaviour)
pipe = map Just [Pipe, Pipe, Pipe]

-- | Share stdin with stdin, stdout with stdout, and stderr with stderr.
inherit :: Array (Maybe StdIOBehaviour)
inherit = map Just
  [ ShareStream process.stdin
  , ShareStream process.stdout
  , ShareStream process.stderr
  ]

foreign import process :: forall props. { | props }

-- | Ignore all streams.
ignore :: Array (Maybe StdIOBehaviour)
ignore = map Just [Ignore, Ignore, Ignore]

foreign import data ActualStdIOBehaviour :: *

toActualStdIOBehaviour :: StdIOBehaviour -> ActualStdIOBehaviour
toActualStdIOBehaviour b = case b of
  Pipe               -> c "pipe"
  Ignore             -> c "ignore"
  ShareFD x          -> c x
  ShareStream stream -> c stream
  where
  c :: forall a. a -> ActualStdIOBehaviour
  c = unsafeCoerce

type ActualStdIOOptions = Array (Nullable ActualStdIOBehaviour)

toActualStdIOOptions :: Array (Maybe StdIOBehaviour) -> ActualStdIOOptions
toActualStdIOOptions = map (toNullable <<< map toActualStdIOBehaviour)


Changed the type to String, this fixes #77.

This is a seriously weird bug. It has been reported.

module Lemmingpants where

import Prelude

import Components.Admin as CA
import Components.Admin.ListAttendees as CAL
import Components.Home as CH
import Components.Login as CL
import Components.Overhead as CO
import Components.Registration as CR
import Control.Alt ((<|>))
import Control.Monad.Except (except, runExcept)
import Data.Array as A
import Data.Either (Either(..), note)
import Data.Either.Nested (Either6)
import Data.Foldable (foldMap)
import Data.Functor.Coproduct.Nested (Coproduct6)
import Data.Lens (over, set, traverseOf)
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record (prop)
import Data.Maybe (Maybe(Nothing, Just), fromMaybe, maybe)
import Data.String (toLower)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Effect.Class.Console (log)
import Foreign (F, Foreign, ForeignError(..), fail, readString, renderForeignError, unsafeFromForeign)
import Halogen as H
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Routing.Match (Match, lit)
import Simple.JSON (readImpl, readJSON')
import Type.Prelude (SProxy(..))
import Types.Agenda as AG
import Types.Attendee as AT
import Types.Flash as FL
import Types.Lens (_withId)
import Types.Speaker as S
import Types.SpeakerQueue as SQ
import Types.Token (Payload(..), Token(..))
import Types.Token as TT
import Web.HTML (Window)

type ChildQuery = Coproduct6 CR.Query CO.Query CA.Query CAL.Query CL.Query CH.Query
type ChildSlot  = Either6 Int Int Int Int Int Int

data WSAction
  = Insert
  | Update

data Location
  = Home
  | Registration
  | Overhead
  | Admin
  | AdminListAttendees
  | Login

instance shLoc :: Show Location where
  show
    = case _ of
        Home               -> "Home"
        Registration       -> "Registration"
        Overhead           -> "Overhead"
        Admin              -> "Admin"
        AdminListAttendees -> "Admin: List attendees"
        Login              -> "Login"

locations :: Match Location
locations
  =   (Registration       <$ lit "registration")
  <|> (Overhead           <$ lit "overhead")
  <|> (Admin              <$ lit "admin")
  <|> (Admin              <$ lit "admin")
  <|> (AdminListAttendees <$ lit "adminAttendees")
  <|> (Login              <$ lit "login")
  <|> (Home               <$ lit "")

type State =
  { currentLocation :: Location
  , token           :: TT.Token
  , flash           :: Maybe FL.Flash
  , agenda          :: AG.Agenda
  , attendees       :: AT.AttendeeDB
  , showRegForm     :: Boolean
  , window          :: Window
  }

data Query a
  = ChangePage      Location   a
  | SignOut                    a
  | AdminMsg        CA.Message a
  | LoginMsg        CL.Message a
  | RegistrationMsg CR.Message a
  | WSMsg           Foreign    a

type Input = { token :: TT.Token, agenda :: AG.Agenda, attendees :: AT.AttendeeDB, window :: Window }

component :: H.Component HH.HTML Query Input Void Aff
component =
  H.parentComponent
    { initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where
    initialState :: Input -> State
    initialState i =
      { currentLocation: Home
      , token:           i.token
      , flash:           Nothing
      , agenda:          i.agenda
      , attendees:       i.attendees
      , showRegForm:     true
      , window:          i.window
      }

    render :: State -> H.ParentHTML Query ChildQuery ChildSlot Aff
    render state =
      HH.div
        [ HP.id_ (toLower (show state.currentLocation)) ]
        [ HH.nav_
          [ HH.menu_ (
            [ HH.li_ [HH.a [HP.href "#"]             [HH.text "Home"]]
            , HH.li_ [HH.a [HP.href "#registration"] [HH.text "Registration"]]
            , HH.li_ [HH.a [HP.href "#overhead"]     [HH.text "Overhead"]]
            ] <> (if pl.role == "admin_user"
                   then [ HH.li_
                      [ HH.a [HP.href "#admin"] [HH.text "Admin"]
                      , HH.menu
                        [ HP.id_ "submenu" ]
                        [ HH.li_ [ HH.a [HP.href "#adminAttendees"] [HH.text "List attendees"] ] ]
                      ]
                    ]
                    else mempty)
            <> [ loginlogoutlink state ])
          ]
        , HH.div
          [HP.class_ (HH.ClassName "container")]
          (maybe [] (\(FL.Flash f) -> [ HH.div [ HP.id_ "flash", (HP.class_ (HH.ClassName (show f.typ))) ] [ HH.text f.msg ] ]) state.flash
            <> [locationToSlot state.currentLocation state])
        ]
      where
        (Payload pl) = let (Token t) = state.token in t.payload

        loginlogoutlink
          :: State
          -> H.ParentHTML Query ChildQuery ChildSlot Aff
        loginlogoutlink s =
          let (TT.Token {payload}) = s.token
              (TT.Payload p)       = payload
           in if p.role == "admin_user"
                -- Blergh... hack... blergh...
                -- TODO: Unhack this!
                then HH.li_ [HH.a [HP.href "#signout", HE.onClick (HE.input_ SignOut)] [HH.text "Sign out"]]
                else HH.li_ [HH.a [HP.href "#login"]   [HH.text "Login"]]

        locationToSlot
          :: Location
          -> State
          -> H.ParentHTML Query ChildQuery ChildSlot Aff
        locationToSlot l s =
          case l of
            Registration       -> go CP.cp1 1 CR.component  rs   (HE.input RegistrationMsg)
            Overhead           -> go CP.cp2 2 CO.component  ohs  (const Nothing)
            Admin              -> go CP.cp3 3 CA.component  s'   (HE.input AdminMsg)
            AdminListAttendees -> go CP.cp4 4 CAL.component alas (const Nothing)
            Login              -> go CP.cp5 5 CL.component  ls   (HE.input LoginMsg)
            Home               -> go CP.cp6 6 CH.component  unit (const Nothing)
          where
            go :: forall g i o
               . CP.ChildPath g ChildQuery Int ChildSlot
              -> Int
              -> H.Component HH.HTML g i o Aff
              -> i
              -> (o -> Maybe (Query Unit))
              -> H.ParentHTML Query ChildQuery ChildSlot Aff
            go cp p c i f = HH.slot' cp p c i f

            ls   = { token: s.token }
            rs   = { token: s.token, showForm: s.showRegForm }
            s'   = { token: s.token, agenda: s.agenda, attendees: s.attendees }
            ohs  = { agenda: s.agenda, attendees: s.attendees }
            alas = { attendees: s.attendees }

    eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Void Aff
    eval =
      case _ of
        ChangePage l next ->
          H.modify (_ {currentLocation = l, flash = Nothing, showRegForm = true}) *> pure next
        SignOut      next -> do
          s <- H.get
          H.liftAff (TT.removeToken s.window)
          pure next
        AdminMsg   m next ->
          case m of
            CA.Flash s -> flash s next
        LoginMsg   m next ->
          case m of
            CL.NewToken t -> do
              s <- H.modify (_ {token = t})
              H.liftAff (TT.saveToken s.window t)
              pure next
            CL.Flash s -> flash s next
        RegistrationMsg m next ->
          case m of
            CR.FrmVsbl b -> H.modify (\s -> s { showRegForm = b }) *> pure next
            CR.Flash   s -> flash s next
        WSMsg fr next -> do
          -- Log the message to the console.
          liftEffect $ log $ unsafeFromForeign fr
          state <- H.get
          -- In case you think this is inefficient and want to change
          -- `readJSON' =<< readString` into `read'`, do know that
          -- there is a bug that makes the parsing fail if you only
          -- run read' on your foreign data. I don't know why, but I
          -- intend to find out.
          --
          -- Regards, A.
          case runExcept (dispatcher state =<< readJSON' =<< readString fr) of
            Left  es -> flash (FL.mkFlash (foldMap renderForeignError es) FL.Error) next
            Right s' -> H.put s' *> pure next
      where
        flash s next =
          H.modify (_ {flash = Just s})
          *> pure next

        dispatcher
          :: State
          -> { channel :: String, event :: String, payload :: Foreign }
          -> F State
        dispatcher state r =
          case r.event of
            "agenda_item_insert"   -> handleAgendaItem   (readImpl r.payload) Insert state
            "agenda_item_update"   -> handleAgendaItem   (readImpl r.payload) Update state
            "attendee_insert"      -> handleAttendee     (readImpl r.payload)        state
            "attendee_update"      -> handleAttendee     (readImpl r.payload)        state
            "speaker_insert"       -> handleSpeaker      (readImpl r.payload) Insert state
            "speaker_update"       -> handleSpeaker      (readImpl r.payload) Update state
            "speaker_queue_insert" -> handleSpeakerQueue (readImpl r.payload) Insert state
            "speaker_queue_update" -> handleSpeakerQueue (readImpl r.payload) Update state
            _                      -> fail (ForeignError "Anything can happen.")

        -- TODO: Make _ALL_ the go functions scream and shout if they can't update stuff.
        handleAgendaItem
          :: F { id         :: Int
               , supertitle :: Maybe String
               , title      :: String
               , order_     :: Int
               , state      :: String
               }
             -> WSAction
             -> State
             -> F State
        handleAgendaItem fr action st =
          fr
            >>= \air -> go action air st.agenda
            <#> \r   -> st { agenda = AG.jumpToFirstActive r }
          where
            go Insert air ag = pure (AG.insert (newAI air) ag)
            go Update air ag =
              except (note (pure (ForeignError "ERROR: handleAgendaItem: Could not update AgendaItem!"))
                (traverseOf (AG._AgendaItems <<< _withId air.id) (\(AG.AgendaItem {speakerQueues}) ->
                  Just $ set (_Newtype <<< prop (SProxy :: SProxy "speakerQueues")) speakerQueues (newAI air))
                  ag))

            newAI { id, supertitle, title, order_, state } =
              AG.AgendaItem { id, supertitle, title, order_, state, speakerQueues: mempty }

        handleAttendee :: F AT.Attendee -> State -> F State
        handleAttendee fr state =
            fr <#> \at -> state { attendees = AT.insertAttendee at state.attendees }

        handleSpeaker
          :: F { id               :: Int
               , speaker_queue_id :: Int
               , attendee_id      :: Int
               , state            :: S.SpeakerState
               , times_spoken     :: Maybe Int
               , agenda_item_id   :: Int
               }
             -> WSAction
             -> State
             -> F State
        handleSpeaker fr action st =
          fr >>= \r ->
            except (note
              (pure (ForeignError ("Modifying the speaker failed.")))
              (traverseOf
                (prop (SProxy :: SProxy "agenda") <<< AG._AgendaItems <<< _withId r.agenda_item_id <<< AG._SpeakerQueues <<< _withId r.speaker_queue_id)
                (Just <<< go action r)
                st))
          where
            go Insert r = over SQ._Speakers $ A.insert $ newSpeaker r
            go Update r = set (SQ._Speakers <<< _withId r.id) (newSpeaker r)

            newSpeaker {id, attendee_id, state, times_spoken} =
              let ts = fromMaybe 0 times_spoken
               in S.Speaker { id, attendeeId: attendee_id, state, timesSpoken: ts }

        handleSpeakerQueue
          :: F { id             :: Int
               , agenda_item_id :: Int
               , state          :: String
               }
          -> WSAction
          -> State
          -> F State
        handleSpeakerQueue r action s =
          r >>= \{id, agenda_item_id, state} ->
          except (note
            (pure (ForeignError "Modifying the speaker queue failed."))
            (traverseOf (prop (SProxy :: SProxy "agenda") <<< AG._AgendaItems <<< _withId agenda_item_id) (go action {id, state}) s))
          where
            go Insert {id, state} ai = Just $ AG.pushSQ (SQ.SpeakerQueue {id, state, speakers: mempty}) ai
            go Update {id, state} ai =
              if state == "done"
                then AG.popSQIfMatchingId id ai
                else Nothing

module Lemmingpants where

import Prelude

import Components.Admin as CA
import Components.Admin.ListAttendees as CAL
import Components.Home as CH
import Components.Login as CL
import Components.Overhead as CO
import Components.Registration as CR
import Control.Alt ((<|>))
import Control.Monad.Except (except, runExcept)
import Data.Array as A
import Data.Either (Either(..), note)
import Data.Either.Nested (Either6)
import Data.Foldable (foldMap)
import Data.Functor.Coproduct.Nested (Coproduct6)
import Data.Lens (over, set, traverseOf)
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record (prop)
import Data.Maybe (Maybe(Nothing, Just), fromMaybe, maybe)
import Data.String (toLower)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Effect.Class.Console (log)
import Foreign (F, Foreign, ForeignError(..), fail, renderForeignError, unsafeFromForeign)
import Halogen as H
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Routing.Match (Match, lit)
import Simple.JSON (read', readImpl)
import Type.Prelude (SProxy(..))
import Types.Agenda as AG
import Types.Attendee as AT
import Types.Flash as FL
import Types.Lens (_withId)
import Types.Speaker as S
import Types.SpeakerQueue as SQ
import Types.Token (Payload(..), Token(..))
import Types.Token as TT
import Web.HTML (Window)

type ChildQuery = Coproduct6 CR.Query CO.Query CA.Query CAL.Query CL.Query CH.Query
type ChildSlot  = Either6 Int Int Int Int Int Int

data WSAction
  = Insert
  | Update

data Location
  = Home
  | Registration
  | Overhead
  | Admin
  | AdminListAttendees
  | Login

instance shLoc :: Show Location where
  show
    = case _ of
        Home               -> "Home"
        Registration       -> "Registration"
        Overhead           -> "Overhead"
        Admin              -> "Admin"
        AdminListAttendees -> "Admin: List attendees"
        Login              -> "Login"

locations :: Match Location
locations
  =   (Registration       <$ lit "registration")
  <|> (Overhead           <$ lit "overhead")
  <|> (Admin              <$ lit "admin")
  <|> (Admin              <$ lit "admin")
  <|> (AdminListAttendees <$ lit "adminAttendees")
  <|> (Login              <$ lit "login")
  <|> (Home               <$ lit "")

type State =
  { currentLocation :: Location
  , token           :: TT.Token
  , flash           :: Maybe FL.Flash
  , agenda          :: AG.Agenda
  , attendees       :: AT.AttendeeDB
  , showRegForm     :: Boolean
  , window          :: Window
  }

data Query a
  = ChangePage      Location   a
  | SignOut                    a
  | AdminMsg        CA.Message a
  | LoginMsg        CL.Message a
  | RegistrationMsg CR.Message a
  | WSMsg           Foreign    a

type Input = { token :: TT.Token, agenda :: AG.Agenda, attendees :: AT.AttendeeDB, window :: Window }

component :: H.Component HH.HTML Query Input Void Aff
component =
  H.parentComponent
    { initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where
    initialState :: Input -> State
    initialState i =
      { currentLocation: Home
      , token:           i.token
      , flash:           Nothing
      , agenda:          i.agenda
      , attendees:       i.attendees
      , showRegForm:     true
      , window:          i.window
      }

    render :: State -> H.ParentHTML Query ChildQuery ChildSlot Aff
    render state =
      HH.div
        [ HP.id_ (toLower (show state.currentLocation)) ]
        [ HH.nav_
          [ HH.menu_ (
            [ HH.li_ [HH.a [HP.href "#"]             [HH.text "Home"]]
            , HH.li_ [HH.a [HP.href "#registration"] [HH.text "Registration"]]
            , HH.li_ [HH.a [HP.href "#overhead"]     [HH.text "Overhead"]]
            ] <> (if pl.role == "admin_user"
                   then [ HH.li_
                      [ HH.a [HP.href "#admin"] [HH.text "Admin"]
                      , HH.menu
                        [ HP.id_ "submenu" ]
                        [ HH.li_ [ HH.a [HP.href "#adminAttendees"] [HH.text "List attendees"] ] ]
                      ]
                    ]
                    else mempty)
            <> [ loginlogoutlink state ])
          ]
        , HH.div
          [HP.class_ (HH.ClassName "container")]
          (maybe [] (\(FL.Flash f) -> [ HH.div [ HP.id_ "flash", (HP.class_ (HH.ClassName (show f.typ))) ] [ HH.text f.msg ] ]) state.flash
            <> [locationToSlot state.currentLocation state])
        ]
      where
        (Payload pl) = let (Token t) = state.token in t.payload

        loginlogoutlink
          :: State
          -> H.ParentHTML Query ChildQuery ChildSlot Aff
        loginlogoutlink s =
          let (TT.Token {payload}) = s.token
              (TT.Payload p)       = payload
           in if p.role == "admin_user"
                -- Blergh... hack... blergh...
                -- TODO: Unhack this!
                then HH.li_ [HH.a [HP.href "#signout", HE.onClick (HE.input_ SignOut)] [HH.text "Sign out"]]
                else HH.li_ [HH.a [HP.href "#login"]   [HH.text "Login"]]

        locationToSlot
          :: Location
          -> State
          -> H.ParentHTML Query ChildQuery ChildSlot Aff
        locationToSlot l s =
          case l of
            Registration       -> go CP.cp1 1 CR.component  rs   (HE.input RegistrationMsg)
            Overhead           -> go CP.cp2 2 CO.component  ohs  (const Nothing)
            Admin              -> go CP.cp3 3 CA.component  s'   (HE.input AdminMsg)
            AdminListAttendees -> go CP.cp4 4 CAL.component alas (const Nothing)
            Login              -> go CP.cp5 5 CL.component  ls   (HE.input LoginMsg)
            Home               -> go CP.cp6 6 CH.component  unit (const Nothing)
          where
            go :: forall g i o
               . CP.ChildPath g ChildQuery Int ChildSlot
              -> Int
              -> H.Component HH.HTML g i o Aff
              -> i
              -> (o -> Maybe (Query Unit))
              -> H.ParentHTML Query ChildQuery ChildSlot Aff
            go cp p c i f = HH.slot' cp p c i f

            ls   = { token: s.token }
            rs   = { token: s.token, showForm: s.showRegForm }
            s'   = { token: s.token, agenda: s.agenda, attendees: s.attendees }
            ohs  = { agenda: s.agenda, attendees: s.attendees }
            alas = { attendees: s.attendees }

    eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Void Aff
    eval =
      case _ of
        ChangePage l next ->
          H.modify (_ {currentLocation = l, flash = Nothing, showRegForm = true}) *> pure next
        SignOut      next -> do
          s <- H.get
          H.liftAff (TT.removeToken s.window)
          pure next
        AdminMsg   m next ->
          case m of
            CA.Flash s -> flash s next
        LoginMsg   m next ->
          case m of
            CL.NewToken t -> do
              s <- H.modify (_ {token = t})
              H.liftAff (TT.saveToken s.window t)
              pure next
            CL.Flash s -> flash s next
        RegistrationMsg m next ->
          case m of
            CR.FrmVsbl b -> H.modify (\s -> s { showRegForm = b }) *> pure next
            CR.Flash   s -> flash s next
        WSMsg fr next -> do
          liftEffect $ log $ unsafeFromForeign fr
          state <- H.get
          case runExcept (dispatcher state =<< read' fr) of
            Left  es -> flash (FL.mkFlash (foldMap renderForeignError es) FL.Error) next
            Right s' -> H.put s' *> pure next
      where
        flash s next =
          H.modify (_ {flash = Just s})
          *> pure next

        dispatcher
          :: State
          -> { channel :: String, event :: String, payload :: Foreign }
          -> F State
        dispatcher state r =
          case r.event of
            "agenda_item_insert"   -> handleAgendaItem   (readImpl r.payload) Insert state
            "agenda_item_update"   -> handleAgendaItem   (readImpl r.payload) Update state
            "attendee_insert"      -> handleAttendee     (readImpl r.payload)        state
            "attendee_update"      -> handleAttendee     (readImpl r.payload)        state
            "speaker_insert"       -> handleSpeaker      (readImpl r.payload) Insert state
            "speaker_update"       -> handleSpeaker      (readImpl r.payload) Update state
            "speaker_queue_insert" -> handleSpeakerQueue (readImpl r.payload) Insert state
            "speaker_queue_update" -> handleSpeakerQueue (readImpl r.payload) Update state
            _                      -> fail (ForeignError "Anything can happen.")

        -- TODO: Make _ALL_ the go functions scream and shout if they can't update stuff.
        handleAgendaItem
          :: F { id         :: Int
               , supertitle :: Maybe String
               , title      :: String
               , order_     :: Int
               , state      :: String
               }
             -> WSAction
             -> State
             -> F State
        handleAgendaItem fr action st =
          fr
            >>= \air -> go action air st.agenda
            <#> \r   -> st { agenda = AG.jumpToFirstActive r }
          where
            go Insert air ag = pure (AG.insert (newAI air) ag)
            go Update air ag =
              except (note (pure (ForeignError "ERROR: handleAgendaItem: Could not update AgendaItem!"))
                (traverseOf (AG._AgendaItems <<< _withId air.id) (\(AG.AgendaItem {speakerQueues}) ->
                  Just $ set (_Newtype <<< prop (SProxy :: SProxy "speakerQueues")) speakerQueues (newAI air))
                  ag))

            newAI { id, supertitle, title, order_, state } =
              AG.AgendaItem { id, supertitle, title, order_, state, speakerQueues: mempty }

        handleAttendee :: F AT.Attendee -> State -> F State
        handleAttendee fr state =
            fr <#> \at -> state { attendees = AT.insertAttendee at state.attendees }

        handleSpeaker
          :: F { id               :: Int
               , speaker_queue_id :: Int
               , attendee_id      :: Int
               , state            :: S.SpeakerState
               , times_spoken     :: Maybe Int
               , agenda_item_id   :: Int
               }
             -> WSAction
             -> State
             -> F State
        handleSpeaker fr action st =
          fr >>= \r ->
            except (note
              (pure (ForeignError ("Modifying the speaker failed.")))
              (traverseOf
                (prop (SProxy :: SProxy "agenda") <<< AG._AgendaItems <<< _withId r.agenda_item_id <<< AG._SpeakerQueues <<< _withId r.speaker_queue_id)
                (Just <<< go action r)
                st))
          where
            go Insert r = over SQ._Speakers $ A.insert $ newSpeaker r
            go Update r = set (SQ._Speakers <<< _withId r.id) (newSpeaker r)

            newSpeaker {id, attendee_id, state, times_spoken} =
              let ts = fromMaybe 0 times_spoken
               in S.Speaker { id, attendeeId: attendee_id, state, timesSpoken: ts }

        handleSpeakerQueue
          :: F { id             :: Int
               , agenda_item_id :: Int
               , state          :: String
               }
          -> WSAction
          -> State
          -> F State
        handleSpeakerQueue r action s =
          r >>= \{id, agenda_item_id, state} ->
          except (note
            (pure (ForeignError "Modifying the speaker queue failed."))
            (traverseOf (prop (SProxy :: SProxy "agenda") <<< AG._AgendaItems <<< _withId agenda_item_id) (go action {id, state}) s))
          where
            go Insert {id, state} ai = Just $ AG.pushSQ (SQ.SpeakerQueue {id, state, speakers: mempty}) ai
            go Update {id, state} ai =
              if state == "done"
                then AG.popSQIfMatchingId id ai
                else Nothing


Prefix variables with var in query string

{-
Copyright 2015 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 Api.Query
  ( query
  , portView
  , portQuery
  , sample
  , fields
  , countWithQuery
  , SQL()
  , templated
  ) where

import Prelude
import Api.Common (RetryEffects(), getResponse, succeeded, retryGet, slamjax, ldJSON)
import Api.Fs (saveViewMount)
import Config.Paths (queryUrl, dataUrl)
import Control.Apply (lift2)
import Control.Bind ((<=<), (>=>))
import Control.Monad.Aff (Aff())
import Control.Monad.Aff.AVar (AVAR())
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.MonadPlus (guard)
import Data.Argonaut.Combinators ((.?))
import Data.Argonaut.Core (JArray(), Json(), JObject(), jsonEmptyObject, isArray, isObject, foldJson, toArray, toObject, toNumber, fromObject)
import Data.Argonaut.Decode (DecodeJson, decodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (concat, nub, filter, head, range, length)
import Data.Either (Either(..), either)
import Data.Either.Unsafe (fromRight)
import Data.Foldable (foldl)
import Data.List (uncons, fromList)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Path.Pathy (rootDir, (</>), dir, file, printPath)
import Data.String (split, joinWith, replace)
import Data.StrMap (StrMap(), keys, toList, empty, lookup)
import Data.Tuple (Tuple(..))
import Data.Bifunctor (lmap)
import Model.Notebook.Port (VarMapValue())
import Model.Path (FilePath(), rootify, encodeURIPath)
import Model.Resource (Resource(..), resourcePath, isFile, _name, resourceDir, resourceName)
import Network.HTTP.Affjax (Affjax(), AJAX(), affjax, defaultRequest)
import Network.HTTP.Method (Method(..))
import Network.HTTP.RequestHeader (RequestHeader(..))
import Optic.Core
import Utils (encodeURIComponent)
import qualified Data.Int as I

-- | This is template string where actual path is encoded like {{path}}
type SQL = String

query :: forall e. Resource -> SQL -> Aff (RetryEffects (ajax :: AJAX | e)) (Either String JArray)
query res@(File _) sql = do
  result <- retryGet (mkURI res sql)
  pure
    if succeeded result.status
       then Right (extractJArray result.response)
       else readError "error in query" result.response
  where
  mkURI :: Resource -> SQL -> FilePath
  mkURI res sql =
    queryUrl
    </> rootify (resourceDir res)
    </> dir (resourceName res)
    </> file ("?q=" <> encodeURIComponent (templated res sql))

query _ _ = pure $ Left "Query resource is not a file"

countWithQuery :: forall e. Resource -> Aff (RetryEffects (ajax :: AJAX | e)) Int
countWithQuery res =
  if not $ isFile res
    then pure 0
    else fromMaybe 0 <<< readTotal <<< extractJArray <$> getResponse msg (retryGet uriPath)

  where
  sql :: SQL
  sql = "SELECT COUNT(*) as total FROM {{path}}"

  msg = "error in query"
  uriPath = queryUrl </> file ("?q=" <> encodeURIComponent (templated res sql))

  readTotal :: JArray -> Maybe Int
  readTotal = I.fromNumber <=< toNumber <=< lookup "total" <=< toObject <=< head

portQuery :: forall e. Resource -> Resource -> SQL -> StrMap VarMapValue -> Aff (RetryEffects (ajax :: AJAX | e)) JObject
portQuery res dest sql vars = do
  guard $ isFile dest
  result <- slamjax $ defaultRequest
    { method = POST
    , headers =
        [ RequestHeader "Destination" $ resourcePath dest
        , ContentType ldJSON
        ]
    , url = printPath $ queryUrl </> rootify (resourceDir res) </> dir (resourceName res) </> file queryVars
    , content = Just (templated res sql)
    }

  if not $ succeeded result.status
    then throwError $ error $ readErr result.response
    else
      -- We expect result message to be valid json.
      either (throwError <<< error) pure $
        jsonParser result.response >>= decodeJson
  where
  readErr :: String -> String
  readErr input =
    case jsonParser input >>= decodeJson >>= (.? "error") of
      -- All response is error text
      Left _ -> input
      -- Error is hided in json message, return only `error` field
      Right err -> err
  -- TODO: This should be somewhere better.
  queryVars :: String
  queryVars = maybe "" makeQueryVars <<< uncons $ toList vars

  pair :: Tuple String VarMapValue -> String
  pair (Tuple a b) = "var." <> a <> "=" <> b

  makeQueryVars { head = h, tail = t } =
    foldl (\a v -> a <> "&" <> pair v) ("?" <> pair h) t

portView :: forall e. Resource -> Resource -> SQL -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
portView res dest sql = do
  guard $ isFile dest
  let uri = "sql2:///?q=" <> encodeURIPath (templated res sql)
  saveViewMount dest uri

readError :: forall a. String -> String -> Either String a
readError msg input =
  let responseError = jsonParser input >>= decodeJson >>= (.? "error")
  in either (const $ Left msg) Left responseError

sample :: forall e. Resource -> Maybe Int -> Maybe Int -> Aff (RetryEffects (ajax :: AJAX | e)) JArray
sample res mbOffset mbLimit =
  if not $ isFile res
  then pure []
  else extractJArray <$> (getResponse msg $ retryGet uri)
  where
  msg = "error getting resource sample"
  uri = dataUrl
        </> rootify (resourceDir res)
        </> file ((resourceName res) <>
                  (maybe "" (("?offset=" <>) <<< show) mbOffset) <>
                  (maybe "" (("&limit=" <>) <<< show ) mbLimit))

fields :: forall e. Resource -> Aff (RetryEffects (ajax :: AJAX | e)) (Array String)
fields res = do
  jarr <- sample res (Just 0) (Just 100)
  case jarr of
    [] -> throwError $ error "empty file"
    _ -> pure $ nub $ concat (getFields <$> jarr)

templated :: Resource -> SQL -> SQL
templated res = replace "{{path}}" ("\"" <> resourcePath res <> "\"")

extractJArray :: String -> JArray
extractJArray =
  (foldl folder []) <<< (jsonParser <$>) <<< (split "\n")
  where
  folder :: JArray -> Either _ Json -> JArray
  folder agg (Right j) = agg ++ [j]
  folder agg _ = agg

getFields :: Json -> Array String
getFields json =
  filter (/= "") $ nub $ getFields' [] json

getFields' :: Array String -> Json -> Array String
getFields' [] json = getFields' [""] json
getFields' acc json =
  if isObject json
  then maybe acc (goObj acc) $ toObject json
  else if isArray json
       then maybe acc (goArr acc) $ toArray json
       else acc

goArr :: Array String -> JArray -> Array String
goArr acc arr =
  concat $ getFields' (lift2 append acc $ mkArrIxs arr) <$> arr
  where
  mkArrIxs :: JArray -> Array String
  mkArrIxs jarr = map (show >>> \x -> "[" <> x <> "]") $ range 0 $ length jarr - 1

goObj :: Array String -> JObject -> Array String
goObj acc obj = concat $ (goTuple acc <$> (fromList $ toList obj))

goTuple :: Array String -> Tuple String Json -> Array String
goTuple acc (Tuple key json) =
  getFields' ((\x -> x <> ".\"" <> key <> "\"") <$> acc) json

{-
Copyright 2015 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 Api.Query
  ( query
  , portView
  , portQuery
  , sample
  , fields
  , countWithQuery
  , SQL()
  , templated
  ) where

import Prelude
import Api.Common (RetryEffects(), getResponse, succeeded, retryGet, slamjax, ldJSON)
import Api.Fs (saveViewMount)
import Config.Paths (queryUrl, dataUrl)
import Control.Apply (lift2)
import Control.Bind ((<=<), (>=>))
import Control.Monad.Aff (Aff())
import Control.Monad.Aff.AVar (AVAR())
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.MonadPlus (guard)
import Data.Argonaut.Combinators ((.?))
import Data.Argonaut.Core (JArray(), Json(), JObject(), jsonEmptyObject, isArray, isObject, foldJson, toArray, toObject, toNumber, fromObject)
import Data.Argonaut.Decode (DecodeJson, decodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Array (concat, nub, filter, head, range, length)
import Data.Either (Either(..), either)
import Data.Either.Unsafe (fromRight)
import Data.Foldable (foldl)
import Data.List (uncons, fromList)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Path.Pathy (rootDir, (</>), dir, file, printPath)
import Data.String (split, joinWith, replace)
import Data.StrMap (StrMap(), keys, toList, empty, lookup)
import Data.Tuple (Tuple(..))
import Data.Bifunctor (lmap)
import Model.Notebook.Port (VarMapValue())
import Model.Path (FilePath(), rootify, encodeURIPath)
import Model.Resource (Resource(..), resourcePath, isFile, _name, resourceDir, resourceName)
import Network.HTTP.Affjax (Affjax(), AJAX(), affjax, defaultRequest)
import Network.HTTP.Method (Method(..))
import Network.HTTP.RequestHeader (RequestHeader(..))
import Optic.Core
import Utils (encodeURIComponent)
import qualified Data.Int as I

-- | This is template string where actual path is encoded like {{path}}
type SQL = String

query :: forall e. Resource -> SQL -> Aff (RetryEffects (ajax :: AJAX | e)) (Either String JArray)
query res@(File _) sql = do
  result <- retryGet (mkURI res sql)
  pure
    if succeeded result.status
       then Right (extractJArray result.response)
       else readError "error in query" result.response
  where
  mkURI :: Resource -> SQL -> FilePath
  mkURI res sql =
    queryUrl
    </> rootify (resourceDir res)
    </> dir (resourceName res)
    </> file ("?q=" <> encodeURIComponent (templated res sql))

query _ _ = pure $ Left "Query resource is not a file"

countWithQuery :: forall e. Resource -> Aff (RetryEffects (ajax :: AJAX | e)) Int
countWithQuery res =
  if not $ isFile res
    then pure 0
    else fromMaybe 0 <<< readTotal <<< extractJArray <$> getResponse msg (retryGet uriPath)

  where
  sql :: SQL
  sql = "SELECT COUNT(*) as total FROM {{path}}"

  msg = "error in query"
  uriPath = queryUrl </> file ("?q=" <> encodeURIComponent (templated res sql))

  readTotal :: JArray -> Maybe Int
  readTotal = I.fromNumber <=< toNumber <=< lookup "total" <=< toObject <=< head

portQuery :: forall e. Resource -> Resource -> SQL -> StrMap VarMapValue -> Aff (RetryEffects (ajax :: AJAX | e)) JObject
portQuery res dest sql vars = do
  guard $ isFile dest
  result <- slamjax $ defaultRequest
    { method = POST
    , headers =
        [ RequestHeader "Destination" $ resourcePath dest
        , ContentType ldJSON
        ]
    , url = printPath $ queryUrl </> rootify (resourceDir res) </> dir (resourceName res) </> file queryVars
    , content = Just (templated res sql)
    }

  if not $ succeeded result.status
    then throwError $ error $ readErr result.response
    else
      -- We expect result message to be valid json.
      either (throwError <<< error) pure $
        jsonParser result.response >>= decodeJson
  where
  readErr :: String -> String
  readErr input =
    case jsonParser input >>= decodeJson >>= (.? "error") of
      -- All response is error text
      Left _ -> input
      -- Error is hided in json message, return only `error` field
      Right err -> err
  -- TODO: This should be somewhere better.
  queryVars :: String
  queryVars = maybe "" makeQueryVars <<< uncons $ toList vars

  pair :: Tuple String VarMapValue -> String
  pair (Tuple a b) = a <> "=" <> b

  makeQueryVars { head = h, tail = t } =
    foldl (\a v -> a <> "&" <> pair v) ("?" <> pair h) t

portView :: forall e. Resource -> Resource -> SQL -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
portView res dest sql = do
  guard $ isFile dest
  let uri = "sql2:///?q=" <> encodeURIPath (templated res sql)
  saveViewMount dest uri

readError :: forall a. String -> String -> Either String a
readError msg input =
  let responseError = jsonParser input >>= decodeJson >>= (.? "error")
  in either (const $ Left msg) Left responseError

sample :: forall e. Resource -> Maybe Int -> Maybe Int -> Aff (RetryEffects (ajax :: AJAX | e)) JArray
sample res mbOffset mbLimit =
  if not $ isFile res
  then pure []
  else extractJArray <$> (getResponse msg $ retryGet uri)
  where
  msg = "error getting resource sample"
  uri = dataUrl
        </> rootify (resourceDir res)
        </> file ((resourceName res) <>
                  (maybe "" (("?offset=" <>) <<< show) mbOffset) <>
                  (maybe "" (("&limit=" <>) <<< show ) mbLimit))

fields :: forall e. Resource -> Aff (RetryEffects (ajax :: AJAX | e)) (Array String)
fields res = do
  jarr <- sample res (Just 0) (Just 100)
  case jarr of
    [] -> throwError $ error "empty file"
    _ -> pure $ nub $ concat (getFields <$> jarr)

templated :: Resource -> SQL -> SQL
templated res = replace "{{path}}" ("\"" <> resourcePath res <> "\"")

extractJArray :: String -> JArray
extractJArray =
  (foldl folder []) <<< (jsonParser <$>) <<< (split "\n")
  where
  folder :: JArray -> Either _ Json -> JArray
  folder agg (Right j) = agg ++ [j]
  folder agg _ = agg

getFields :: Json -> Array String
getFields json =
  filter (/= "") $ nub $ getFields' [] json

getFields' :: Array String -> Json -> Array String
getFields' [] json = getFields' [""] json
getFields' acc json =
  if isObject json
  then maybe acc (goObj acc) $ toObject json
  else if isArray json
       then maybe acc (goArr acc) $ toArray json
       else acc

goArr :: Array String -> JArray -> Array String
goArr acc arr =
  concat $ getFields' (lift2 append acc $ mkArrIxs arr) <$> arr
  where
  mkArrIxs :: JArray -> Array String
  mkArrIxs jarr = map (show >>> \x -> "[" <> x <> "]") $ range 0 $ length jarr - 1

goObj :: Array String -> JObject -> Array String
goObj acc obj = concat $ (goTuple acc <$> (fromList $ toList obj))

goTuple :: Array String -> Tuple String Json -> Array String
goTuple acc (Tuple key json) =
  getFields' ((\x -> x <> ".\"" <> key <> "\"") <$> acc) json


Fix `now`

Fix `now`

module Data.Date
  ( JSDate()
  , Now()
  , Date()
  , Year()
  , Month(..)
  , Day()
  , DayOfWeek()
  , Hours()
  , Minutes()
  , Seconds()
  , Milliseconds()
  , fromJSDate
  , toJSDate
  , now
  , dateTime
  , date
  , year
  , yearUTC
  , month
  , monthUTC
  , day
  , dayUTC
  , dayOfWeek
  , dayOfWeekUTC
  , hour
  , hourUTC
  , minute
  , minuteUTC
  , second
  , secondUTC
  , millisecond
  , millisecondUTC
  , timezoneOffset
  , toEpochMilliseconds
  , fromEpochMilliseconds
  , fromString
  ) where

import Control.Monad.Eff
import Data.Enum
import Data.Maybe
import qualified Data.Maybe.Unsafe as U

foreign import jsDateMethod
  "function jsDateMethod(method) { \
  \  return function(date) { \
  \    return date[method](); \
  \  }; \
  \}" :: forall a. String -> JSDate -> a

foreign import jsDateConstructor
  "function jsDateConstructor(x) { \
  \  return new Date(x); \
  \}" :: forall a. a -> JSDate

foreign import jsDateFromRecord
  "function jsDateFromRecord(r) {\
  \  return new Date(r.year, r.month, r.day, r.hours, r.minutes, r.seconds, r.milliseconds); \
  \}" :: { year :: Number
         , month :: Number
         , day :: Number
         , hours :: Number
         , minutes :: Number
         , seconds :: Number
         , milliseconds :: Number } -> JSDate

foreign import data JSDate :: *
foreign import data Now :: !

data Date = DateTime JSDate

instance eqDate :: Eq Date where
  (==) = liftOp (==)
  (/=) = liftOp (/=)

instance ordDate :: Ord Date where
  compare = liftOp compare

liftOp :: forall b. (Number -> Number -> b) -> Date -> Date -> b
liftOp op x y = toEpochMilliseconds x `op` toEpochMilliseconds y

type Year = Number

data Month
  = January
  | February
  | March
  | April
  | May
  | June
  | July
  | August
  | September
  | October
  | November
  | December

type Day = Number

data DayOfWeek
  = Sunday
  | Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday

type Hours = Number
type Minutes = Number
type Seconds = Number
type Milliseconds = Number

instance enumMonth :: Enum Month where

  toEnum 0  = Just January
  toEnum 1  = Just February
  toEnum 2  = Just March
  toEnum 3  = Just April
  toEnum 4  = Just May
  toEnum 5  = Just June
  toEnum 6  = Just July
  toEnum 7  = Just August
  toEnum 8  = Just September
  toEnum 8  = Just October
  toEnum 10 = Just November
  toEnum 11 = Just December
  toEnum _  = Nothing

  fromEnum January   = 0
  fromEnum February  = 1
  fromEnum March     = 2
  fromEnum April     = 3
  fromEnum May       = 4
  fromEnum June      = 5
  fromEnum July      = 6
  fromEnum August    = 7
  fromEnum September = 8
  fromEnum October   = 9
  fromEnum November  = 10
  fromEnum December  = 11

instance showMonth :: Show Month where

  show January   = "January"
  show February  = "February"
  show March     = "March"
  show April     = "April"
  show May       = "May"
  show June      = "June"
  show July      = "July"
  show August    = "August"
  show September = "September"
  show October   = "October"
  show November  = "November"
  show December  = "December"

instance enumDayOfWeek :: Enum DayOfWeek where

  toEnum 0  = Just Sunday
  toEnum 1  = Just Monday
  toEnum 2  = Just Tuesday
  toEnum 3  = Just Wednesday
  toEnum 4  = Just Thursday
  toEnum 5  = Just Friday
  toEnum 6  = Just Saturday
  toEnum _  = Nothing

  fromEnum Sunday    = 0
  fromEnum Monday    = 1
  fromEnum Tuesday   = 2
  fromEnum Wednesday = 3
  fromEnum Thursday  = 4
  fromEnum Friday    = 5
  fromEnum Saturday  = 6

instance showDayOfWeek :: Show DayOfWeek where

  show Sunday    = "Sunday"
  show Monday    = "Monday"
  show Tuesday   = "Tuesday"
  show Wednesday = "Wednesday"
  show Thursday  = "Thursday"
  show Friday    = "Friday"
  show Saturday  = "Saturday"

fromJSDate :: JSDate -> Maybe Date
fromJSDate d = if Global.isNaN (jsDateMethod "getTime" d)
               then Nothing
               else Just $ DateTime d

toJSDate :: Date -> JSDate
toJSDate (DateTime d) = d

liftDate :: forall a. (JSDate -> a) -> Date -> a
liftDate f (DateTime d) = f d

foreign import nowImpl
  "function nowImpl(f) { \
  \  return f(new Date()); \
  \}" :: forall e. (JSDate -> Date) -> Eff (now :: Now | e) Date

now :: forall e. Eff (now :: Now | e) Date
now = nowImpl DateTime

dateTime :: Year -> Month -> Day
         -> Hours -> Minutes -> Seconds -> Milliseconds
         -> Maybe Date
dateTime y m d h n s ms =
  fromJSDate $ jsDateFromRecord { year: y
                                , month: (fromEnum m)
                                , day: d
                                , hours: h
                                , minutes: n
                                , seconds: s
                                , milliseconds: ms }

date :: Year -> Month -> Day -> Maybe Date
date y m d = dateTime y m d 0 0 0 0

year :: Date -> Year
year = liftDate $ jsDateMethod "getFullYear"

yearUTC :: Date -> Year
yearUTC = liftDate $ jsDateMethod "getUTCFullYear"

month :: Date -> Month
month = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getMonth")

monthUTC :: Date -> Month
monthUTC = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCMonth")

day :: Date -> Day
day = liftDate $ jsDateMethod "getDate"

dayUTC :: Date -> Day
dayUTC = liftDate $ jsDateMethod "getUTCDate"

dayOfWeek :: Date -> DayOfWeek
dayOfWeek = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getDay")

dayOfWeekUTC :: Date -> DayOfWeek
dayOfWeekUTC = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCDay")

hour :: Date -> Hours
hour = liftDate $ jsDateMethod "getHours"

hourUTC :: Date -> Hours
hourUTC = liftDate $ jsDateMethod "getUTCHours"

minute :: Date -> Minutes
minute = liftDate $ jsDateMethod "getMinutes"

minuteUTC :: Date -> Minutes
minuteUTC = liftDate $ jsDateMethod "getUTCMinutes"

second :: Date -> Seconds
second = liftDate $ jsDateMethod "getSeconds"

secondUTC :: Date -> Seconds
secondUTC = liftDate $ jsDateMethod "getUTCSeconds"

millisecond :: Date -> Seconds
millisecond = liftDate $ jsDateMethod "getMilliseconds"

millisecondUTC :: Date -> Seconds
millisecondUTC = liftDate $ jsDateMethod "getUTCMilliseconds"

timezoneOffset :: Date -> Minutes
timezoneOffset = liftDate $ jsDateMethod "getTimezoneOffset"

toEpochMilliseconds :: Date -> Milliseconds
toEpochMilliseconds = liftDate $ jsDateMethod "getTime"

fromEpochMilliseconds :: Milliseconds -> Maybe Date
fromEpochMilliseconds = fromJSDate <<< jsDateConstructor

fromString :: String -> Maybe Date
fromString = fromJSDate <<< jsDateConstructor

instance showDate :: Show Date where
  show = liftDate $ jsDateMethod "toString"

module Data.Date
  ( JSDate()
  , Now()
  , Date()
  , Year()
  , Month(..)
  , Day()
  , DayOfWeek()
  , Hours()
  , Minutes()
  , Seconds()
  , Milliseconds()
  , fromJSDate
  , toJSDate
  , now
  , dateTime
  , date
  , year
  , yearUTC
  , month
  , monthUTC
  , day
  , dayUTC
  , dayOfWeek
  , dayOfWeekUTC
  , hour
  , hourUTC
  , minute
  , minuteUTC
  , second
  , secondUTC
  , millisecond
  , millisecondUTC
  , timezoneOffset
  , toEpochMilliseconds
  , fromEpochMilliseconds
  , fromString
  ) where

import Control.Monad.Eff
import Data.Enum
import Data.Maybe
import qualified Data.Maybe.Unsafe as U

foreign import jsDateMethod
  "function jsDateMethod(method) { \
  \  return function(date) { \
  \    return date[method](); \
  \  }; \
  \}" :: forall a. String -> JSDate -> a

foreign import jsDateConstructor
  "function jsDateConstructor(x) { \
  \  return new Date(x); \
  \}" :: forall a. a -> JSDate

foreign import jsDateFromRecord
  "function jsDateFromRecord(r) {\
  \  return new Date(r.year, r.month, r.day, r.hours, r.minutes, r.seconds, r.milliseconds); \
  \}" :: { year :: Number
         , month :: Number
         , day :: Number
         , hours :: Number
         , minutes :: Number
         , seconds :: Number
         , milliseconds :: Number } -> JSDate

foreign import data JSDate :: *
foreign import data Now :: !

data Date = DateTime JSDate

instance eqDate :: Eq Date where
  (==) = liftOp (==)
  (/=) = liftOp (/=)

instance ordDate :: Ord Date where
  compare = liftOp compare

liftOp :: forall b. (Number -> Number -> b) -> Date -> Date -> b
liftOp op x y = toEpochMilliseconds x `op` toEpochMilliseconds y

type Year = Number

data Month
  = January
  | February
  | March
  | April
  | May
  | June
  | July
  | August
  | September
  | October
  | November
  | December

type Day = Number

data DayOfWeek
  = Sunday
  | Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday

type Hours = Number
type Minutes = Number
type Seconds = Number
type Milliseconds = Number

instance enumMonth :: Enum Month where

  toEnum 0  = Just January
  toEnum 1  = Just February
  toEnum 2  = Just March
  toEnum 3  = Just April
  toEnum 4  = Just May
  toEnum 5  = Just June
  toEnum 6  = Just July
  toEnum 7  = Just August
  toEnum 8  = Just September
  toEnum 8  = Just October
  toEnum 10 = Just November
  toEnum 11 = Just December
  toEnum _  = Nothing

  fromEnum January   = 0
  fromEnum February  = 1
  fromEnum March     = 2
  fromEnum April     = 3
  fromEnum May       = 4
  fromEnum June      = 5
  fromEnum July      = 6
  fromEnum August    = 7
  fromEnum September = 8
  fromEnum October   = 9
  fromEnum November  = 10
  fromEnum December  = 11

instance showMonth :: Show Month where

  show January   = "January"
  show February  = "February"
  show March     = "March"
  show April     = "April"
  show May       = "May"
  show June      = "June"
  show July      = "July"
  show August    = "August"
  show September = "September"
  show October   = "October"
  show November  = "November"
  show December  = "December"

instance enumDayOfWeek :: Enum DayOfWeek where

  toEnum 0  = Just Sunday
  toEnum 1  = Just Monday
  toEnum 2  = Just Tuesday
  toEnum 3  = Just Wednesday
  toEnum 4  = Just Thursday
  toEnum 5  = Just Friday
  toEnum 6  = Just Saturday
  toEnum _  = Nothing

  fromEnum Sunday    = 0
  fromEnum Monday    = 1
  fromEnum Tuesday   = 2
  fromEnum Wednesday = 3
  fromEnum Thursday  = 4
  fromEnum Friday    = 5
  fromEnum Saturday  = 6

instance showDayOfWeek :: Show DayOfWeek where

  show Sunday    = "Sunday"
  show Monday    = "Monday"
  show Tuesday   = "Tuesday"
  show Wednesday = "Wednesday"
  show Thursday  = "Thursday"
  show Friday    = "Friday"
  show Saturday  = "Saturday"

fromJSDate :: JSDate -> Maybe Date
fromJSDate d = if Global.isNaN (jsDateMethod "getTime" d)
               then Nothing
               else Just $ DateTime d

toJSDate :: Date -> JSDate
toJSDate (DateTime d) = d

liftDate :: forall a. (JSDate -> a) -> Date -> a
liftDate f (DateTime d) = f d

foreign import nowImpl
  "function now(f) { \
  \  return f(new Date()); \
  \}" :: forall e. (JSDate -> Date) -> Eff (now :: Now | e) Date

now :: forall e. Eff (now :: Now | e) Date
now = nowImpl DateTime

dateTime :: Year -> Month -> Day
         -> Hours -> Minutes -> Seconds -> Milliseconds
         -> Maybe Date
dateTime y m d h n s ms =
  fromJSDate $ jsDateFromRecord { year: y
                                , month: (fromEnum m)
                                , day: d
                                , hours: h
                                , minutes: n
                                , seconds: s
                                , milliseconds: ms }

date :: Year -> Month -> Day -> Maybe Date
date y m d = dateTime y m d 0 0 0 0

year :: Date -> Year
year = liftDate $ jsDateMethod "getFullYear"

yearUTC :: Date -> Year
yearUTC = liftDate $ jsDateMethod "getUTCFullYear"

month :: Date -> Month
month = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getMonth")

monthUTC :: Date -> Month
monthUTC = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCMonth")

day :: Date -> Day
day = liftDate $ jsDateMethod "getDate"

dayUTC :: Date -> Day
dayUTC = liftDate $ jsDateMethod "getUTCDate"

dayOfWeek :: Date -> DayOfWeek
dayOfWeek = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getDay")

dayOfWeekUTC :: Date -> DayOfWeek
dayOfWeekUTC = U.fromJust <<< toEnum <<< liftDate (jsDateMethod "getUTCDay")

hour :: Date -> Hours
hour = liftDate $ jsDateMethod "getHours"

hourUTC :: Date -> Hours
hourUTC = liftDate $ jsDateMethod "getUTCHours"

minute :: Date -> Minutes
minute = liftDate $ jsDateMethod "getMinutes"

minuteUTC :: Date -> Minutes
minuteUTC = liftDate $ jsDateMethod "getUTCMinutes"

second :: Date -> Seconds
second = liftDate $ jsDateMethod "getSeconds"

secondUTC :: Date -> Seconds
secondUTC = liftDate $ jsDateMethod "getUTCSeconds"

millisecond :: Date -> Seconds
millisecond = liftDate $ jsDateMethod "getMilliseconds"

millisecondUTC :: Date -> Seconds
millisecondUTC = liftDate $ jsDateMethod "getUTCMilliseconds"

timezoneOffset :: Date -> Minutes
timezoneOffset = liftDate $ jsDateMethod "getTimezoneOffset"

toEpochMilliseconds :: Date -> Milliseconds
toEpochMilliseconds = liftDate $ jsDateMethod "getTime"

fromEpochMilliseconds :: Milliseconds -> Maybe Date
fromEpochMilliseconds = fromJSDate <<< jsDateConstructor

fromString :: String -> Maybe Date
fromString = fromJSDate <<< jsDateConstructor

instance showDate :: Show Date where
  show = liftDate $ jsDateMethod "toString"


Simplify

Simplify

module Data.Enum
  ( class Enum, succ, pred
  , defaultSucc
  , defaultPred
  , enumFromTo
  , enumFromThenTo
  , upFrom
  , downFrom
  , Cardinality(..)
  , class BoundedEnum, cardinality, toEnum, fromEnum, toEnumWithDefaults
  , defaultCardinality
  , defaultToEnum
  , defaultFromEnum
  ) where

import Prelude

import Control.MonadPlus (guard)

import Data.Char (fromCharCode, toCharCode)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe, fromJust)
import Data.Newtype (class Newtype, unwrap)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable, unfoldr)

import Partial.Unsafe (unsafePartial)

newtype Cardinality a = Cardinality Int

derive instance newtypeCardinality :: Newtype (Cardinality a) _

derive newtype instance eqCardinality :: Eq (Cardinality a)

derive newtype instance ordCardinality :: Ord (Cardinality a)

-- | Type class for enumerations.
-- |
-- | Laws:
-- | - `succ a > pred a`
-- | - `pred a < succ a`
-- | - `pred >=> succ >=> pred = pred`
-- | - `succ >=> pred >=> succ = succ`
class Ord a <= Enum a where
  succ :: a -> Maybe a
  pred :: a -> Maybe a

instance enumBoolean :: Enum Boolean where
  succ false = Just true
  succ _ = Nothing
  pred true = Just false
  pred _= Nothing

instance enumInt :: Enum Int where
  succ n = if n < top then Just (n + 1) else Nothing
  pred n = if n > bottom then Just (n - 1) else Nothing

instance enumChar :: Enum Char where
  succ = defaultSucc charToEnum toCharCode
  pred = defaultPred charToEnum toCharCode

charToEnum :: Int -> Maybe Char
charToEnum n | n >= bottom && n <= top = Just $ fromCharCode n
charToEnum _ = Nothing

instance enumUnit :: Enum Unit where
  succ = const Nothing
  pred = const Nothing

instance enumOrdering :: Enum Ordering where
  succ LT = Just EQ
  succ EQ = Just GT
  succ GT = Nothing
  pred LT = Nothing
  pred EQ = Just LT
  pred GT = Just EQ

instance enumMaybe :: BoundedEnum a => Enum (Maybe a) where
  succ Nothing = Just $ Just bottom
  succ (Just a) = Just <$> succ a
  pred Nothing = Nothing
  pred (Just a) = Just $ pred a

instance enumEither :: (BoundedEnum a, BoundedEnum b) => Enum (Either a b) where
  succ (Left a) = maybe (Just $ Right bottom) (Just <<< Left) (succ a)
  succ (Right b) = maybe (Nothing) (Just <<< Right) (succ b)
  pred (Left a) = maybe (Nothing) (Just <<< Left) (pred a)
  pred (Right b) = maybe (Just $ Left top) (Just <<< Right) (pred b)

instance enumTuple :: (Enum a, BoundedEnum b) => Enum (Tuple a b) where
  succ (Tuple a b) = maybe (flip Tuple bottom <$> succ a) (Just <<< Tuple a) (succ b)
  pred (Tuple a b) = maybe (flip Tuple top <$> pred a) (Just <<< Tuple a) (pred b)

-- | ```defaultSucc toEnum fromEnum = succ```
defaultSucc :: forall a. (Int -> Maybe a) -> (a -> Int) -> a -> Maybe a
defaultSucc toEnum' fromEnum' a = toEnum' (fromEnum' a + 1)

-- | ```defaultPred toEnum fromEnum = pred```
defaultPred :: forall a. (Int -> Maybe a) -> (a -> Int) -> a -> Maybe a
defaultPred toEnum' fromEnum' a = toEnum' (fromEnum' a - 1)

-- | Returns a successive sequence of elements from the lower bound to
-- | the upper bound (inclusive).
enumFromTo :: forall a u. (Enum a, Unfoldable u) => a -> a -> u a
enumFromTo from to = unfoldr go (Just from)
  where
    go mx = do
      x <- mx
      guard (x <= to)
      pure $ Tuple x (succ x)

-- | `[a,b..c]`
enumFromThenTo :: forall a. BoundedEnum a => a -> a -> a -> Array a
enumFromThenTo = unsafePartial \a b c ->
  let a' = fromEnum a
      b' = fromEnum b
      c' = fromEnum c
  in (toEnum >>> fromJust) <$> intStepFromTo (b' - a') a' c'

-- | Property: ```forall e in intStepFromTo step a b: a <= e <= b```
intStepFromTo :: Int -> Int -> Int -> Array Int
intStepFromTo step from to =
  unfoldr (\e ->
            if e <= to
            then Just $ Tuple e (e + step)  -- Output the value e, set the next state to (e + step)
            else Nothing                    -- End of the collection.
          ) from

diag :: forall a. a -> Tuple a a
diag a = Tuple a a

upFrom :: forall a u. (Enum a, Unfoldable u) => a -> u a
upFrom = unfoldr (map diag <<< succ)

downFrom :: forall a u. (Enum a, Unfoldable u) => a -> u a
downFrom = unfoldr (map diag <<< pred)

-- | Type class for finite enumerations.
-- |
-- | This should not be considered a part of a numeric hierarchy, as in Haskell.
-- | Rather, this is a type class for small, ordered sum types with
-- | statically-determined cardinality and the ability to easily compute
-- | successor and predecessor elements, e.g. `DayOfWeek`.
-- |
-- | Laws:
-- |
-- | - ```succ bottom >>= succ >>= succ ... succ [cardinality - 1 times] == top```
-- | - ```pred top    >>= pred >>= pred ... pred [cardinality - 1 times] == bottom```
-- | - ```forall a > bottom: pred a >>= succ == Just a```
-- | - ```forall a < top:  succ a >>= pred == Just a```
-- | - ```forall a > bottom: fromEnum <$> pred a = Just (fromEnum a - 1)```
-- | - ```forall a < top:  fromEnum <$> succ a = Just (fromEnum a + 1)```
-- | - ```e1 `compare` e2 == fromEnum e1 `compare` fromEnum e2```
-- | - ```toEnum (fromEnum a) = Just a```
class (Bounded a, Enum a) <= BoundedEnum a where
  cardinality :: Cardinality a
  toEnum :: Int -> Maybe a
  fromEnum :: a -> Int

instance boundedEnumBoolean :: BoundedEnum Boolean where
  cardinality = Cardinality 2
  toEnum 0 = Just false
  toEnum 1 = Just true
  toEnum _ = Nothing
  fromEnum false = 0
  fromEnum true = 1

instance boundedEnumInt :: BoundedEnum Int where
  cardinality = Cardinality (top - bottom)
  toEnum = Just
  fromEnum = id

instance boundedEnumChar :: BoundedEnum Char where
  cardinality = Cardinality (toCharCode top - toCharCode bottom)
  toEnum = charToEnum
  fromEnum = toCharCode

instance boundedEnumUnit :: BoundedEnum Unit where
  cardinality = Cardinality 1
  toEnum 0 = Just unit
  toEnum _ = Nothing
  fromEnum = const 0

instance boundedEnumOrdering :: BoundedEnum Ordering where
  cardinality = Cardinality 3
  toEnum 0 = Just LT
  toEnum 1 = Just EQ
  toEnum 2 = Just GT
  toEnum _ = Nothing
  fromEnum LT = 0
  fromEnum EQ = 1
  fromEnum GT = 2

instance boundedEnumMaybe :: BoundedEnum a => BoundedEnum (Maybe a) where
  cardinality = Cardinality $ unwrap (cardinality :: Cardinality a) + 1
  toEnum 0 = pure Nothing
  toEnum n = Just <$> toEnum (n - 1)
  fromEnum Nothing = 0
  fromEnum (Just e) = fromEnum e + 1

instance boundedEnumEither :: (BoundedEnum a, BoundedEnum b) => BoundedEnum (Either a b) where
  cardinality =
    Cardinality
      $ unwrap (cardinality :: Cardinality a)
      + unwrap (cardinality :: Cardinality b)
  toEnum = to cardinality cardinality
    where
    to :: Cardinality a -> Cardinality (Either a b) -> Int -> Maybe (Either a b)
    to (Cardinality ca) (Cardinality cab) n
      | n >= 0 && n < ca = Left <$> toEnum n
      | n >= ca && n < cab = Right <$> toEnum (n - ca)
      | otherwise = Nothing
  fromEnum (Left a) = fromEnum a
  fromEnum (Right b) = fromEnum b + unwrap (cardinality :: Cardinality a)

instance boundedEnumTuple :: (BoundedEnum a, BoundedEnum b) => BoundedEnum (Tuple a b) where
  cardinality =
    Cardinality
      $ unwrap (cardinality :: Cardinality a)
      * unwrap (cardinality :: Cardinality b)
  toEnum = to cardinality
    where
    to :: Cardinality b -> Int -> Maybe (Tuple a b)
    to (Cardinality cb) n = Tuple <$> toEnum (n / cb) <*> toEnum (n `mod` cb)
  fromEnum = from cardinality
    where
    from :: Cardinality b -> Tuple a b -> Int
    from (Cardinality cb) (Tuple a b) = fromEnum a * cb + fromEnum b

-- | Runs in `O(n)` where `n` is `fromEnum top`
defaultCardinality :: forall a. (Bounded a, Enum a) => Cardinality a
defaultCardinality = Cardinality $ defaultCardinality' 1 (bottom :: a) where
  defaultCardinality' i = maybe i (defaultCardinality' $ i + 1) <<< succ

  -- | Runs in `O(n)` where `n` is `fromEnum a`
defaultToEnum :: forall a. (Bounded a, Enum a) => Int -> Maybe a
defaultToEnum n
  | n < 0 = Nothing
  | n == 0 = Just bottom
  | otherwise = defaultToEnum (n - 1) >>= succ

  -- | Runs in `O(n)` where `n` is `fromEnum a`
defaultFromEnum :: forall a. Enum a => a -> Int
defaultFromEnum = maybe 0 (\prd -> defaultFromEnum prd + 1) <<< pred

-- | Like `toEnum` but returns the first argument if `x` is less than
-- | `fromEnum bottom` and the second argument if `x` is greater than
-- | `fromEnum top`.
-- |
-- | ``` purescript
-- | toEnumWithDefaults False True (-1) -- False
-- | toEnumWithDefaults False True 0    -- False
-- | toEnumWithDefaults False True 1    -- True
-- | toEnumWithDefaults False True 2    -- True
-- | ```
toEnumWithDefaults :: forall a. BoundedEnum a => a -> a -> Int -> a
toEnumWithDefaults b t x = case toEnum x of
  Just enum -> enum
  Nothing -> if x < fromEnum (bottom :: a) then b else t

module Data.Enum
  ( class Enum, succ, pred
  , defaultSucc
  , defaultPred
  , enumFromTo
  , enumFromThenTo
  , upFrom
  , downFrom
  , Cardinality(..)
  , class BoundedEnum, cardinality, toEnum, fromEnum, toEnumWithDefaults
  , defaultCardinality
  , defaultToEnum
  , defaultFromEnum
  ) where

import Prelude

import Control.MonadPlus (guard)

import Data.Char (fromCharCode, toCharCode)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe, fromJust)
import Data.Newtype (class Newtype, unwrap)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (class Unfoldable, unfoldr)

import Partial.Unsafe (unsafePartial)

newtype Cardinality a = Cardinality Int

derive instance newtypeCardinality :: Newtype (Cardinality a) _

derive newtype instance eqCardinality :: Eq (Cardinality a)

derive newtype instance ordCardinality :: Ord (Cardinality a)

-- | Type class for enumerations.
-- |
-- | Laws:
-- | - `succ a > pred a`
-- | - `pred a < succ a`
-- | - `pred >=> succ >=> pred = pred`
-- | - `succ >=> pred >=> succ = succ`
class Ord a <= Enum a where
  succ :: a -> Maybe a
  pred :: a -> Maybe a

instance enumBoolean :: Enum Boolean where
  succ false = Just true
  succ _ = Nothing
  pred true = Just false
  pred _= Nothing

instance enumInt :: Enum Int where
  succ n = if n < top then Just (n + 1) else Nothing
  pred n = if n > bottom then Just (n - 1) else Nothing

instance enumChar :: Enum Char where
  succ = defaultSucc charToEnum toCharCode
  pred = defaultPred charToEnum toCharCode

charToEnum :: Int -> Maybe Char
charToEnum n | n >= bottom && n <= top = Just $ fromCharCode n
charToEnum _ = Nothing

instance enumUnit :: Enum Unit where
  succ = const Nothing
  pred = const Nothing

instance enumOrdering :: Enum Ordering where
  succ LT = Just EQ
  succ EQ = Just GT
  succ GT = Nothing
  pred LT = Nothing
  pred EQ = Just LT
  pred GT = Just EQ

instance enumMaybe :: BoundedEnum a => Enum (Maybe a) where
  succ Nothing = Just $ Just bottom
  succ (Just a) = Just <$> succ a
  pred Nothing = Nothing
  pred (Just a) = Just $ pred a

instance enumEither :: (BoundedEnum a, BoundedEnum b) => Enum (Either a b) where
  succ (Left a) = maybe (Just $ Right bottom) (Just <<< Left) (succ a)
  succ (Right b) = maybe (Nothing) (Just <<< Right) (succ b)
  pred (Left a) = maybe (Nothing) (Just <<< Left) (pred a)
  pred (Right b) = maybe (Just $ Left top) (Just <<< Right) (pred b)

instance enumTuple :: (Enum a, BoundedEnum b) => Enum (Tuple a b) where
  succ (Tuple a b) = maybe (flip Tuple bottom <$> succ a) (Just <<< Tuple a) (succ b)
  pred (Tuple a b) = maybe (flip Tuple top <$> pred a) (Just <<< Tuple a) (pred b)

-- | ```defaultSucc toEnum fromEnum = succ```
defaultSucc :: forall a. (Int -> Maybe a) -> (a -> Int) -> a -> Maybe a
defaultSucc toEnum' fromEnum' a = toEnum' (fromEnum' a + 1)

-- | ```defaultPred toEnum fromEnum = pred```
defaultPred :: forall a. (Int -> Maybe a) -> (a -> Int) -> a -> Maybe a
defaultPred toEnum' fromEnum' a = toEnum' (fromEnum' a - 1)

-- | Returns a successive sequence of elements from the lower bound to
-- | the upper bound (inclusive).
enumFromTo :: forall a u. (Enum a, Unfoldable u) => a -> a -> u a
enumFromTo from to = unfoldr go (Just from)
  where
    go mx = do
      x <- mx
      guard (x <= to)
      pure $ Tuple x (succ x)

-- | `[a,b..c]`
enumFromThenTo :: forall a. BoundedEnum a => a -> a -> a -> Array a
enumFromThenTo = unsafePartial \a b c ->
  let a' = fromEnum a
      b' = fromEnum b
      c' = fromEnum c
  in (toEnum >>> fromJust) <$> intStepFromTo (b' - a') a' c'

-- | Property: ```forall e in intStepFromTo step a b: a <= e <= b```
intStepFromTo :: Int -> Int -> Int -> Array Int
intStepFromTo step from to =
  unfoldr (\e ->
            if e <= to
            then Just $ Tuple e (e + step)  -- Output the value e, set the next state to (e + step)
            else Nothing                    -- End of the collection.
          ) from

diag :: forall a. a -> Tuple a a
diag a = Tuple a a

upFrom :: forall a u. (Enum a, Unfoldable u) => a -> u a
upFrom = unfoldr (map diag <<< succ)

downFrom :: forall a u. (Enum a, Unfoldable u) => a -> u a
downFrom = unfoldr (map diag <<< pred)

-- | Type class for finite enumerations.
-- |
-- | This should not be considered a part of a numeric hierarchy, as in Haskell.
-- | Rather, this is a type class for small, ordered sum types with
-- | statically-determined cardinality and the ability to easily compute
-- | successor and predecessor elements, e.g. `DayOfWeek`.
-- |
-- | Laws:
-- |
-- | - ```succ bottom >>= succ >>= succ ... succ [cardinality - 1 times] == top```
-- | - ```pred top    >>= pred >>= pred ... pred [cardinality - 1 times] == bottom```
-- | - ```forall a > bottom: pred a >>= succ == Just a```
-- | - ```forall a < top:  succ a >>= pred == Just a```
-- | - ```forall a > bottom: fromEnum <$> pred a = Just (fromEnum a - 1)```
-- | - ```forall a < top:  fromEnum <$> succ a = Just (fromEnum a + 1)```
-- | - ```e1 `compare` e2 == fromEnum e1 `compare` fromEnum e2```
-- | - ```toEnum (fromEnum a) = Just a```
class (Bounded a, Enum a) <= BoundedEnum a where
  cardinality :: Cardinality a
  toEnum :: Int -> Maybe a
  fromEnum :: a -> Int

instance boundedEnumBoolean :: BoundedEnum Boolean where
  cardinality = Cardinality 2
  toEnum 0 = Just false
  toEnum 1 = Just true
  toEnum _ = Nothing
  fromEnum false = 0
  fromEnum true = 1

instance boundedEnumInt :: BoundedEnum Int where
  cardinality = Cardinality (top - bottom)
  toEnum = Just
  fromEnum = id

instance boundedEnumChar :: BoundedEnum Char where
  cardinality = Cardinality (toCharCode top - toCharCode bottom)
  toEnum = charToEnum
  fromEnum = toCharCode

instance boundedEnumUnit :: BoundedEnum Unit where
  cardinality = Cardinality 1
  toEnum 0 = Just unit
  toEnum _ = Nothing
  fromEnum = const 0

instance boundedEnumOrdering :: BoundedEnum Ordering where
  cardinality = Cardinality 3
  toEnum 0 = Just LT
  toEnum 1 = Just EQ
  toEnum 2 = Just GT
  toEnum _ = Nothing
  fromEnum LT = 0
  fromEnum EQ = 1
  fromEnum GT = 2

instance boundedEnumMaybe :: BoundedEnum a => BoundedEnum (Maybe a) where
  cardinality = Cardinality $ unwrap (cardinality :: Cardinality a) + 1
  toEnum = to cardinality
    where
    to :: Cardinality a -> Int -> Maybe (Maybe a)
    to _ 0 = Just Nothing
    to (Cardinality ca) n | n > 0 && n <= ca = Just $ toEnum (n - 1)
    to _ _ = Nothing
  fromEnum Nothing = 0
  fromEnum (Just e) = fromEnum e + 1

instance boundedEnumEither :: (BoundedEnum a, BoundedEnum b) => BoundedEnum (Either a b) where
  cardinality =
    Cardinality
      $ unwrap (cardinality :: Cardinality a)
      + unwrap (cardinality :: Cardinality b)
  toEnum = to cardinality cardinality
    where
    to :: Cardinality a -> Cardinality (Either a b) -> Int -> Maybe (Either a b)
    to (Cardinality ca) (Cardinality cab) n
      | n >= 0 && n < ca = Left <$> toEnum n
      | n >= ca && n < cab = Right <$> toEnum (n - ca)
      | otherwise = Nothing
  fromEnum (Left a) = fromEnum a
  fromEnum (Right b) = fromEnum b + unwrap (cardinality :: Cardinality a)

instance boundedEnumTuple :: (BoundedEnum a, BoundedEnum b) => BoundedEnum (Tuple a b) where
  cardinality =
    Cardinality
      $ unwrap (cardinality :: Cardinality a)
      * unwrap (cardinality :: Cardinality b)
  toEnum = to cardinality
    where
    to :: Cardinality b -> Int -> Maybe (Tuple a b)
    to (Cardinality cb) n = Tuple <$> toEnum (n / cb) <*> toEnum (n `mod` cb)
  fromEnum = from cardinality
    where
    from :: Cardinality b -> Tuple a b -> Int
    from (Cardinality cb) (Tuple a b) = fromEnum a * cb + fromEnum b

-- | Runs in `O(n)` where `n` is `fromEnum top`
defaultCardinality :: forall a. (Bounded a, Enum a) => Cardinality a
defaultCardinality = Cardinality $ defaultCardinality' 1 (bottom :: a) where
  defaultCardinality' i = maybe i (defaultCardinality' $ i + 1) <<< succ

  -- | Runs in `O(n)` where `n` is `fromEnum a`
defaultToEnum :: forall a. (Bounded a, Enum a) => Int -> Maybe a
defaultToEnum n
  | n < 0 = Nothing
  | n == 0 = Just bottom
  | otherwise = defaultToEnum (n - 1) >>= succ

  -- | Runs in `O(n)` where `n` is `fromEnum a`
defaultFromEnum :: forall a. Enum a => a -> Int
defaultFromEnum = maybe 0 (\prd -> defaultFromEnum prd + 1) <<< pred

-- | Like `toEnum` but returns the first argument if `x` is less than
-- | `fromEnum bottom` and the second argument if `x` is greater than
-- | `fromEnum top`.
-- |
-- | ``` purescript
-- | toEnumWithDefaults False True (-1) -- False
-- | toEnumWithDefaults False True 0    -- False
-- | toEnumWithDefaults False True 1    -- True
-- | toEnumWithDefaults False True 2    -- True
-- | ```
toEnumWithDefaults :: forall a. BoundedEnum a => a -> a -> Int -> a
toEnumWithDefaults b t x = case toEnum x of
  Just enum -> enum
  Nothing -> if x < fromEnum (bottom :: a) then b else t