fix Show Data.GetSpotResponse

fix Show Data.GetSpotResponse

module Data.GetSpotResponse (GetSpotResponse(..)) where

import Data.Detail (Detail)
import Data.Foreign (F, Foreign, readString)
import Data.Foreign.Class (class IsForeign, readProp)
import Data.Foreign.Index (prop)
import Data.Foreign.Null (readNull, unNull)
import Data.Maybe (fromMaybe)
import Data.Show (class Show, show)
import Prelude (($), (<>), bind, pure)

data GetSpotResponse = GetSpotResponse
  { id :: Int
  , description :: String -- or null
  , details :: Array Detail
  -- , images :: Array Image
  , lat :: String -- NumberString
  , lng :: String -- NumberString
  , name :: String
  , radius :: String -- NumberString
  , stampByLocation :: Boolean
  , stampByQrCode :: Boolean
  , tagline :: String -- or null
  , zoom :: Int
  }

instance getSpotResponseShow :: Show GetSpotResponse where
  show (GetSpotResponse { id
                        , description
                        , details
                        -- , images :: Array Image
                        , lat
                        , lng
                        , name
                        , radius
                        , stampByLocation
                        , stampByQrCode
                        , tagline
                        , zoom
                        }) =
    "{"
    <> " \"id\": " <> show id <> ","
    <> " \"description\": " <> show description <> ","
    <> " \"details\": " <> show details <> ","
    <> " \"lat\": " <> show lat <> ","
    <> " \"lng\": " <> show lng <> ","
    <> " \"name\": " <> show name <> ","
    <> " \"radius\": " <> show radius <> ","
    <> " \"stampByLocation\": " <> show stampByLocation <> ","
    <> " \"stampByQrCode\": " <> show stampByQrCode <> ","
    <> " \"tagline\": " <> show tagline <> ","
    <> " \"zoom\": " <> show zoom
    <> " }"

readNullProp :: String -> String -> Foreign -> F String
readNullProp p defaultValue o = do
  pv <- prop p o
  ns <- readNull readString pv
  pure $ fromMaybe defaultValue $ unNull ns

instance getSpotResponseIsForeign :: IsForeign GetSpotResponse where
  read value = do
    id <- readProp "id" value
    description <- readNullProp "description" "" value
    details <- readProp "details" value
    lat <- readProp "lat" value
    lng <- readProp "lng" value
    name <- readProp "name" value
    radius <- readProp "radius" value
    stampByLocation <- readProp "stampByLocation" value
    stampByQrCode <- readProp "stampByQrCode" value
    tagline <- readNullProp "tagline" "" value
    zoom <- readProp "zoom" value
    pure $ GetSpotResponse { id
                           , description
                           , details
                           -- , images :: Array Image
                           , lat
                           , lng
                           , name
                           , radius
                           , stampByLocation
                           , stampByQrCode
                           , tagline
                           , zoom
                           }

module Data.GetSpotResponse (GetSpotResponse(..)) where

import Data.Detail (Detail)
import Data.Foreign (F, Foreign, readString)
import Data.Foreign.Class (class IsForeign, readProp)
import Data.Foreign.Index (prop)
import Data.Foreign.Null (readNull, unNull)
import Data.Maybe (fromMaybe)
import Data.Show (class Show, show)
import Prelude (($), (<>), bind, pure)

data GetSpotResponse = GetSpotResponse
  { id :: Int
  , description :: String -- or null
  , details :: Array Detail
  -- , images :: Array Image
  , lat :: String -- NumberString
  , lng :: String -- NumberString
  , name :: String
  , radius :: String -- NumberString
  , stampByLocation :: Boolean
  , stampByQrCode :: Boolean
  , tagline :: String -- or null
  , zoom :: Int
  }

instance getSpotResponseShow :: Show GetSpotResponse where
  show (GetSpotResponse { id
                        , description
                        , details
                        -- , images :: Array Image
                        , lat
                        , lng
                        , name
                        , radius
                        , stampByLocation
                        , stampByQrCode
                        , tagline
                        , zoom
                        }) =
    "{"
    <> " \"id\": " <> show id <> ","
    <> " \"description\": " <> show description <> ","
    <> " \"details\": " <> show details <> ","
    <> " \"lat\": " <> show lat <> ","
    <> " \"lng\": " <> show lng <> ","
    <> " \"name\": " <> show name <> ","
    <> " \"radius\": " <> show radius <> ","
    <> " \"stampByLocation\": " <> show stampByLocation <> ","
    <> " \"stampByQrCode\": " <> show stampByQrCode <> ","
    <> " \"tagline\": " <> show tagline <> ","
    <> " }"

readNullProp :: String -> String -> Foreign -> F String
readNullProp p defaultValue o = do
  pv <- prop p o
  ns <- readNull readString pv
  pure $ fromMaybe defaultValue $ unNull ns

instance getSpotResponseIsForeign :: IsForeign GetSpotResponse where
  read value = do
    id <- readProp "id" value
    description <- readNullProp "description" "" value
    details <- readProp "details" value
    lat <- readProp "lat" value
    lng <- readProp "lng" value
    name <- readProp "name" value
    radius <- readProp "radius" value
    stampByLocation <- readProp "stampByLocation" value
    stampByQrCode <- readProp "stampByQrCode" value
    tagline <- readNullProp "tagline" "" value
    zoom <- readProp "zoom" value
    pure $ GetSpotResponse { id
                           , description
                           , details
                           -- , images :: Array Image
                           , lat
                           , lng
                           , name
                           , radius
                           , stampByLocation
                           , stampByQrCode
                           , tagline
                           , zoom
                           }


Fresh workspace on path change

Fresh workspace on path change

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace (main) where

import SlamData.Prelude

import Control.Coroutine (runProcess, await, ($$))
import Control.Coroutine.Aff (produce)
import Control.Monad.Aff (Aff, forkAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.UI.Browser as Browser

import Ace.Config as AceConfig

import Data.Map.Diff as Diff
import Data.Nullable (toMaybe)

import DOM.HTML.Document (body)
import DOM.HTML (window)
import DOM.HTML.Types (HTMLElement, htmlElementToElement, htmlElementToNode, htmlDocumentToParentNode)
import DOM.HTML.Window (document)
import DOM.Node.Element (setClassName)
import DOM.Node.Node (removeChild)
import DOM.Node.Types (elementToNode)
import DOM.Node.ParentNode (querySelector)

import Halogen (Driver, runUI, parentState, interpret)
import Halogen.Util (runHalogenAff, awaitBody)

import SlamData.Analytics as Analytics
import SlamData.Config as Config
import SlamData.Effects (SlamDataRawEffects, SlamDataEffects)
import SlamData.Monad (runSlam)
import SlamData.Wiring (Wiring(..))
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action (Action(..), toAccessType)
import SlamData.Workspace.Component as Workspace
import SlamData.Workspace.Eval.Persistence as P
import SlamData.Workspace.Routing (Routes(..), routing)
import SlamData.Workspace.StyleLoader as StyleLoader

import Routing as Routing

import Utils.Path as UP

data RouterState = RouterState Routes Wiring (Driver Workspace.QueryP SlamDataRawEffects)

main ∷ Eff SlamDataEffects Unit
main = do
  AceConfig.set AceConfig.basePath (Config.baseUrl ⊕ "js/ace")
  AceConfig.set AceConfig.modePath (Config.baseUrl ⊕ "js/ace")
  AceConfig.set AceConfig.themePath (Config.baseUrl ⊕ "js/ace")
  runHalogenAff do
    forkAff Analytics.enableAnalytics
    forkAff routeSignal
  StyleLoader.loadStyles

routeSignal ∷ Aff SlamDataEffects Unit
routeSignal = do
  runProcess (routeProducer $$ routeConsumer Nothing)

  where
  routeProducer = produce \emit →
    Routing.matches' UP.decodeURIPath routing \_ → emit ∘ Left

  routeConsumer state = do
    new ← await
    case new, state of
      -- Initialize the Workspace component
      WorkspaceRoute path deckId action varMaps, Nothing → do
        wiring ← lift $ Wiring.make path (toAccessType action) varMaps
        mount wiring new

      -- Reload the page on path change or varMap change
      WorkspaceRoute path _ action _, Just (RouterState (WorkspaceRoute path' _ action' _) wiring _)
        | path ≠ path' || toAccessType action ≠ toAccessType action' →
        reload wiring new

      -- Transition Workspace
      WorkspaceRoute path deckId action varMaps, Just (RouterState old wiring driver) →
        case old of
          WorkspaceRoute _ deckId' _ varMaps'
            | deckId ≡ deckId' ∧ varMaps ≡ varMaps' →
                routeConsumer (Just (RouterState new wiring driver))
          WorkspaceRoute _ deckId' _ varMaps' → do
            when (varMaps ≠ varMaps') $ lift do
              Cache.restore varMaps (Wiring.unWiring wiring).varMaps
              runSlam wiring
                $ traverse_ (P.queueEvalForDeck 0)
                $ Diff.updated
                $ Diff.diff varMaps' varMaps
            lift $ setup new driver
            routeConsumer (Just (RouterState new wiring driver))

  reload (Wiring wiring) new@(WorkspaceRoute path _ action varMaps) = do
    wiring' ←
      if path ≡ wiring.path
        then pure $ Wiring wiring { path = path, accessType = toAccessType action }
        else lift $ Wiring.make path (toAccessType action) varMaps
    lift $ removeFromBody ".sd-workspace"
    mount wiring' new

  mount wiring new@(WorkspaceRoute _ _ action _) = do
    let
      st = Workspace.initialState (Just "4.0")
      ui = interpret (runSlam wiring) $ Workspace.comp (toAccessType action)
    driver ← lift $ runUI ui (parentState st) =<< awaitBody'
    lift $ setup new driver
    routeConsumer (Just (RouterState new wiring driver))

  setup new@(WorkspaceRoute _ deckId action varMaps) driver = do
    when (toAccessType action ≡ AT.ReadOnly) do
      isEmbedded ←
        liftEff $ Browser.detectEmbedding
      let
        bodyClass =
          if isEmbedded
            then "sd-workspace-page sd-embedded"
            else "sd-workspace-page"
      void
        $ liftEff
        $ traverse (setClassName bodyClass ∘ htmlElementToElement)
        ∘ toMaybe
        =<< body
        =<< document
        =<< window

    forkAff case action of
      Load _ →
        driver $ Workspace.toWorkspace $ Workspace.Load deckId
      New →
        driver $ Workspace.toWorkspace $ Workspace.New
      Exploring fp →
        driver $ Workspace.toWorkspace $ Workspace.ExploreFile fp

awaitBody' ∷ Aff SlamDataEffects HTMLElement
awaitBody' = do
  body ← liftEff $ map toMaybe $ window >>= document >>= body
  maybe awaitBody pure body

removeFromBody ∷ String → Aff SlamDataEffects Unit
removeFromBody sel = liftEff $ void $ runMaybeT do
  body ← MaybeT $ map toMaybe $ window >>= document >>= body
  root ← MaybeT $ map toMaybe $ window >>= document >>= htmlDocumentToParentNode >>> querySelector sel
  lift $ removeChild (elementToNode root) (htmlElementToNode body)

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace (main) where

import SlamData.Prelude

import Control.Coroutine (runProcess, await, ($$))
import Control.Coroutine.Aff (produce)
import Control.Monad.Aff (Aff, forkAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.UI.Browser as Browser

import Ace.Config as AceConfig

import Data.Map.Diff as Diff
import Data.Nullable (toMaybe)

import DOM.HTML.Document (body)
import DOM.HTML (window)
import DOM.HTML.Types (HTMLElement, htmlElementToElement, htmlElementToNode, htmlDocumentToParentNode)
import DOM.HTML.Window (document)
import DOM.Node.Element (setClassName)
import DOM.Node.Node (removeChild)
import DOM.Node.Types (elementToNode)
import DOM.Node.ParentNode (querySelector)

import Halogen (Driver, runUI, parentState, interpret)
import Halogen.Util (runHalogenAff, awaitBody)

import SlamData.Analytics as Analytics
import SlamData.Config as Config
import SlamData.Effects (SlamDataRawEffects, SlamDataEffects)
import SlamData.Monad (runSlam)
import SlamData.Wiring (Wiring(..))
import SlamData.Wiring as Wiring
import SlamData.Wiring.Cache as Cache
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action (Action(..), toAccessType)
import SlamData.Workspace.Component as Workspace
import SlamData.Workspace.Eval.Persistence as P
import SlamData.Workspace.Routing (Routes(..), routing)
import SlamData.Workspace.StyleLoader as StyleLoader

import Routing as Routing

import Utils.Path as UP

data RouterState = RouterState Routes Wiring (Driver Workspace.QueryP SlamDataRawEffects)

main ∷ Eff SlamDataEffects Unit
main = do
  AceConfig.set AceConfig.basePath (Config.baseUrl ⊕ "js/ace")
  AceConfig.set AceConfig.modePath (Config.baseUrl ⊕ "js/ace")
  AceConfig.set AceConfig.themePath (Config.baseUrl ⊕ "js/ace")
  runHalogenAff do
    forkAff Analytics.enableAnalytics
    forkAff routeSignal
  StyleLoader.loadStyles

routeSignal ∷ Aff SlamDataEffects Unit
routeSignal = do
  runProcess (routeProducer $$ routeConsumer Nothing)

  where
  routeProducer = produce \emit →
    Routing.matches' UP.decodeURIPath routing \_ → emit ∘ Left

  routeConsumer state = do
    new ← await
    case new, state of
      -- Initialize the Workspace component
      WorkspaceRoute path deckId action varMaps, Nothing → do
        wiring ← lift $ Wiring.make path (toAccessType action) varMaps
        mount wiring new

      -- Reload the page on path change or varMap change
      WorkspaceRoute path _ action _, Just (RouterState (WorkspaceRoute path' _ action' _) wiring _)
        | path ≠ path' || toAccessType action ≠ toAccessType action' →
        reload wiring new

      -- Transition Workspace
      WorkspaceRoute path deckId action varMaps, Just (RouterState old wiring driver) →
        case old of
          WorkspaceRoute _ deckId' _ varMaps'
            | deckId ≡ deckId' ∧ varMaps ≡ varMaps' →
                routeConsumer (Just (RouterState new wiring driver))
          WorkspaceRoute _ deckId' _ varMaps' → do
            when (varMaps ≠ varMaps') $ lift do
              Cache.restore varMaps (Wiring.unWiring wiring).varMaps
              runSlam wiring
                $ traverse_ (P.queueEvalForDeck 0)
                $ Diff.updated
                $ Diff.diff varMaps' varMaps
            lift $ setup new driver
            routeConsumer (Just (RouterState new wiring driver))

  reload (Wiring wiring) new@(WorkspaceRoute path _ action _) = do
    let
      wiring' = wiring
        { path = path
        , accessType = toAccessType action
        }
    lift $ removeFromBody ".sd-workspace"
    mount (Wiring wiring') new

  mount wiring new@(WorkspaceRoute _ _ action _) = do
    let
      st = Workspace.initialState (Just "4.0")
      ui = interpret (runSlam wiring) $ Workspace.comp (toAccessType action)
    driver ← lift $ runUI ui (parentState st) =<< awaitBody'
    lift $ setup new driver
    routeConsumer (Just (RouterState new wiring driver))

  setup new@(WorkspaceRoute _ deckId action varMaps) driver = do
    when (toAccessType action ≡ AT.ReadOnly) do
      isEmbedded ←
        liftEff $ Browser.detectEmbedding
      let
        bodyClass =
          if isEmbedded
            then "sd-workspace-page sd-embedded"
            else "sd-workspace-page"
      void
        $ liftEff
        $ traverse (setClassName bodyClass ∘ htmlElementToElement)
        ∘ toMaybe
        =<< body
        =<< document
        =<< window

    forkAff case action of
      Load _ →
        driver $ Workspace.toWorkspace $ Workspace.Load deckId
      New →
        driver $ Workspace.toWorkspace $ Workspace.New
      Exploring fp →
        driver $ Workspace.toWorkspace $ Workspace.ExploreFile fp

awaitBody' ∷ Aff SlamDataEffects HTMLElement
awaitBody' = do
  body ← liftEff $ map toMaybe $ window >>= document >>= body
  maybe awaitBody pure body

removeFromBody ∷ String → Aff SlamDataEffects Unit
removeFromBody sel = liftEff $ void $ runMaybeT do
  body ← MaybeT $ map toMaybe $ window >>= document >>= body
  root ← MaybeT $ map toMaybe $ window >>= document >>= htmlDocumentToParentNode >>> querySelector sel
  lift $ removeChild (elementToNode root) (htmlElementToNode body)


Order

Order

Original commit 176a52939225db86ed7f4497fb47cf9fb20c442c

module Main
    ( renderFromJson
    , renderFromJsonSchema
    , renderFromJsonStringPossiblyAsSchemaInDevelopment
    , renderers
    ) where

import IR
import IRGraph
import Prelude
import Transformations

import CSharp as CSharp
import Data.Argonaut.Core (Json)
import Data.Argonaut.Core (foldJson) as J
import Data.Argonaut.Decode (decodeJson) as J
import Data.Argonaut.Parser (jsonParser) as J
import Data.Array (foldl)
import Data.Array as A
import Data.Either (Either(..))
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Elm as Elm
import Environment (Environment(..))
import Environment as Env
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema

import TypeScript as TypeScript
import Math (round)

import Utils (mapM)

type Error = String
type SourceCode = String

-- A type representing the input to Pipelines
-- This makes pipelines easier to call from JavaScript
type Input a =
    { input :: a
    , renderer :: Doc.Renderer
    , topLevelName :: String
    }

type Pipeline a = Input a -> Either Error SourceCode

renderers :: Array Doc.Renderer
renderers =
    [ TypeScript.renderer
    , Golang.renderer
    , CSharp.renderer
    , Elm.renderer
    , JsonSchema.renderer
    ]

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

irFromError :: String -> IR IRType
irFromError err = do
    addClass $ IRClassData { names: S.singleton err, properties: Map.empty }

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

renderFromJson :: Pipeline Json
renderFromJson { renderer, input: json, topLevelName: topLevelNameGiven } =
    let topLevelName = renderer.transforms.topLevelNameFromGiven topLevelNameGiven
    in
        json
        # makeTypeAndUnify topLevelName
        # regatherClassNames
        # Doc.runRenderer renderer topLevelNameGiven
        # Right

renderFromJsonSchema :: Pipeline Json
renderFromJsonSchema { renderer, input: json, topLevelName: topLevelNameGiven } =
    let topLevelName = renderer.transforms.topLevelNameFromGiven topLevelNameGiven
    in do
        schema <- J.decodeJson json
        graph <- makeTypeFromSchema topLevelName schema
        graph
            # Doc.runRenderer renderer topLevelNameGiven
            # pure

pipelines :: Environment -> Array (Pipeline Json)
pipelines Development = [renderFromJson]
pipelines Production = [renderFromJson]

firstSuccess :: forall a. Array (Pipeline a) -> Pipeline a
firstSuccess pipes input = foldl takeFirstRight (Left "no pipelines provided") pipes
    where
        takeFirstRight (Right output) _ = Right output
        takeFirstRight _ pipeline = pipeline input

renderFromJsonStringPossiblyAsSchemaInDevelopment :: Pipeline String
renderFromJsonStringPossiblyAsSchemaInDevelopment { renderer, input: jsonString, topLevelName } = do
    obj <- J.jsonParser jsonString
    firstSuccess (pipelines Env.current) { renderer, input: obj, topLevelName }

module Main
    ( renderFromJson
    , renderFromJsonSchema
    , renderFromJsonStringPossiblyAsSchemaInDevelopment
    , renderers
    ) where

import IR
import IRGraph
import Prelude
import Transformations

import CSharp as CSharp
import Data.Argonaut.Core (Json)
import Data.Argonaut.Core (foldJson) as J
import Data.Argonaut.Decode (decodeJson) as J
import Data.Argonaut.Parser (jsonParser) as J
import Data.Array (foldl)
import Data.Array as A
import Data.Either (Either(..))
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as S
import Data.StrMap as StrMap
import Data.String.Util (singular)
import Data.Tuple (Tuple(..))
import Doc as Doc
import Elm as Elm
import Environment (Environment(..))
import Environment as Env
import Golang as Golang
import JsonSchema (JSONSchema, jsonSchemaToIR)
import JsonSchema as JsonSchema

import TypeScript as TypeScript
import Math (round)

import Utils (mapM)

type Error = String
type SourceCode = String

-- A type representing the input to Pipelines
-- This makes pipelines easier to call from JavaScript
type Input a =
    { input :: a
    , renderer :: Doc.Renderer
    , topLevelName :: String
    }

type Pipeline a = Input a -> Either Error SourceCode

renderers :: Array Doc.Renderer
renderers =
    [ CSharp.renderer
    , Golang.renderer
    , JsonSchema.renderer
    , TypeScript.renderer
    , Elm.renderer
    ]

makeTypeFromJson :: String -> Json -> IR IRType
makeTypeFromJson name json =
    J.foldJson
    (\_ -> pure IRNull)
    (\_ -> pure IRBool)
    (\n -> pure IRDouble)
    (\_ -> pure IRString)
    (\arr -> do
        let typeName = singular name
        IRArray <$> A.foldRecM (unify typeName) IRNothing arr)
    (\obj -> do
        let l1 = StrMap.toUnfoldable obj
        l2 <- mapM toProperty l1
        addClass $ IRClassData { names: S.singleton name, properties: Map.fromFoldable l2 })
    json
    where
        unify typeName t1 j2 = makeTypeFromJson typeName j2 >>= unifyTypes t1
        toProperty (Tuple name json) = Tuple name <$> makeTypeFromJson name json

makeTypeAndUnify :: String -> Json -> IRGraph
makeTypeAndUnify name json = execIR do
    topLevel <- makeTypeFromJson name json
    setTopLevel topLevel
    replaceSimilarClasses
    makeMaps

irFromError :: String -> IR IRType
irFromError err = do
    addClass $ IRClassData { names: S.singleton err, properties: Map.empty }

makeTypeFromSchema :: String -> JSONSchema -> Either Error IRGraph
makeTypeFromSchema name schema = eitherify $ runIR do
    topLevelOrError <- jsonSchemaToIR schema "TopLevel" schema
    case topLevelOrError of
        Left err -> pure $ Just err
        Right topLevel -> do
            setTopLevel topLevel
            pure Nothing
    where
        eitherify (Tuple (Just err) _) = Left err
        eitherify (Tuple Nothing g) = Right g

renderFromJson :: Pipeline Json
renderFromJson { renderer, input: json, topLevelName: topLevelNameGiven } =
    let topLevelName = renderer.transforms.topLevelNameFromGiven topLevelNameGiven
    in
        json
        # makeTypeAndUnify topLevelName
        # regatherClassNames
        # Doc.runRenderer renderer topLevelNameGiven
        # Right

renderFromJsonSchema :: Pipeline Json
renderFromJsonSchema { renderer, input: json, topLevelName: topLevelNameGiven } =
    let topLevelName = renderer.transforms.topLevelNameFromGiven topLevelNameGiven
    in do
        schema <- J.decodeJson json
        graph <- makeTypeFromSchema topLevelName schema
        graph
            # Doc.runRenderer renderer topLevelNameGiven
            # pure

pipelines :: Environment -> Array (Pipeline Json)
pipelines Development = [renderFromJson]
pipelines Production = [renderFromJson]

firstSuccess :: forall a. Array (Pipeline a) -> Pipeline a
firstSuccess pipes input = foldl takeFirstRight (Left "no pipelines provided") pipes
    where
        takeFirstRight (Right output) _ = Right output
        takeFirstRight _ pipeline = pipeline input

renderFromJsonStringPossiblyAsSchemaInDevelopment :: Pipeline String
renderFromJsonStringPossiblyAsSchemaInDevelopment { renderer, input: jsonString, topLevelName } = do
    obj <- J.jsonParser jsonString
    firstSuccess (pipelines Env.current) { renderer, input: obj, topLevelName }


simplify lambdacube webgl import list

simplify lambdacube webgl import list

module Main (main,run) where

import Prelude
import Extensions (fail)
import Global

import Control.Monad.Eff.Console as C

import Control.Bind
import Timer
import Control.Monad.Except
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.Eff.Ref
import Data.Foldable (for_, foldl)
import Data.Traversable (for)
import Partial.Unsafe (unsafePartial)

import Ace
import Ace as Ace
import Ace.Types as Ace
import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Range as Range

import Graphics.WebGL as GL
import Control.Monad.Eff.JQuery as J

import WebSocket
import Data.Either
import Sample

import Data.Foreign
import Data.Function
import Data.Function.Uncurried
import Data.Maybe
import Data.StrMap(fromFoldable,StrMap(..))
import Data.Tuple
import Data.Array
import Data.Int
import Data.StrMap as StrMap

import LambdaCube.WebGL
import LambdaCube.WebGL.Util (unlines)
import LambdaCube.WebGL.Mesh

import LambdaCube.TypeInfo

import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Decode (class DecodeJson, decodeJson)
import Data.Argonaut.Core as AC

import Data.Matrix (Mat(..))
import Data.Matrix4
import Data.Vector3

import DOM as DOM

defaultExampleName = "LambdaCube2.lc"

main :: forall e. Eff (console :: C.CONSOLE | e) Unit
main = do
  C.log "Start LambdaCube 3D Editor"
--main :: forall m. (Applicative m) => m Unit
--main = pure unit
--run :: forall m. (Applicative m) => m Unit
--run = pure unit

foreign import getUrlParameter :: forall eff a. String -> Eff (dom :: DOM.DOM | eff) String
foreign import getMousePos :: forall eff a. J.JQueryEvent -> Eff (dom :: DOM.DOM | eff) (Array Number)
foreign import getJSON :: forall eff a. String -> (AC.Json -> Eff (dom :: DOM.DOM | eff) a) -> Eff (dom :: DOM.DOM | eff) Unit

--  control-b - compile/build
--  control-n - new

type TypeInfoRecord =
  { startLine :: Int
  , startColumn :: Int
  , endLine :: Int
  , endColumn :: Int
  , text :: String
  }

foreign import addCommand :: forall eff . Editor -> String -> String -> String -> (Editor -> Eff (ace :: ACE | eff) Unit) -> Eff (ace :: ACE | eff) Unit
foreign import tokenTooltip :: forall eff . Editor -> (Int -> Int -> Eff (ace :: ACE | eff) TypeInfoRecord) -> Eff (ace :: ACE | eff) Unit
foreign import addMarkerImpl :: forall eff. Fn5 Ace.Range String String Boolean EditSession (Eff (ace :: ACE | eff) Int)

addMarker :: forall eff. Ace.Range -> String -> String -> Boolean -> EditSession -> Eff (ace :: ACE | eff) Int
addMarker range clazz _type inFront self = runFn5 addMarkerImpl range clazz _type inFront self

run :: forall e. Eff
   ( console :: C.CONSOLE
   , err :: EXCEPTION
   , ref :: REF
   , dom :: DOM.DOM
   , timeout :: TIMEOUT
   , now :: NOW
   , ace :: ACE
   , ws :: WS
   | e
   )
   Unit
-- unsafePartial is needed to prevent Partial => context; otherwise run cannot be called from .html
run = unsafePartial $ do
 GL.runWebGL "glcanvas" (\s -> C.log s) $ \context -> do
  -- setup pipeline input
  let inputSchema =
        { slots : fromFoldable
                    [ Tuple "stream"  {primitive: Triangles, attributes: fromFoldable [Tuple "position"  TV3F, Tuple "normal" TV3F]}
                    , Tuple "stream4" {primitive: Triangles, attributes: fromFoldable [Tuple "position4" TV4F, Tuple "vertexUV" TV2F]}
                    , Tuple "line"    {primitive: Triangles, attributes: fromFoldable [Tuple "position" TV3F]}
                    , Tuple "grid"    {primitive: Triangles, attributes: fromFoldable [Tuple "position" TV3F]}
                    , Tuple "grid3d"  {primitive: Points,    attributes: fromFoldable [Tuple "position" TV3F]}
                    , Tuple "quad"    {primitive: Triangles, attributes: fromFoldable [Tuple "position" TV2F]}
                    , Tuple "cube"    {primitive: Triangles, attributes: fromFoldable [Tuple "position"  TV3F, Tuple "normal" TV3F]}
                    , Tuple "lambdaCube" {primitive: Triangles, attributes: fromFoldable [Tuple "position"  TV3F, Tuple "normal" TV3F]}
                    ]
        , uniforms : fromFoldable
                      [ Tuple "MVP" M44F
                      , Tuple "Time" Float
                      , Tuple "Mouse" V2F
                      , Tuple "Diffuse" FTexture2D
                      , Tuple "OcclusionFieldMin" FTexture2D
                      , Tuple "OcclusionFieldMax" FTexture2D
                      ]
        }
  pplInput <- mkWebGLPipelineInput inputSchema

  timeRef <- newRef 0.0
  b <- J.body
  timeBox <- J.find "#timeBox" b
  timeRange <- J.find "#timeRange" b
  let getTime = do
                  t <- J.getValue timeBox
                  case runExcept $ readNumber t of
                    Right time -> pure time
                    _ -> case runExcept $ readString t of
                        Right timeStr -> pure $ readFloat timeStr
                        _ -> pure 0.0
  flip (J.on "input") timeBox $ \_ _ -> do
    J.getValue timeBox >>= flip J.setValue timeRange
    getTime >>= writeRef timeRef
  flip (J.on "input") timeRange $ \_ _ -> do
    J.getValue timeRange >>= flip J.setValue timeBox
    getTime >>= writeRef timeRef
  flip (J.on "change") timeBox $ \_ _ -> do
    J.getValue timeBox >>= flip J.setValue timeRange
    getTime >>= writeRef timeRef
  flip (J.on "change") timeRange $ \_ _ -> do
    J.getValue timeRange >>= flip J.setValue timeBox
    getTime >>= writeRef timeRef

  pauseBox <- J.find "#pause" b
  pipelinepanel <- J.find "#pipeline" b
  desugaredpanel <- J.find "#desugared" b
  messagepanel <- J.find "#messagepanel" b
  statuspanel <- J.find "#statuspanel" b
  btnCompile <- J.find "#compilebutton" b
  exerciseselect <- J.find "#exerciseselect" b
  glcanvas <- J.find "#glcanvas" b
  flip (J.on "mousemove") glcanvas $ \e _ -> do
    w <- GL.getCanvasWidth context
    h <- GL.getCanvasHeight context
    [x,y] <- getMousePos e
    uniformV2F "Mouse" pplInput.uniformSetter $ V2 (x / toNumber w) (y / toNumber h)

  let toLCMat4 :: Mat4 -> M44F
      toLCMat4 (Mat [x11, x21, x31, x41, x12, x22, x32, x42, x13, x23, x33, x43, x14, x24, x34, x44]) = let
          v1 = V4 x11 x21 x31 x41
          v2 = V4 x12 x22 x32 x42
          v3 = V4 x13 x23 x33 x43
          v4 = V4 x14 x24 x34 x44
        in V4 v1 v2 v3 v4
      toLCMat4 _ = fail "invalid Mat4"

      updateInput t = do
        w <- GL.getCanvasWidth context
        h <- GL.getCanvasHeight context
        setScreenSize pplInput (V2 w h)

        uniformFloat "Time" pplInput.uniformSetter t
-- todo        uniformFloat "Aspect" pplInput.uniformSetter (toNumber w / toNumber h)

  gpuCube <- compileMesh myCube
  addMesh pplInput "stream4" gpuCube []

  gpuQuad <- compileMesh myQuad
  addMesh pplInput "quad" gpuQuad []

  gpuLambdaCube <- compileMesh lambdaCube
  addMesh pplInput "lambdaCube" gpuLambdaCube []

  -- upload textures
  uploadTexture2DToGPU "logo.png" (uniformFTexture2D "Diffuse" pplInput.uniformSetter)
  uploadTexture2DToGPU "OcclusionFieldMin.png" (uniformFTexture2D "OcclusionFieldMin" pplInput.uniformSetter)
  uploadTexture2DToGPU "OcclusionFieldMax.png" (uniformFTexture2D "OcclusionFieldMax" pplInput.uniformSetter)

  let addRemoteModel sname uri = getJSON uri $ \m -> do
        case decodeJson m of
          Left e -> C.log $ "decode error: " <> e
          Right (mesh) -> do
            gpuMesh <- compileMesh mesh
            addMesh pplInput sname gpuMesh []
            sortSlotObjects pplInput
            pure unit

  --addRemoteModel "grid3d" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/grid3d.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/logo2.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/logo3.mesh.json"

  --addRemoteModel "quad"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/quad.mesh.json"
  --addRemoteModel "grid"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/grid.mesh.json"
  --addRemoteModel "line"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/line.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/ico.mesh.json"

  -- setup ace editor
  editor <- Ace.edit "editor" ace
  session <- Editor.getSession editor
  Editor.setTheme "ace/theme/terminal" editor
  Session.setMode "ace/mode/haskell" session
  typeInfoRef <- newRef []
  markerRef <- newRef []
  let lessEqPos l c l' c' = l < l' || l == l' && c <= c'
  let lessPos l c l' c' = l < l' || l == l' && c < c'
  let getTypeInfo l c = do
        x <- readRef typeInfoRef
        let flattenTypeInfo (TypeInfo i) = case i.range of
              Range r ->
                { startLine   : r.startLine
                , startColumn : r.startColumn
                , endLine     : r.endLine
                , endColumn   : r.endColumn
                , text        : i.text
                }
            ps = flip filter (map flattenTypeInfo x) $ \ti -> lessEqPos ti.startLine ti.startColumn l c && lessPos l c ti.endLine ti.endColumn
            f Nothing i = Just i
            f (Just d) i
                | lessPos d.startLine d.startColumn i.startLine i.startColumn = Just i
                | otherwise = Just d
        pure $ case foldl f Nothing ps of
          Nothing ->
              { startLine   : 0
              , startColumn : 0
              , endLine     : 0
              , endColumn   : 0
              , text        : ""
              }
          Just a -> a
  tokenTooltip editor getTypeInfo

  pipelineRef <- newRef Nothing
  let compile s = do
        C.log "compile"
        J.setText "Compiling..." statuspanel
        src <- Session.getValue session
        send s src
{-
      loadUserTextures (Pipeline p) = do
        let isFTexture2D unis n = case StrMap.lookup n unis of
              Just FTexture2D -> true
              _ -> false
        for_ (concatMap (\(Slot s) -> filter (isFTexture2D s.slotUniforms) $ StrMap.keys s.slotUniforms) p.slots) $ \n ->
          uploadTexture2DToGPU n >>= uniformFTexture2D n pplInput.uniformSetter
-}
      render ir = do
        --loadUserTextures ir
        old <- readRef pipelineRef
        writeRef pipelineRef Nothing
        case old of
          Nothing -> pure unit
          Just p -> do
            C.log "dispose old pipeline"
            disposePipeline p
        C.log "allocate new pipeline"
        ppl <- allocPipeline ir
        C.log "attach pipeline input"
        setPipelineInput ppl (Just pplInput)
        C.log "generate object commands"
        sortSlotObjects pplInput
        writeRef pipelineRef $ Just ppl

  socket1 <- webSocket "ws://localhost:8000/exerciselist" $
    { onOpen    : \s -> do
        send s "query"
        C.log "socket1 is ready"
        pure unit
    , onMessage : \s m -> case jsonParser m >>= decodeJson of
          Left e -> C.log $ "decode error: " <> e
          Right es -> do
            for_ (es :: Array String) $ \e -> do
                op <- J.create "<option></option>"
                J.setText e op
                J.append op exerciseselect
            pure unit
    , onError   : \s m -> C.log m
    , onClose   : C.log "socket1 is closed"
    }

  socket <- webSocket "ws://localhost:8000/compile" $
    { onOpen    : \s -> do
        C.log "socket is ready"
        timerRef <- newRef Nothing
        Session.onChange session $ do
          t <- readRef timerRef
          case t of
            Nothing -> pure unit
            Just a -> clearTimeout a
          writeRef timerRef =<< Just <$> timeout 1000 (compile s)

    , onClose   : C.log "socket is closed"
    , onMessage : \s m -> do
        C.log "got response"
        let addRangeMarker cssClass e = do
              range <- Range.create (e.startLine - 1) (e.startColumn - 1) (e.endLine - 1) (e.endColumn - 1)
              addMarker range cssClass "text" false session
            unlinesWithCaption title a = if null a then "" else show (length a) <> " " <> title <> unlines a
        case jsonParser m >>= decodeJson of
          Left e -> C.log $ "decode error: " <> e
          Right (CompileError errorMessage types warnings errors) -> do
            J.setText (show (max 1 $ length errors) <> " Errors" <> if null warnings then "" else ", " <> show (length warnings) <> " Warnings") statuspanel
            let warningsTxt = map (\(WarningInfo wi) -> wi.wText) warnings
                errorsTxt   = map (\(ErrorInfo ei) -> ei.eText) errors
            J.setText (unlines [errorMessage, unlinesWithCaption "Errors:\n" errorsTxt, unlinesWithCaption "Warnings:\n" warningsTxt]) messagepanel
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            warningMarkers <- for warnings $ \(WarningInfo {wRange: Range e}) -> addRangeMarker "lc_warning" e
            errorMarkers <- for errors $ \(ErrorInfo {eRange: Range e}) -> addRangeMarker "lc_error" e
            writeRef markerRef (concat [warningMarkers, errorMarkers])
            writeRef typeInfoRef types
            pure unit
          Right (Compiled dsSrc pplSrc p types warnings) -> do
            J.setText dsSrc desugaredpanel
            J.setText pplSrc pipelinepanel
            J.setText ("Compiled" <> if null warnings then "" else ", " <> show (length warnings) <> " Warnings") statuspanel
            let warningsTxt = map (\(WarningInfo wi) -> wi.wText) warnings
            J.setText (if null warnings then "No errors.\n" else unlinesWithCaption "Warnings:\n" warningsTxt) messagepanel
            writeRef typeInfoRef types
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            warningMarkers <- for warnings $ \(WarningInfo {wRange: Range e}) -> addRangeMarker "lc_warning" e
            writeRef markerRef warningMarkers
            render p
    , onError   : \s m -> C.log $ "error: " <> m
    }
  case socket of
    Left m -> C.log $ "error: " <> m
    Right ws -> do

      socket2 <- webSocket "ws://localhost:8000/getexercise" $
        { onOpen    : \s -> do
            C.log "socket2 is ready"
            flip (J.on "change") exerciseselect $ \_ _ -> do
                sel <- J.find ":selected" exerciseselect
                txt <- J.getText sel
                send s txt
            -- get the default example
            paramExample <- getUrlParameter "example"
            send s $ if paramExample == "" then defaultExampleName else paramExample
            pure unit
        , onMessage : \s m -> case jsonParser m >>= decodeJson of
              Left e -> C.log $ "decode error: " <> e
              Right src -> do
                Session.setValue src session
                compile ws
                pure unit
        , onError   : \s m -> C.log m
        , onClose   : C.log "socket2 is closed"
        }

      flip (J.on "click") btnCompile $ \_ _ -> do
        compile ws
        C.log "clicked compile"
      addCommand editor "Compile" "Ctrl-B" "Command-B" (\_ -> compile ws)

      lastTimeRef <- newRef =<< nowEpochMilliseconds
      let renderLoop = do
            t <- nowEpochMilliseconds
            lastTime <- readRef lastTimeRef
            let deltaTime = (t - lastTime) / 1000.0
            writeRef lastTimeRef t
            paused <- J.getProp "checked" pauseBox
            case runExcept $ readBoolean paused of
              Right false -> do
                  modifyRef timeRef (\x -> deltaTime + x)
                  time <- readRef timeRef
                  let time' = (toNumber $ floor $ time * 1000.0)/1000.0
                  J.setValue time' timeBox
                  J.setValue time' timeRange
                  updateInput time
              _ -> do
                  time <- getTime
                  writeRef timeRef time
                  updateInput time
            mppl <- readRef pipelineRef
            case mppl of
              Nothing -> pure unit
              Just ppl -> renderPipeline ppl
            timeout (1000/25) renderLoop
      -- render loop
      renderLoop

      pure unit

module Main (main,run) where

import Prelude
import Extensions (fail)
import Global

import Control.Monad.Eff.Console as C

import Control.Bind
import LambdaCube.TypeInfo
import Timer
import Control.Monad.Except
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.Eff.Ref
import Data.Foldable (for_, foldl)
import Data.Traversable (for)
import Partial.Unsafe (unsafePartial)

import Ace
import Ace as Ace
import Ace.Types as Ace
import Ace.Editor as Editor
import Ace.EditSession as Session
import Ace.Range as Range

import Graphics.WebGL as GL
import Control.Monad.Eff.JQuery as J

import WebSocket
import Data.Either
import Sample

import Data.Foreign
import Data.Function
import Data.Function.Uncurried
import Data.Maybe
import Data.StrMap(fromFoldable,StrMap(..))
import Data.Tuple
import Data.Array
import Data.Int
import Data.StrMap as StrMap

import LambdaCube.IR
import LambdaCube.LinearBase
import LambdaCube.WebGL.Backend
import LambdaCube.WebGL.Mesh
import LambdaCube.WebGL.Type
import LambdaCube.WebGL.Input
import LambdaCube.WebGL.Util (unlines)
import LambdaCube.WebGL.Data (uploadTexture2DToGPU)

import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Decode (class DecodeJson, decodeJson)
import Data.Argonaut.Core as AC

import Data.Matrix (Mat(..))
import Data.Matrix4
import Data.Vector3

import DOM as DOM

defaultExampleName = "LambdaCube2.lc"

main :: forall e. Eff (console :: C.CONSOLE | e) Unit
main = do
  C.log "Start LambdaCube 3D Editor"
--main :: forall m. (Applicative m) => m Unit
--main = pure unit
--run :: forall m. (Applicative m) => m Unit
--run = pure unit

foreign import getUrlParameter :: forall eff a. String -> Eff (dom :: DOM.DOM | eff) String
foreign import getMousePos :: forall eff a. J.JQueryEvent -> Eff (dom :: DOM.DOM | eff) (Array Number)
foreign import getJSON :: forall eff a. String -> (AC.Json -> Eff (dom :: DOM.DOM | eff) a) -> Eff (dom :: DOM.DOM | eff) Unit

--  control-b - compile/build
--  control-n - new

type TypeInfoRecord =
  { startLine :: Int
  , startColumn :: Int
  , endLine :: Int
  , endColumn :: Int
  , text :: String
  }

foreign import addCommand :: forall eff . Editor -> String -> String -> String -> (Editor -> Eff (ace :: ACE | eff) Unit) -> Eff (ace :: ACE | eff) Unit
foreign import tokenTooltip :: forall eff . Editor -> (Int -> Int -> Eff (ace :: ACE | eff) TypeInfoRecord) -> Eff (ace :: ACE | eff) Unit
foreign import addMarkerImpl :: forall eff. Fn5 Ace.Range String String Boolean EditSession (Eff (ace :: ACE | eff) Int)

addMarker :: forall eff. Ace.Range -> String -> String -> Boolean -> EditSession -> Eff (ace :: ACE | eff) Int
addMarker range clazz _type inFront self = runFn5 addMarkerImpl range clazz _type inFront self

run :: forall e. Eff
   ( console :: C.CONSOLE
   , err :: EXCEPTION
   , ref :: REF
   , dom :: DOM.DOM
   , timeout :: TIMEOUT
   , now :: NOW
   , ace :: ACE
   , ws :: WS
   | e
   )
   Unit
-- unsafePartial is needed to prevent Partial => context; otherwise run cannot be called from .html
run = unsafePartial $ do
 GL.runWebGL "glcanvas" (\s -> C.log s) $ \context -> do
  -- setup pipeline input
  let inputSchema =
        { slots : fromFoldable
                    [ Tuple "stream"  {primitive: Triangles, attributes: fromFoldable [Tuple "position"  TV3F, Tuple "normal" TV3F]}
                    , Tuple "stream4" {primitive: Triangles, attributes: fromFoldable [Tuple "position4" TV4F, Tuple "vertexUV" TV2F]}
                    , Tuple "line"    {primitive: Triangles, attributes: fromFoldable [Tuple "position" TV3F]}
                    , Tuple "grid"    {primitive: Triangles, attributes: fromFoldable [Tuple "position" TV3F]}
                    , Tuple "grid3d"  {primitive: Points,    attributes: fromFoldable [Tuple "position" TV3F]}
                    , Tuple "quad"    {primitive: Triangles, attributes: fromFoldable [Tuple "position" TV2F]}
                    , Tuple "cube"    {primitive: Triangles, attributes: fromFoldable [Tuple "position"  TV3F, Tuple "normal" TV3F]}
                    , Tuple "lambdaCube" {primitive: Triangles, attributes: fromFoldable [Tuple "position"  TV3F, Tuple "normal" TV3F]}
                    ]
        , uniforms : fromFoldable [Tuple "MVP" M44F, Tuple "Time" Float, Tuple "Mouse" V2F, Tuple "Diffuse" FTexture2D, Tuple "OcclusionFieldMin" FTexture2D, Tuple "OcclusionFieldMax" FTexture2D]
        }
  pplInput <- mkWebGLPipelineInput inputSchema

  timeRef <- newRef 0.0
  b <- J.body
  timeBox <- J.find "#timeBox" b
  timeRange <- J.find "#timeRange" b
  let getTime = do
                  t <- J.getValue timeBox
                  case runExcept $ readNumber t of
                    Right time -> pure time
                    _ -> case runExcept $ readString t of
                        Right timeStr -> pure $ readFloat timeStr
                        _ -> pure 0.0
  flip (J.on "input") timeBox $ \_ _ -> do
    J.getValue timeBox >>= flip J.setValue timeRange
    getTime >>= writeRef timeRef
  flip (J.on "input") timeRange $ \_ _ -> do
    J.getValue timeRange >>= flip J.setValue timeBox
    getTime >>= writeRef timeRef
  flip (J.on "change") timeBox $ \_ _ -> do
    J.getValue timeBox >>= flip J.setValue timeRange
    getTime >>= writeRef timeRef
  flip (J.on "change") timeRange $ \_ _ -> do
    J.getValue timeRange >>= flip J.setValue timeBox
    getTime >>= writeRef timeRef

  pauseBox <- J.find "#pause" b
  pipelinepanel <- J.find "#pipeline" b
  desugaredpanel <- J.find "#desugared" b
  messagepanel <- J.find "#messagepanel" b
  statuspanel <- J.find "#statuspanel" b
  btnCompile <- J.find "#compilebutton" b
  exerciseselect <- J.find "#exerciseselect" b
  glcanvas <- J.find "#glcanvas" b
  flip (J.on "mousemove") glcanvas $ \e _ -> do
    w <- GL.getCanvasWidth context
    h <- GL.getCanvasHeight context
    [x,y] <- getMousePos e
    uniformV2F "Mouse" pplInput.uniformSetter $ V2 (x / toNumber w) (y / toNumber h)

  let toLCMat4 :: Mat4 -> M44F
      toLCMat4 (Mat [x11, x21, x31, x41, x12, x22, x32, x42, x13, x23, x33, x43, x14, x24, x34, x44]) = let
          v1 = V4 x11 x21 x31 x41
          v2 = V4 x12 x22 x32 x42
          v3 = V4 x13 x23 x33 x43
          v4 = V4 x14 x24 x34 x44
        in V4 v1 v2 v3 v4
      toLCMat4 _ = fail "invalid Mat4"

      updateInput t = do
        w <- GL.getCanvasWidth context
        h <- GL.getCanvasHeight context
        setScreenSize pplInput (V2 w h)

        uniformFloat "Time" pplInput.uniformSetter t
-- todo        uniformFloat "Aspect" pplInput.uniformSetter (toNumber w / toNumber h)

  gpuCube <- compileMesh myCube
  addMesh pplInput "stream4" gpuCube []

  gpuQuad <- compileMesh myQuad
  addMesh pplInput "quad" gpuQuad []

  gpuLambdaCube <- compileMesh lambdaCube
  addMesh pplInput "lambdaCube" gpuLambdaCube []

  -- upload textures
  uploadTexture2DToGPU "logo.png" (uniformFTexture2D "Diffuse" pplInput.uniformSetter)
  uploadTexture2DToGPU "OcclusionFieldMin.png" (uniformFTexture2D "OcclusionFieldMin" pplInput.uniformSetter)
  uploadTexture2DToGPU "OcclusionFieldMax.png" (uniformFTexture2D "OcclusionFieldMax" pplInput.uniformSetter)

  let addRemoteModel sname uri = getJSON uri $ \m -> do
        case decodeJson m of
          Left e -> C.log $ "decode error: " <> e
          Right (mesh) -> do
            gpuMesh <- compileMesh mesh
            addMesh pplInput sname gpuMesh []
            sortSlotObjects pplInput
            pure unit

  --addRemoteModel "grid3d" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/grid3d.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/logo2.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/logo3.mesh.json"

  --addRemoteModel "quad"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/quad.mesh.json"
  --addRemoteModel "grid"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/grid.mesh.json"
  --addRemoteModel "line"   "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/line.mesh.json"
  --addRemoteModel "stream" "http://rawgit.com/lambdacube3d/lambdacube-editor/master/mesh/ico.mesh.json"

  -- setup ace editor
  editor <- Ace.edit "editor" ace
  session <- Editor.getSession editor
  Editor.setTheme "ace/theme/terminal" editor
  Session.setMode "ace/mode/haskell" session
  typeInfoRef <- newRef []
  markerRef <- newRef []
  let lessEqPos l c l' c' = l < l' || l == l' && c <= c'
  let lessPos l c l' c' = l < l' || l == l' && c < c'
  let getTypeInfo l c = do
        x <- readRef typeInfoRef
        let flattenTypeInfo (TypeInfo i) = case i.range of
              Range r ->
                { startLine   : r.startLine
                , startColumn : r.startColumn
                , endLine     : r.endLine
                , endColumn   : r.endColumn
                , text        : i.text
                }
            ps = flip filter (map flattenTypeInfo x) $ \ti -> lessEqPos ti.startLine ti.startColumn l c && lessPos l c ti.endLine ti.endColumn
            f Nothing i = Just i
            f (Just d) i
                | lessPos d.startLine d.startColumn i.startLine i.startColumn = Just i
                | otherwise = Just d
        pure $ case foldl f Nothing ps of
          Nothing ->
              { startLine   : 0
              , startColumn : 0
              , endLine     : 0
              , endColumn   : 0
              , text        : ""
              }
          Just a -> a
  tokenTooltip editor getTypeInfo

  pipelineRef <- newRef Nothing
  let compile s = do
        C.log "compile"
        J.setText "Compiling..." statuspanel
        src <- Session.getValue session
        send s src
{-
      loadUserTextures (Pipeline p) = do
        let isFTexture2D unis n = case StrMap.lookup n unis of
              Just FTexture2D -> true
              _ -> false
        for_ (concatMap (\(Slot s) -> filter (isFTexture2D s.slotUniforms) $ StrMap.keys s.slotUniforms) p.slots) $ \n ->
          uploadTexture2DToGPU n >>= uniformFTexture2D n pplInput.uniformSetter
-}
      render ir = do
        --loadUserTextures ir
        old <- readRef pipelineRef
        writeRef pipelineRef Nothing
        case old of
          Nothing -> pure unit
          Just p -> do
            C.log "dispose old pipeline"
            disposePipeline p
        C.log "allocate new pipeline"
        ppl <- allocPipeline ir
        C.log "attach pipeline input"
        setPipelineInput ppl (Just pplInput)
        C.log "generate object commands"
        sortSlotObjects pplInput
        writeRef pipelineRef $ Just ppl

  socket1 <- webSocket "ws://localhost:8000/exerciselist" $
    { onOpen    : \s -> do
        send s "query"
        C.log "socket1 is ready"
        pure unit
    , onMessage : \s m -> case jsonParser m >>= decodeJson of
          Left e -> C.log $ "decode error: " <> e
          Right es -> do
            for_ (es :: Array String) $ \e -> do
                op <- J.create "<option></option>"
                J.setText e op
                J.append op exerciseselect
            pure unit
    , onError   : \s m -> C.log m
    , onClose   : C.log "socket1 is closed"
    }

  socket <- webSocket "ws://localhost:8000/compile" $
    { onOpen    : \s -> do
        C.log "socket is ready"
        timerRef <- newRef Nothing
        Session.onChange session $ do
          t <- readRef timerRef
          case t of
            Nothing -> pure unit
            Just a -> clearTimeout a
          writeRef timerRef =<< Just <$> timeout 1000 (compile s)

    , onClose   : C.log "socket is closed"
    , onMessage : \s m -> do
        C.log "got response"
        let addRangeMarker cssClass e = do
              range <- Range.create (e.startLine - 1) (e.startColumn - 1) (e.endLine - 1) (e.endColumn - 1)
              addMarker range cssClass "text" false session
            unlinesWithCaption title a = if null a then "" else show (length a) <> " " <> title <> unlines a
        case jsonParser m >>= decodeJson of
          Left e -> C.log $ "decode error: " <> e
          Right (CompileError errorMessage types warnings errors) -> do
            J.setText (show (max 1 $ length errors) <> " Errors" <> if null warnings then "" else ", " <> show (length warnings) <> " Warnings") statuspanel
            let warningsTxt = map (\(WarningInfo wi) -> wi.wText) warnings
                errorsTxt   = map (\(ErrorInfo ei) -> ei.eText) errors
            J.setText (unlines [errorMessage, unlinesWithCaption "Errors:\n" errorsTxt, unlinesWithCaption "Warnings:\n" warningsTxt]) messagepanel
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            warningMarkers <- for warnings $ \(WarningInfo {wRange: Range e}) -> addRangeMarker "lc_warning" e
            errorMarkers <- for errors $ \(ErrorInfo {eRange: Range e}) -> addRangeMarker "lc_error" e
            writeRef markerRef (concat [warningMarkers, errorMarkers])
            writeRef typeInfoRef types
            pure unit
          Right (Compiled dsSrc pplSrc p types warnings) -> do
            J.setText dsSrc desugaredpanel
            J.setText pplSrc pipelinepanel
            J.setText ("Compiled" <> if null warnings then "" else ", " <> show (length warnings) <> " Warnings") statuspanel
            let warningsTxt = map (\(WarningInfo wi) -> wi.wText) warnings
            J.setText (if null warnings then "No errors.\n" else unlinesWithCaption "Warnings:\n" warningsTxt) messagepanel
            writeRef typeInfoRef types
            rs <- readRef markerRef
            for_ rs $ \mkr -> Session.removeMarker mkr session
            warningMarkers <- for warnings $ \(WarningInfo {wRange: Range e}) -> addRangeMarker "lc_warning" e
            writeRef markerRef warningMarkers
            render p
    , onError   : \s m -> C.log $ "error: " <> m
    }
  case socket of
    Left m -> C.log $ "error: " <> m
    Right ws -> do

      socket2 <- webSocket "ws://localhost:8000/getexercise" $
        { onOpen    : \s -> do
            C.log "socket2 is ready"
            flip (J.on "change") exerciseselect $ \_ _ -> do
                sel <- J.find ":selected" exerciseselect
                txt <- J.getText sel
                send s txt
            -- get the default example
            paramExample <- getUrlParameter "example"
            send s $ if paramExample == "" then defaultExampleName else paramExample
            pure unit
        , onMessage : \s m -> case jsonParser m >>= decodeJson of
              Left e -> C.log $ "decode error: " <> e
              Right src -> do
                Session.setValue src session
                compile ws
                pure unit
        , onError   : \s m -> C.log m
        , onClose   : C.log "socket2 is closed"
        }

      flip (J.on "click") btnCompile $ \_ _ -> do
        compile ws
        C.log "clicked compile"
      addCommand editor "Compile" "Ctrl-B" "Command-B" (\_ -> compile ws)

      lastTimeRef <- newRef =<< nowEpochMilliseconds
      let renderLoop = do
            t <- nowEpochMilliseconds
            lastTime <- readRef lastTimeRef
            let deltaTime = (t - lastTime) / 1000.0
            writeRef lastTimeRef t
            paused <- J.getProp "checked" pauseBox
            case runExcept $ readBoolean paused of
              Right false -> do
                  modifyRef timeRef (\x -> deltaTime + x)
                  time <- readRef timeRef
                  let time' = (toNumber $ floor $ time * 1000.0)/1000.0
                  J.setValue time' timeBox
                  J.setValue time' timeRange
                  updateInput time
              _ -> do
                  time <- getTime
                  writeRef timeRef time
                  updateInput time
            mppl <- readRef pipelineRef
            case mppl of
              Nothing -> pure unit
              Just ppl -> renderPipeline ppl
            timeout (1000/25) renderLoop
      -- render loop
      renderLoop

      pure unit


Cleaned up imports a bit and exported SubscriberEff

-- | High level declarative interface for servant-subscriber.
module Servant.Subscriber (
  Subscriber
  , makeSubscriber
  , deploy
  , getConnection
  , module Exports )where

import Prelude

import Servant.Subscriber.Subscriptions as Subs
import Control.Monad.Eff.Ref (newRef, writeRef, readRef, Ref)
import Data.Monoid (mempty)
import Servant.Subscriber.Connection (SubscriberEff, Connection, Config, realize, subscribeAll, unsubscribeAll, makeConnection)
import Servant.Subscriber.Connection (Config) as Exports
import Servant.Subscriber.Internal (ToUserType, SubscriberEff) as Exports
import Servant.Subscriber.Subscriptions (Subscriptions, diffSubscriptions)
import Servant.Subscriber.Subscriptions (Subscriptions, makeSubscriptions) as Exports

newtype Subscriber eff a = Subscriber (SubscriberImpl eff a)

type SubscriberImpl eff a = {
    connection :: Connection eff a
  , old :: Ref (Subscriptions a)
  }

makeSubscriber :: forall eff a. Config eff a -> SubscriberEff eff (Subscriber eff a)
makeSubscriber c = do
  conn <- makeConnection c
  old' <- newRef mempty
  pure $ Subscriber {
    connection : conn
  , old : old'
  }

-- | Get access to the low-level Connection.
getConnection :: forall eff a. Subscriber eff a -> Connection eff a
getConnection (Subscriber impl) = impl.connection

-- | Deploy a given set of Subscriptions.
--
--   This function takes care of unsubscribing subscriptions which are no longer present adds any new ones, updates
--   already existing ones and also calls realize for actually sending Subscribe/Unsubscribe commands to the server.
deploy :: forall eff a. Subscriptions a -> Subscriber eff a -> SubscriberEff eff Unit
deploy subs (Subscriber impl)= do
  old' <- readRef impl.old
  let
    forUnsubscribe = map (_.req) <<< Subs.toList $ diffSubscriptions old' subs
  unsubscribeAll forUnsubscribe impl.connection
  subscribeAll (Subs.toList subs) impl.connection
  realize impl.connection
  writeRef impl.old subs

-- | High level declarative interface for servant-subscriber.
module Servant.Subscriber (
  Subscriber
  , makeSubscriber
  , deploy
  , getConnection
  , module Exports )where

import Prelude
import Data.StrMap as StrMap
import Data.StrMap.ST as SM
import Servant.Subscriber.Subscriptions as Subs
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (newRef, writeRef, readRef, Ref)
import Control.Monad.ST (ST)
import Data.Foldable (traverse_)
import Data.Monoid (mempty)
import Data.StrMap (StrMap)
import Data.StrMap.ST (STStrMap)
import Servant.Subscriber.Connection (ToUserType, realize, subscribeAll, unsubscribe, SubscriberEff, Config, Connection, makeConnection, unsubscribeAll)
import Servant.Subscriber.Connection (Config) as Exports
import Servant.Subscriber.Internal (mutate)
import Servant.Subscriber.Internal (ToUserType) as Exports
import Servant.Subscriber.Subscriptions (Subscriptions, diffSubscriptions)
import Servant.Subscriber.Subscriptions (Subscriptions, makeSubscriptions) as Exports

newtype Subscriber eff a = Subscriber (SubscriberImpl eff a)

type SubscriberImpl eff a = {
    connection :: Connection eff a
  , old :: Ref (Subscriptions a)
  }

makeSubscriber :: forall eff a. Config eff a -> SubscriberEff eff (Subscriber eff a)
makeSubscriber c = do
  conn <- makeConnection c
  old' <- newRef mempty
  pure $ Subscriber {
    connection : conn
  , old : old'
  }

-- | Get access to the low-level Connection.
getConnection :: forall eff a. Subscriber eff a -> Connection eff a
getConnection (Subscriber impl) = impl.connection

-- | Deploy a given set of Subscriptions.
--
--   This function takes care of unsubscribing subscriptions which are no longer present adds any new ones, updates
--   already existing ones and also calls realize for actually sending Subscribe/Unsubscribe commands to the server.
deploy :: forall eff a. Subscriptions a -> Subscriber eff a -> SubscriberEff eff Unit
deploy subs (Subscriber impl)= do
  old' <- readRef impl.old
  let
    forUnsubscribe = map (_.req) <<< Subs.toList $ diffSubscriptions old' subs
  unsubscribeAll forUnsubscribe impl.connection
  subscribeAll (Subs.toList subs) impl.connection
  realize impl.connection
  writeRef impl.old subs


Update Dialog.Share component

Update Dialog.Share component

{-
Copyright 2016 SlamData, Inc.

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

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

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

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

import SlamData.Prelude

import Control.UI.Browser (select)

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

import DOM.HTML.Types (htmlElementToElement, readHTMLElement)

import Halogen as H
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B

import Quasar.Advanced.Types as QT

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

import Utils.DOM as DOM
import Utils.Path (rootFile, FilePath)

import ZClipboard as Z

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

data SubjectType
  = User
  | Group
  | Token

derive instance subjectTypeEq ∷ Eq SubjectType

data ErrorType
  = Connection
  | Validation
  | GroupList

derive instance errorTypeEq ∷ Eq ErrorType

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

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

printShareResume ∷ ShareResume → String
printShareResume = case _ of
  Edit → "Edit"
  View → "View"

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

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

data Query a
  = Init a
  | Share a
  | ChangeGroup String a
  | ChangeEmail String a
  | ChangeShareResume ShareResume a
  | ChangeSubjectType SubjectType a
  | ChangeTokenName String a
  | DismissError a
  | SelectElement DOM.Event a
  | PreventDefault DOM.Event a
  | Cancel a

data Message = Dismiss

copyButtonRef ∷ H.RefLabel
copyButtonRef = H.RefLabel "copy"

component ∷ H.Component HH.HTML Query SharingInput Message Slam
component =
  H.lifecycleComponent
    { render
    , eval
    , initialState
    , finalizer: Nothing
    , initializer: Just (H.action Init)
    , receiver: const Nothing
    }

render ∷ State → HTML
render state =
  HH.div
    [ HP.classes [ HH.ClassName "deck-dialog-share" ] ]
    ( renderTitle
    ⊕ renderBody
    ⊕ renderFooter
    )

  where
  renderTitle ∷ Array HTML
  renderTitle = case state.tokenSecret of
    Nothing → [ HH.h4_ [ HH.text "Share deck" ] ]
    Just _ →
      [ HH.h4_
          [ HH.text
              if state.tokenName ≡ ""
                then "Untitled token"
                else state.tokenName ⊕ " token"
          ]
      , HH.h5_
          [ HH.text $ printShareResume state.shareResume ]
      ]

  renderBody ∷ Array HTML
  renderBody =
    [ HH.div
       [ HP.classes [ HH.ClassName "deck-dialog-body" ]
       , HE.onClick ( HE.input_ DismissError )
       ]
       ( renderLoading
       ⊕ foldMap renderTokenSecret state.tokenSecret
       ⊕ renderSubjectForm
       )
    ]

  renderLoading ∷ Array HTML
  renderLoading =
    [ HH.div
        [ HP.classes $
            [ B.alert
            , B.alertInfo
            , HH.ClassName "share-loading"
            ]
            ⊕ (guard (not state.loading) $> B.hidden)
        ]
        [ HH.img [ HP.src "img/blue-spin.svg" ]
        , HH.text "Loading"
        ]
    ]

  renderTokenSecret ∷ String → Array HTML
  renderTokenSecret token =
    [ HH.form
        [ HE.onSubmit (HE.input PreventDefault)
        , HP.classes $ guard state.loading $> B.hidden
        ]
        [ HH.div
            [ HP.classes [ B.inputGroup ]
            , HE.onClick (HE.input SelectElement ∘ DOM.toEvent)
            ]
            [ HH.input
                [ HP.classes [ B.formControl ]
                , HP.value token
                , HP.readOnly true
                , HP.title "Token secret"
                ]
            , HH.span
                [ HP.classes [ B.inputGroupBtn ] ]
                [ HH.button
                    [ HP.classes [ B.btn, B.btnDefault ]
                    , HP.ref copyButtonRef
                    ]
                    [ glyph B.glyphiconCopy ]
                ]
            ]
        ]
    ]

  renderSubjectForm ∷ Array HTML
  renderSubjectForm =
    [ HH.form
        [ HE.onSubmit (HE.input PreventDefault)
        , HP.classes $ guard (isJust state.tokenSecret ∨ state.loading) $> B.hidden
        ]
        [ HH.label_
            [ HH.text "Subject type"
            , HH.select
                [ HP.classes [ B.formControl ]
                , HE.onValueChange (HE.input (ChangeSubjectType ∘ readSubjectType))
                , HP.disabled state.submitting
                ]
                $ [ HH.option
                      [ HP.value "user" ]
                      [ HH.text "User" ]
                  ]
                ⊕ (guard (not $ Arr.null state.groups) $>
                    HH.option
                      [ HP.value "group" ]
                      [ HH.text "Group" ]
                  )
                ⊕ [ HH.option
                      [ HP.value "token" ]
                      [ HH.text "Token" ]
                  ]
            ]
        , HH.label
            [ HP.classes
                $ (guard (state.subjectType ≠ User) $> B.hidden)
                ⊕ (guard (state.error ≡ Just Validation) $> B.hasError)
            ]
            [ HH.text "User email"
            , HH.input
                [ HP.classes [ B.formControl ]
                , HP.value state.email
                , HE.onValueInput $ HE.input ChangeEmail
                , HP.placeholder "User email"
                , HP.type_ HP.InputText
                , HP.disabled state.submitting
                ]
            ]
        , HH.label
            [ HP.classes $ guard (state.subjectType ≠ Group) $> B.hidden ]
            [ HH.text "Group path"
            , HH.select
                [ HP.classes [ B.formControl ]
                , HE.onValueChange $ HE.input ChangeGroup
                , HP.disabled $ Arr.null state.groups ∨ state.submitting
                ]
                -- I find using such things in where a bit complicated
                -- because it's break context. OTOH, lambdas are not
                -- so fancy as named func. cryogenian.
                let
                  renderOption ∷ FilePath → HTML
                  renderOption group =
                    HH.option
                      [ HP.value $ Pt.printPath  group ]
                      [ HH.text $ Pt.printPath  group ]
                in
                  map renderOption state.groups
            ]
        , HH.label
            [ HP.classes $ guard (state.subjectType ≠ Token) $> B.hidden
            ]
            [ HH.text "Token name"
            , HH.input
                [ HP.classes [ B.formControl ]
                , HP.type_ HP.InputText
                , HP.placeholder "Token name"
                , HP.value state.tokenName
                , HE.onValueInput (HE.input ChangeTokenName)
                , HP.disabled state.submitting
                ]
            ]
        , HH.label_
            [ HH.text "Permission"
            , HH.select
                [ HP.classes [ B.formControl ]
                , HE.onValueChange (HE.input (ChangeShareResume ∘ readShareResume))
                , HP.disabled state.submitting
                ]
                [ HH.option
                    [ HP.value "view" ]
                    [ HH.text "View" ]
                , HH.option
                    [ HP.value "edit" ]
                    [ HH.text "Edit" ]
                ]
            ]
        , HH.div
            [ HP.classes
                $ [ B.alert, B.alertDanger ]
                ⊕ (if state.showError
                      ∧ (state.error ≡ Just Connection ∨ state.error ≡ Just GroupList)
                      then [ ]
                      else [ B.hidden ])
            , HE.onClick (HE.input_ DismissError)
            ]
            [ HH.text
                if state.error ≡ Just Connection
                then
                  "This action couldn't be performed. "
                  ⊕ "Please check your network connection and try again"
                else
                  "Groups are unavailable. To share this deck with a group "
                  ⊕ "please check your network connection and try again."
            ]
        , HH.div
            [ HP.classes
                $ [ B.alert, B.alertInfo ]
                ⊕ (if state.showError ∧ state.error ≡ Just Validation then [ ] else [ B.hidden ])
            ]
            [ HH.text "Please check if user email is correct" ]
        ]
    ]

  renderFooter ∷ Array HTML
  renderFooter =
    [ HH.div
        [ HP.classes [ HH.ClassName "deck-dialog-footer" ] ]
        $ [ HH.button
              [ HP.classes
                  $ [ B.btn, B.btnDefault ]
                  ⊕ (guard state.loading $> B.hidden)
              , HP.type_ HP.ButtonButton
              , HE.onClick $ HE.input_ Cancel
              , HP.disabled state.submitting
              ]
              [ HH.text "Dismiss" ]
          ]
        ⊕ foldMap renderShare state.tokenSecret
    ]

  renderShare ∷ String → Array HTML
  renderShare _ =
    [ HH.button
        [ HP.classes
            $ [ B.btn, B.btnPrimary ]
            ⊕ (guard state.loading $> B.hidden)
            ⊕ (guard (isJust state.error && state.showError) $> B.hasError)
        , HP.type_ HP.ButtonButton
        , HE.onClick (HE.input_ Share)
        , HP.disabled $
            state.submitting
            ∨ ((state.email ≡ "" ∨ state.error ≡ Just Validation)
               ∧ state.subjectType ≡ User)
        ]
        [ HH.text
            if state.submitting
              then "Sharing..."
              else "Share"
        ]
    ]

eval ∷ Query ~> DSL
eval = case _ of
  Init next → do
    Q.groupInfo (rootDir </> file "") >>= case _ of
      Left _ →
        H.modify _
          { error = Just GroupList
          , showError = true
          , loading = false
          }
      Right grInfo → do
        let groups = [ rootFile ] ⊕ grInfo.subGroups
        H.modify _
          { groups = groups
          , loading = false
          }
    pure next
  Share next → do
    H.modify _
      { error = Nothing
      , showError = false
      , submitting = true
      }
    state ← H.get
    if state.subjectType ≡ Token
      then shareToken state
      else sharePermission state
    pure next
  DismissError next →
    H.modify _ { showError = false } $> next
  ChangeSubjectType st next → do
    if st ≡ User
      then H.modify _
        { subjectType = st
        , error = Nothing
        , showError = false
        }
      else H.modify _ { subjectType = st }
    pure next
  ChangeEmail str next → do
    mbError ← H.gets _.error
    unless (mbError ≡ Just Connection) $
      if emailIsIncorrect str
        then H.modify _
          { error = Just Validation
          , showError = true
          , email = str
          }
        else H.modify _
          { error = Nothing
          , showError = false
          , email = str
          }
    pure next
  ChangeGroup grpString next → do
    groups ← H.gets _.groups
    let group = Arr.find (eq grpString ∘ Pt.printPath) groups
    H.modify _ { groupSelected = group }
    pure next
  ChangeTokenName str next →
    H.modify _ { tokenName = str } $> next
  ChangeShareResume sr next →
    H.modify _ { shareResume = sr } $> next
  SelectElement ev next → do
    H.liftEff $ DOM.currentTarget
      # readHTMLElement ∘ toForeign
      # runExcept
      # traverse_ select
    pure next
  PreventDefault ev next →
    H.liftEff (DOM.preventDefault ev) $> next
  Cancel next →
    H.raise Dismiss $> next

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

initZClipboard ∷ String → DSL Unit
initZClipboard token =
  H.getHTMLElementRef copyButtonRef >>= traverse_ \htmlEl →
    H.liftEff $ Z.make (htmlElementToElement htmlEl)
      >>= Z.onCopy (Z.setData "text/plain" token)

shareToken ∷ State → DSL Unit
shareToken state = do
  res ←
    Q.createToken
      (if state.tokenName ≡ "" then Nothing else Just $ QT.TokenName state.tokenName)
      (sharingActions state.sharingInput state.shareResume)
  case res of
    Left _ → showConnectionError
    Right token → do
      let tokenSecret = QT.runTokenHash token.secret
      H.modify _
        { tokenSecret = Just tokenSecret
        , submitting = false
        }
      initZClipboard tokenSecret

sharePermission ∷ State → DSL Unit
sharePermission state = do
  let
    users = if state.subjectType ≡ User then [ QT.UserId state.email ] else [ ]
    groups = if state.subjectType ≡ Group then foldMap (pure ∘ Right) state.groupSelected else [ ]
    actions = sharingActions state.sharingInput state.shareResume
  Q.sharePermission { users, groups, actions } >>= case _ of
    Left _   → showConnectionError
    Right [] → showConnectionError
    Right _  → H.raise Dismiss

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

{-
Copyright 2016 SlamData, Inc.

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

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

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

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

import SlamData.Prelude

import Control.UI.Browser (select)

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

import DOM.HTML.Types (HTMLElement, htmlElementToElement)

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

import Quasar.Advanced.Types as QT

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

import Utils.Path (rootFile, FilePath)

import ZClipboard as Z

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

data SubjectType
  = User
  | Group
  | Token

derive instance subjectTypeEq ∷ Eq SubjectType

data ErrorType
  = Connection
  | Validation
  | GroupList

derive instance errorTypeEq ∷ Eq ErrorType

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

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

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

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

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

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

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

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

               [ HH.div
                   [ HP.classes [ B.inputGroup ]
                   , HE.onClick $ HE.input (SelectElement ∘ _.target)
                   ]
                   [ HH.input
                       [ HP.classes [ B.formControl ]
                       , HP.value token
                       , HP.readonly true
                       , HP.title "Token secret"
                       ]
                   , HH.span
                       [ HP.classes [ B.inputGroupBtn ] ]
                       [ HH.button
                           [ HP.classes [ B.btn, B.btnDefault ]
                           , HP.ref (H.action ∘ InitZClipboard token)
                           , HP.id_ "copy-button"
                           ]
                           [ glyph B.glyphiconCopy ]
                       ]
                   ]
               ]
           ])
       ⊕ [ HH.form
             [ Cp.nonSubmit
             , HP.classes if isJust state.tokenSecret ∨ state.loading then [ B.hidden ] else [ ]
             ]
             [ HH.label
                 [ HP.for "subject-type" ]
                 [ HH.text "Subject type"
                 , HH.select
                     [ HP.classes [ B.formControl ]
                     , HP.id_ "subject-type"
                     , HE.onValueChange (HE.input (ChangeSubjectType ∘ readSubjectType))
                     , HP.disabled state.submitting
                     ]
                     $ [ HH.option
                          [ HP.value "user" ]
                          [ HH.text "User" ]
                       ]
                     ⊕ (guard (not $ Arr.null state.groups)
                        $>  HH.option
                              [ HP.value "group" ]
                              [ HH.text "Group" ]
                       )
                     ⊕ [ HH.option
                         [ HP.value "token" ]
                         [ HH.text "Token" ]
                       ]
                 ]
             , HH.label
                 [ HP.classes
                     $ (if state.subjectType ≠ User then [ B.hidden ] else [ ])
                     ⊕ (if state.error ≡ Just Validation then [ B.hasError ] else [ ])
                 , HP.for "user-email"
                 ]
                 [ HH.text "User email"
                 , HH.input
                     [ HP.classes [ B.formControl ]
                     , HP.id_ "user-email"
                     , HP.value state.email
                     , HE.onValueInput $ HE.input EmailChanged
                     , HP.placeholder "User email"
                     , HP.type_ HP.InputText
                     , HP.disabled state.submitting
                     ]
                 ]
              , HH.label
                  [ HP.classes $ if state.subjectType ≠ Group then [ B.hidden ] else [ ]
                  , HP.for "group-path"
                  ]
                  [ HH.text "Group path"
                  , HH.select
                      [ HP.classes [ B.formControl ]
                      , HP.id_ "group-path"
                      , HE.onValueChange (HE.input GroupSelected)
                      , HP.disabled $ Arr.null state.groups ∨ state.submitting
                      ]
                      -- I find using such things in where a bit complicated
                      -- because it's break context. OTOH, lambdas are not
                      -- so fancy as named func. cryogenian.
                      let
                        renderOption ∷ FilePath → HTML
                        renderOption group =
                          HH.option
                            [ HP.value $ Pt.printPath  group ]
                            [ HH.text $ Pt.printPath  group ]
                      in
                        map renderOption state.groups
                  ]
              , HH.label
                  [ HP.classes $ if state.subjectType ≠ Token then [ B.hidden ] else [ ]
                  , HP.for "token-name"
                  ]
                  [ HH.text "Token name"
                  , HH.input
                      [ HP.id_ "token-name"
                      , HP.classes [ B.formControl ]
                      , HP.type_ HP.InputText
                      , HP.placeholder "Token name"
                      , HP.value state.tokenName
                      , HE.onValueInput (HE.input TokenNameChanged)
                      , HP.disabled state.submitting
                      ]
                  ]
             , HH.label
                 [ HP.for "permission" ]
                 [ HH.text "Permission"
                 , HH.select
                     [ HP.id_ "permission"
                     , HP.classes [ B.formControl ]
                     , HE.onValueChange (HE.input (ChangeShareResume ∘ readShareResume))
                     , HP.disabled state.submitting
                     ]
                     [ HH.option
                         [ HP.value "view" ]
                         [ HH.text "View" ]
                     , HH.option
                         [ HP.value "edit" ]
                         [ HH.text "Edit" ]
                     ]
                 ]
             , HH.div
                  [ HP.classes
                      $ [ B.alert, B.alertDanger ]
                      ⊕ (if state.showError
                            ∧ (state.error ≡ Just Connection ∨ state.error ≡ Just GroupList)
                           then [ ]
                           else [ B.hidden ])
                  , HE.onClick (HE.input_ DismissError)
                  ]
                  [ HH.text
                      if state.error ≡ Just Connection
                      then
                        "This action couldn't be performed. "
                        ⊕ "Please check your network connection and try again"
                      else
                        "Groups are unavailable. To share this deck with a group "
                        ⊕ "please check your network connection and try again."
                  ]
             , HH.div
                 [ HP.classes
                     $ [ B.alert, B.alertInfo ]
                     ⊕ (if state.showError ∧ state.error ≡ Just Validation then [ ] else [ B.hidden ])
                 ]
                 [ HH.text "Please check if user email is correct" ]
             ]
         ]

    , HH.div
         [ HP.classes [ HH.ClassName "deck-dialog-footer" ] ]
         $ [ HH.button
               [ HP.classes
                   $ [ B.btn, B.btnDefault ]
                   ⊕ (if state.loading then [ B.hidden ] else [ ])
               , HP.type_ HP.ButtonButton
               , HE.onClick (HE.input_ Dismiss)
               , HP.disabled state.submitting
               ]
               [ HH.text "Dismiss" ]
           ]
           ⊕ (if isJust state.tokenSecret
                then [ ]
                else
                [ HH.button
                    [ HP.classes
                        $ [ B.btn, B.btnPrimary ]
                        ⊕ (if state.loading then [ B.hidden ] else [ ])
                        ⊕ (if isJust state.error && state.showError then [ B.hasError ] else [ ])
                    , HP.type_ HP.ButtonButton
                    , HE.onClick (HE.input_ Share)
                    , HP.disabled (state.submitting ∨
                                   ((state.email ≡ "" ∨ state.error ≡ Just Validation)
                                    ∧ state.subjectType ≡ User))
                    ]
                    [ HH.text if state.submitting then "Sharing..." else  "Share" ]
                ])
    ]

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

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

  let
    actions = sharingActions state.sharingInput state.shareResume

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

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

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

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