move workspace

move workspace

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Quasar.FS
  ( children
  , transitiveChildren
  , getNewName
  , move
  , listing
  , delete
  , messageIfFileNotFound
  , dirNotAccessible
  , fileNotAccessible
  , module Quasar.Error
  ) where

import SlamData.Prelude

import Control.Monad.Eff.Exception (error)

import Data.Argonaut as J
import Data.Array as Arr
import Data.Foldable as F
import Data.Lens ((.~), (^.), (^?), _Left)
import Data.List as List
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.String as S

import Quasar.Advanced.QuasarAF as QF
import Quasar.Data.JSONMode as QDJ
import Quasar.Error (QError(..))
import Quasar.FS as QFS
import Quasar.FS.Mount as QFSM
import Quasar.FS.Resource as QR
import Quasar.Types (AnyPath, DirPath, FilePath)

import SlamData.Config as Config
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Class (class QuasarDSL, liftQuasar)
import SlamData.Quasar.Data as QD

import SlamData.Workspace.Model as WM
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Deck.DeckId as DID
import SlamData.Workspace.Card.Draftboard.Pane as Pane

children
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
children dir = runExceptT do
  cs ← ExceptT $ listing dir
  let result = (R._root .~ dir) <$> cs
  -- TODO: do this somewhere more appropriate
  -- lift $ fromAff $ memoizeCompletionStrs dir result
  pure result

transitiveChildren
  ∷ ∀ f m
  . (Parallel f m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
transitiveChildren start = runExceptT do
  rs ← ExceptT $ children start
  cs ← parTraverse go rs
  pure $ rs <> join cs
  where
  go :: R.Resource → ExceptT QError m (Array R.Resource)
  go r = case R.getPath r of
    Left dir → do
      crs ← ExceptT $ transitiveChildren dir
      pure $ [r] <> crs
    Right _ → pure [r]

listing
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
listing p =
  map (map toResource) <$> liftQuasar (QF.dirMetadata p)
  where
  toResource ∷ QFS.Resource → R.Resource
  toResource res = case res of
    QFS.File path → R.File path
    QFS.Directory path →
      let workspaceName
            = S.stripSuffix (S.Pattern $ "." <> Config.workspaceExtension)
            ∘ P.runDirName =<< P.dirName path
      in case workspaceName of
        Just name → R.Workspace (p </> P.dir name)
        Nothing → R.Directory path
    QFS.Mount m → R.Mount $ either R.Database R.View $ QFSM.getPath m

-- | Generates a new resource name based on a directory path and a name for the
-- | resource. If the name already exists in the path a number is appended to
-- | the end of the name.
getNewName
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ DirPath
  → String
  → m (Either QError String)
getNewName parent name = do
  result ← liftQuasar (QF.dirMetadata parent)
  pure case result of
    Right items
      | exists name items → Right (getNewName' items 1)
      | otherwise → Right name
    Left QF.NotFound → Right name
    Left err → Left err
  where

  getNewName' ∷ Array QFS.Resource → Int → String
  getNewName' items i =
    let arr = S.split (S.Pattern ".") name
    in fromMaybe "" do
      body ← Arr.head arr
      suffixes ← Arr.tail arr
      let newName = S.joinWith "." $ Arr.cons (body <> " " <> show i) suffixes
      pure if exists newName items
           then getNewName' items (i + one)
           else newName

  exists ∷ String → Array QFS.Resource → Boolean
  exists n = F.any ((_ == n) ∘ printName ∘ QR.getName)

  printName ∷ Either (Maybe P.DirName) P.FileName → String
  printName = either (fromMaybe "" ∘ map P.runDirName) P.runFileName

-- | Will return `Just` in case the resource was successfully moved, and
-- | `Nothing` in case no resource existed at the requested source path.
move
  ∷ ∀ f m
  . (Monad m, QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → AnyPath
  → m (Either QError (Maybe AnyPath))
move src tgt = do
  let
    srcPath = R.getPath src

  runExceptT ∘ traverse cleanViewMounts $ srcPath ^? _Left

  case src of
    R.Workspace wsDir → void $ prepareWorkspaceForMoving wsDir
    _ → pure unit

  result ←
    case src of
      R.Mount _ → liftQuasar $ QF.moveMount srcPath tgt
      _ → liftQuasar $ QF.moveData srcPath tgt

  pure
    case result of
      Right _ → Right (Just tgt)
      Left QF.NotFound → Right Nothing
      Left err → Left err

  where
  prepareWorkspaceForMoving ∷ DirPath → m (QError ⊹ Unit)
  prepareWorkspaceForMoving wsDir = do
    eitherDid ← getWorkspaceRoot wsDir
    case eitherDid of
      Left e → pure $ Left e
      Right Nothing → pure $ Right unit
      Right (Just did) → do
        deck ← getDeck wsDir did
        case deck of
          Left e → pure $ Left e
          Right deck' → do
            newDeck ← oneDeck wsDir deck'
            case newDeck of
              Left e → pure $ Left e
              Right (true × d) → putDeck wsDir did d
              _ → pure $ Right unit

  getWorkspaceRoot ∷ DirPath → m (QError ⊹ Maybe DID.DeckId)
  getWorkspaceRoot wsDir = do
    wsIndexArr ←
      liftQuasar $ QF.readFile QDJ.Readable (wsDir </> P.file "index") Nothing
    pure case wsIndexArr of
      Left e → Left e
      Right wsIArr → case Arr.head wsIArr of
        Nothing → Left $ Error $ error "incorrect workspace model"
        Just wmJS → case WM.decode wmJS of
          Left e → Left $ Error $ error e
          Right ok → Right ok.root

  getDeck ∷ DirPath → DID.DeckId → m (QError ⊹ DM.Deck)
  getDeck wsDir did = do
    deckJArr ←
      liftQuasar
        $ QF.readFile
          QDJ.Readable
          (wsDir </> P.dir (DID.deckIdToString did) </> P.file "index")
          Nothing
    pure case deckJArr of
      Left e → Left e
      Right arr → case Arr.head arr of
        Nothing → Left $ Error $ error "incorrect deck model"
        Just deckJS →
          case DM.decode deckJS of
            Left e → Left $ Error $ error e
            Right ok → Right ok

  putDeck ∷ DirPath → DID.DeckId → DM.Deck → m (QError ⊹ Unit)
  putDeck wsDir did deck = do
    QD.save
      (wsDir </> P.dir (DID.deckIdToString did) </> P.file "index")
      (J.encodeJson $ Arr.singleton $ DM.encode deck)

  oneDeck ∷ DirPath → DM.Deck → m (QError ⊹ (Boolean × DM.Deck))
  oneDeck wsDir deck =
    let
      foldFn current@(shouldSave × d) = case _ of
        {model: CM.Draftboard m} → do
          for_ (List.catMaybes $ Pane.toList m.layout) \did → do
            d' ← getDeck wsDir  did
            for_ d' \deck' → do
              newDeck ← oneDeck wsDir deck'
              for_ newDeck \(save × d') →
                when save $ void $ putDeck wsDir did d'
          pure current
        {cardId, model: CM.Cache m} →
          let newM =
                S.replace
                  (S.Pattern $ P.printPath wsDir)
                  (S.Replacement $ either P.printPath P.printPath tgt)
                  <$> m
          in
           pure $ true × d{cards =
                             Arr.sortBy (\{cardId: a} {cardId: b} → compare a b)
                             $ Arr.cons {cardId, model: CM.Cache newM}
                             $ Arr.filter (_.cardId ⋙ eq cardId ⋙ not) d.cards
                          }

        _ → pure current
    in Right <$> Arr.foldM foldFn (false × deck) deck.cards

delete
  ∷ ∀ f m
  . (Monad m, QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → m (Either QError (Maybe R.Resource))
delete resource =
  runExceptT $
    if R.isMount resource || alreadyInTrash resource
    then
      forceDelete resource $> Nothing
    else
      moveToTrash resource `catchError` \(err ∷ QError) →
        forceDelete resource $> Nothing

  where
  msg ∷ String
  msg = "cannot delete"

  moveToTrash
    ∷ R.Resource
    → ExceptT QError m (Maybe R.Resource)
  moveToTrash res = do
    let
      d = (res ^. R._root) </> P.dir Config.trashFolder
      path = (res # R._root .~ d) ^. R._path
    name ← ExceptT $ getNewName d (res ^. R._name)
    ExceptT $ move res (path # R._nameAnyPath .~ name)
    pure ∘ Just $ R.Directory d

  alreadyInTrash ∷ R.Resource → Boolean
  alreadyInTrash res =
    case res ^. R._path of
      Left path → alreadyInTrash' path
      Right _ → alreadyInTrash' (res ^. R._root)

  alreadyInTrash' ∷ DirPath → Boolean
  alreadyInTrash' d =
    if d == P.rootDir
    then false
    else maybe false go $ P.peel d

    where
    go ∷ Tuple DirPath (Either P.DirName P.FileName) → Boolean
    go (Tuple d' name) =
      case name of
        Right _ → false
        Left n →
          if n == P.DirName Config.trashFolder
          then true
          else alreadyInTrash' d'

forceDelete
  ∷ ∀ f m
  . (QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → ExceptT QError m Unit
forceDelete res =
  case res of
    R.Mount _ →
      ExceptT ∘ liftQuasar $ QF.deleteMount (R.getPath res)
    _ → do
      let path = R.getPath res
      traverse cleanViewMounts $ path ^? _Left
      ExceptT ∘ liftQuasar $ QF.deleteData path

cleanViewMounts
  ∷ ∀ f m
  . (Parallel f m, QuasarDSL m)
  ⇒ DirPath
  → ExceptT QError m Unit
cleanViewMounts =
  parTraverse_ deleteViewMount <=< ExceptT ∘ transitiveChildren
  where
  deleteViewMount ∷ R.Resource → ExceptT QError m Unit
  deleteViewMount =
    case _ of
      R.Mount (R.View vp) →
        ExceptT ∘ liftQuasar $ QF.deleteMount (Right vp)
      _ → pure unit

messageIfFileNotFound
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ FilePath
  → String
  → m (Either QError (Maybe String))
messageIfFileNotFound path defaultMsg =
  handleResult <$> liftQuasar (QF.fileMetadata path)
  where
  handleResult ∷ ∀ a. Either QF.QError a → Either QError (Maybe String)
  handleResult (Left QF.NotFound) = Right (Just defaultMsg)
  handleResult (Left err) = Left err
  handleResult (Right _) = Right Nothing

dirNotAccessible
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ DirPath
  → m (Maybe QF.QError)
dirNotAccessible path =
  either Just (const Nothing) <$> liftQuasar (QF.dirMetadata path)

fileNotAccessible
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ FilePath
  → m (Maybe QF.QError)
fileNotAccessible path =
  either Just (const Nothing) <$> liftQuasar (QF.fileMetadata path)

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Quasar.FS
  ( children
  , transitiveChildren
  , getNewName
  , move
  , listing
  , delete
  , messageIfFileNotFound
  , dirNotAccessible
  , fileNotAccessible
  , module Quasar.Error
  ) where

import SlamData.Prelude

import Control.Monad.Eff.Exception (error)

import Data.Argonaut as J
import Data.Array as Arr
import Data.Foldable as F
import Data.Lens ((.~), (^.), (^?), _Left)
import Data.List as List
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.String as S

import Quasar.Advanced.QuasarAF as QF
import Quasar.Data.JSONMode as QDJ
import Quasar.Error (QError(..))
import Quasar.FS as QFS
import Quasar.FS.Mount as QFSM
import Quasar.FS.Resource as QR
import Quasar.Types (AnyPath, DirPath, FilePath)

import SlamData.Config as Config
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Class (class QuasarDSL, liftQuasar)
import SlamData.Quasar.Data as QD

import SlamData.Workspace.Model as WM
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Card.Model as CM
import SlamData.Workspace.Deck.DeckId as DID
import SlamData.Workspace.Card.Draftboard.Pane as Pane

children
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
children dir = runExceptT do
  cs ← ExceptT $ listing dir
  let result = (R._root .~ dir) <$> cs
  -- TODO: do this somewhere more appropriate
  -- lift $ fromAff $ memoizeCompletionStrs dir result
  pure result

transitiveChildren
  ∷ ∀ f m
  . (Parallel f m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
transitiveChildren start = runExceptT do
  rs ← ExceptT $ children start
  cs ← parTraverse go rs
  pure $ rs <> join cs
  where
  go :: R.Resource → ExceptT QError m (Array R.Resource)
  go r = case R.getPath r of
    Left dir → do
      crs ← ExceptT $ transitiveChildren dir
      pure $ [r] <> crs
    Right _ → pure [r]

listing
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ DirPath
  → m (Either QError (Array R.Resource))
listing p =
  map (map toResource) <$> liftQuasar (QF.dirMetadata p)
  where
  toResource ∷ QFS.Resource → R.Resource
  toResource res = case res of
    QFS.File path → R.File path
    QFS.Directory path →
      let workspaceName
            = S.stripSuffix (S.Pattern $ "." <> Config.workspaceExtension)
            ∘ P.runDirName =<< P.dirName path
      in case workspaceName of
        Just name → R.Workspace (p </> P.dir name)
        Nothing → R.Directory path
    QFS.Mount m → R.Mount $ either R.Database R.View $ QFSM.getPath m

-- | Generates a new resource name based on a directory path and a name for the
-- | resource. If the name already exists in the path a number is appended to
-- | the end of the name.
getNewName
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ DirPath
  → String
  → m (Either QError String)
getNewName parent name = do
  result ← liftQuasar (QF.dirMetadata parent)
  pure case result of
    Right items
      | exists name items → Right (getNewName' items 1)
      | otherwise → Right name
    Left QF.NotFound → Right name
    Left err → Left err
  where

  getNewName' ∷ Array QFS.Resource → Int → String
  getNewName' items i =
    let arr = S.split (S.Pattern ".") name
    in fromMaybe "" do
      body ← Arr.head arr
      suffixes ← Arr.tail arr
      let newName = S.joinWith "." $ Arr.cons (body <> " " <> show i) suffixes
      pure if exists newName items
           then getNewName' items (i + one)
           else newName

  exists ∷ String → Array QFS.Resource → Boolean
  exists n = F.any ((_ == n) ∘ printName ∘ QR.getName)

  printName ∷ Either (Maybe P.DirName) P.FileName → String
  printName = either (fromMaybe "" ∘ map P.runDirName) P.runFileName

-- | Will return `Just` in case the resource was successfully moved, and
-- | `Nothing` in case no resource existed at the requested source path.
move
  ∷ ∀ f m
  . (Monad m, QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → AnyPath
  → m (Either QError (Maybe AnyPath))
move src tgt = do
  let srcPath = R.getPath src
  runExceptT ∘ traverse cleanViewMounts $ srcPath ^? _Left

  case src of
    R.Workspace wsDir → void $ prepareWorkspaceForMoving wsDir
    _ → pure unit

  result ←
    case src of
      R.Mount _ → liftQuasar $ QF.moveMount srcPath tgt
      _ → liftQuasar $ QF.moveData srcPath tgt

  pure
    case result of
      Right _ → Right (Just tgt)
      Left QF.NotFound → Right Nothing
      Left err → Left err

  where
  prepareWorkspaceForMoving ∷ DirPath → m (QError ⊹ Unit)
  prepareWorkspaceForMoving wsDir = do
    eitherDid ← getWorkspaceRoot wsDir
    case eitherDid of
      Left e → pure $ Left e
      Right Nothing → pure $ Right unit
      Right (Just did) → do
        deck ← getDeck wsDir did
        case deck of
          Left e → pure $ Left e
          Right deck' → do
            newDeck ← oneDeck wsDir deck'
            case newDeck of
              Left e → pure $ Left e
              Right d → putDeck wsDir did d

  getWorkspaceRoot ∷ DirPath → m (QError ⊹ Maybe DID.DeckId)
  getWorkspaceRoot wsDir = do
    wsIndexArr ←
      liftQuasar $ QF.readFile QDJ.Readable (wsDir </> P.file "index") Nothing
    pure case wsIndexArr of
      Left e → Left e
      Right wsIArr → case Arr.head wsIArr of
        Nothing → Left $ Error $ error "incorrect workspace model"
        Just wmJS → case WM.decode wmJS of
          Left e → Left $ Error $ error e
          Right ok → Right ok.root

  getDeck ∷ DirPath → DID.DeckId → m (QError ⊹ DM.Deck)
  getDeck wsDir did = do
    deckJArr ←
      liftQuasar
        $ QF.readFile
          QDJ.Readable
          (wsDir </> P.dir (DID.deckIdToString did) </> P.file "index")
          Nothing
    pure case deckJArr of
      Left e → Left e
      Right arr → case Arr.head arr of
        Nothing → Left $ Error $ error "incorrect deck model"
        Just deckJS →
          case DM.decode deckJS of
            Left e → Left $ Error $ error e
            Right ok → Right ok

  putDeck ∷ DirPath → DID.DeckId → DM.Deck → m (QError ⊹ Unit)
  putDeck wsDir did deck =
    QD.save
      (wsDir </> P.dir (DID.deckIdToString did) </> P.file "index")
      (J.encodeJson $ Arr.singleton $ DM.encode deck)

  oneDeck ∷ DirPath → DM.Deck → m (QError ⊹ DM.Deck)
  oneDeck wsDir deck =
    let
      foldFn d = case _ of
        {model: CM.Draftboard m} → do
          for_ (List.catMaybes $ Pane.toList m.layout) \did → do
            d' ← getDeck wsDir  did
            for_ d' \deck' → do
              newDeck ← oneDeck wsDir deck'
              for_ newDeck $ putDeck wsDir did
          pure d
        {cardId, model: CM.Cache m} →
          let newM =
                S.replace
                  (S.Pattern $ P.printPath wsDir)
                  (S.Replacement $ either P.printPath P.printPath tgt)
                  <$> m
          in
           pure d{cards =
                     Arr.sortBy (\{cardId: a} {cardId: b} → compare a b)
                       $ Arr.cons {cardId, model: CM.Cache newM}
                       $ Arr.filter (_.cardId ⋙ eq cardId ⋙ not) d.cards
                 }

        _ → pure d
    in Right <$> Arr.foldM foldFn deck deck.cards

delete
  ∷ ∀ f m
  . (Monad m, QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → m (Either QError (Maybe R.Resource))
delete resource =
  runExceptT $
    if R.isMount resource || alreadyInTrash resource
    then
      forceDelete resource $> Nothing
    else
      moveToTrash resource `catchError` \(err ∷ QError) →
        forceDelete resource $> Nothing

  where
  msg ∷ String
  msg = "cannot delete"

  moveToTrash
    ∷ R.Resource
    → ExceptT QError m (Maybe R.Resource)
  moveToTrash res = do
    let
      d = (res ^. R._root) </> P.dir Config.trashFolder
      path = (res # R._root .~ d) ^. R._path
    name ← ExceptT $ getNewName d (res ^. R._name)
    ExceptT $ move res (path # R._nameAnyPath .~ name)
    pure ∘ Just $ R.Directory d

  alreadyInTrash ∷ R.Resource → Boolean
  alreadyInTrash res =
    case res ^. R._path of
      Left path → alreadyInTrash' path
      Right _ → alreadyInTrash' (res ^. R._root)

  alreadyInTrash' ∷ DirPath → Boolean
  alreadyInTrash' d =
    if d == P.rootDir
    then false
    else maybe false go $ P.peel d

    where
    go ∷ Tuple DirPath (Either P.DirName P.FileName) → Boolean
    go (Tuple d' name) =
      case name of
        Right _ → false
        Left n →
          if n == P.DirName Config.trashFolder
          then true
          else alreadyInTrash' d'

forceDelete
  ∷ ∀ f m
  . (QuasarDSL m, Parallel f m)
  ⇒ R.Resource
  → ExceptT QError m Unit
forceDelete res =
  case res of
    R.Mount _ →
      ExceptT ∘ liftQuasar $ QF.deleteMount (R.getPath res)
    _ → do
      let path = R.getPath res
      traverse cleanViewMounts $ path ^? _Left
      ExceptT ∘ liftQuasar $ QF.deleteData path

cleanViewMounts
  ∷ ∀ f m
  . (Parallel f m, QuasarDSL m)
  ⇒ DirPath
  → ExceptT QError m Unit
cleanViewMounts =
  parTraverse_ deleteViewMount <=< ExceptT ∘ transitiveChildren
  where
  deleteViewMount ∷ R.Resource → ExceptT QError m Unit
  deleteViewMount =
    case _ of
      R.Mount (R.View vp) →
        ExceptT ∘ liftQuasar $ QF.deleteMount (Right vp)
      _ → pure unit

messageIfFileNotFound
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ FilePath
  → String
  → m (Either QError (Maybe String))
messageIfFileNotFound path defaultMsg =
  handleResult <$> liftQuasar (QF.fileMetadata path)
  where
  handleResult ∷ ∀ a. Either QF.QError a → Either QError (Maybe String)
  handleResult (Left QF.NotFound) = Right (Just defaultMsg)
  handleResult (Left err) = Left err
  handleResult (Right _) = Right Nothing

dirNotAccessible
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ DirPath
  → m (Maybe QF.QError)
dirNotAccessible path =
  either Just (const Nothing) <$> liftQuasar (QF.dirMetadata path)

fileNotAccessible
  ∷ ∀ m
  . (Functor m, QuasarDSL m)
  ⇒ FilePath
  → m (Maybe QF.QError)
fileNotAccessible path =
  either Just (const Nothing) <$> liftQuasar (QF.fileMetadata path)


Set card icon class.

Set card icon class.

module Main where

import Prelude hiding (append)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.JQuery
  ( JQuery
  , JQueryEvent
  , append
  , appendText
  , body
  , clone
  , create
  , css
  , find
  , getValue
  , on
  , on'
  , ready
  , select
  , setAttr
  , setClass
  , setText
  )
import Control.Monad.Eff.Ref (Ref, REF, readRef, modifyRef, newRef)

import Data.AppState (AppState(..))
import Data.Array ((..), elem, findIndex, index)
import Data.DateTime as DT
import Data.JSDate (LOCALE, parse, toDateTime)
import Data.Map as M
import Data.Maybe (Maybe(..), fromMaybe)
import Data.WeatherCard (WeatherCard, CardKey)

import DOM (DOM)

foreign import test :: Int

main :: forall e. Eff (console :: CONSOLE, dom :: DOM, locale :: LOCALE, ref :: REF | e) Unit
main = ready $ do
  log "Hello PWA!"

  spinner <- select ".loader"
  cardTemplate <- select ".cardTemplate"
  container <- select ".main"
  addDialog <- select ".dialog-container"

  stateRef <- newRef $ AppState
    { isLoading: true
    , visibleCards: M.empty
    , spinner: spinner
    , cardTemplate: cardTemplate
    , container: container
    , addDialog: addDialog
    }

  body <- body
  on' "click" "#butAdd" (\_ _ -> toggleAddDialog true addDialog) body

  hideSpinner spinner

  updateForecastCard stateRef initialWeatherForecast

-- Methods to update/refresh the UI

hideSpinner :: forall e. JQuery -> Eff (dom :: DOM | e) Unit
hideSpinner = setAttr "hidden" true

toggleAddDialog :: forall e. Boolean -> JQuery -> Eff (dom :: DOM | e) Unit
toggleAddDialog visible = setClass "dialog-container--visible" visible

updateForecastCard
  :: forall e
   . Ref AppState
  -> WeatherCard
  -> Eff (dom :: DOM, locale :: LOCALE, ref :: REF | e) Unit
updateForecastCard stateRef cardData = do
  let dataLastUpdated = toDateTime <$> parse cardData.created  -- Maybe DT.DateTime
  let key = cardData.key
  let current = cardData.channel.item.condition

  card <- getOrCreateCard stateRef key
  find ".description" card >>= setText current.text
  find ".date" card >>= setText current.date
  find ".current .icon" card >>= setClass (getIconClass current.code) true

getOrCreateCard
  :: forall e
   . Ref AppState
  -> CardKey
  -> Eff (dom :: DOM, ref :: REF | e) JQuery
getOrCreateCard stateRef key = do
  AppState state <- readRef stateRef
  case M.lookup key state.visibleCards of
    Just wc ->
      pure wc
    Nothing -> do
      -- card doesn't exist - clone from template and store in state
      nc <- clone state.cardTemplate
      setClass "cardTemplate" false nc
      setAttr "hidden" false nc
      append nc state.container
      modifyRef stateRef $ addCardForKey key nc
      pure nc

-- Methods for dealing with the model

addCardForKey :: CardKey -> JQuery -> AppState -> AppState
addCardForKey key card (AppState state) =
  AppState state { visibleCards = M.insert key card state.visibleCards }

-- Weather codes: https://developer.yahoo.com/weather/documentation.html#codes
weatherCodes =
  [ [25, 32, 33, 34, 36, 3200]
  , [0, 1, 2, 6] <> 8..12 <> [17, 35, 40]
  , [3, 4, 37, 38, 39, 45, 47]
  , [5, 7, 13, 14, 16, 18, 41, 42, 43, 46]
  , [15] <> 19..22
  , [23, 24]
  , [26, 27, 28, 31]
  , [29, 30, 44]
  ]

weatherClasses =
  [ "clear-day"
  , "rain"
  , "thunderstorms"
  , "snow"
  , "fog"
  , "windy"
  , "cloudy"
  , "partly-cloudy-day"
  ]

getIconClass :: Int -> String
getIconClass weatherCode =
  fromMaybe "clear-day" $ findIndex (elem weatherCode) weatherCodes >>= index weatherClasses

-- Fake data
initialWeatherForecast :: WeatherCard
initialWeatherForecast = {
  key: "2459115"
, label: "New York, NY"
, created: "2016-07-22T01:00:00Z"
, channel: {
    astronomy: {
      sunrise: "5:43 am"
    , sunset: "8:21 pm"
    }
  , item: {
      condition: {
        text: "Windy"
      , date: "Thu, 21 Jul 2016 09:00 PM EDT"
      , temp: 56
      , code: 24
      }
    , forecast: [
        {code: 44, high: 86, low: 70}
      , {code: 44, high: 94, low: 73}
      , {code: 4, high: 95, low: 78}
      , {code: 24, high: 75, low: 89}
      , {code: 24, high: 89, low: 77}
      , {code: 44, high: 92, low: 79}
      , {code: 44, high: 89, low: 77}
      ]
    }
  , atmosphere: {humidity: 56}
  , wind: {
      speed: 25
    , direction: 195
    }
  }
}

module Main where

import Prelude hiding (append)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.JQuery
  ( JQuery
  , JQueryEvent
  , append
  , appendText
  , body
  , clone
  , create
  , css
  , find
  , getValue
  , on
  , on'
  , ready
  , select
  , setAttr
  , setClass
  , setText
  )
import Control.Monad.Eff.Ref (Ref, REF, readRef, modifyRef, newRef)

import Data.AppState (AppState(..))
import Data.DateTime as DT
import Data.JSDate (LOCALE, parse, toDateTime)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.WeatherCard (WeatherCard, CardKey)

import DOM (DOM)

foreign import test :: Int

main :: forall e. Eff (console :: CONSOLE, dom :: DOM, locale :: LOCALE, ref :: REF | e) Unit
main = ready $ do
  log "Hello PWA!"

  spinner <- select ".loader"
  cardTemplate <- select ".cardTemplate"
  container <- select ".main"
  addDialog <- select ".dialog-container"

  stateRef <- newRef $ AppState
    { isLoading: true
    , visibleCards: M.empty
    , spinner: spinner
    , cardTemplate: cardTemplate
    , container: container
    , addDialog: addDialog
    }

  body <- body
  on' "click" "#butAdd" (\_ _ -> toggleAddDialog true addDialog) body

  hideSpinner spinner

  updateForecastCard stateRef initialWeatherForecast

-- Methods to update/refresh the UI

hideSpinner :: forall e. JQuery -> Eff (dom :: DOM | e) Unit
hideSpinner = setAttr "hidden" true

toggleAddDialog :: forall e. Boolean -> JQuery -> Eff (dom :: DOM | e) Unit
toggleAddDialog visible = setClass "dialog-container--visible" visible

updateForecastCard
  :: forall e
   . Ref AppState
  -> WeatherCard
  -> Eff (dom :: DOM, locale :: LOCALE, ref :: REF | e) Unit
updateForecastCard stateRef cardData = do
  let dataLastUpdated = toDateTime <$> parse cardData.created  -- Maybe DT.DateTime
  let key = cardData.key
  let current = cardData.channel.item.condition

  card <- getOrCreateCard stateRef key
  find ".description" card >>= setText current.text
  find ".date" card >>= setText current.date
  --     card.querySelector('.current .icon').classList.add(app.getIconClass(current.code));
  find ".current .icon" card >>= setClass "rain" true

getOrCreateCard
  :: forall e
   . Ref AppState
  -> CardKey
  -> Eff (dom :: DOM, ref :: REF | e) JQuery
getOrCreateCard stateRef key = do
  AppState state <- readRef stateRef
  case M.lookup key state.visibleCards of
    Just wc ->
      pure wc
    Nothing -> do
      -- card doesn't exist - clone from template and store in state
      nc <- clone state.cardTemplate
      setClass "cardTemplate" false nc
      setAttr "hidden" false nc
      append nc state.container
      modifyRef stateRef $ addCardForKey key nc
      pure nc

-- Methods for dealing with the model

addCardForKey :: CardKey -> JQuery -> AppState -> AppState
addCardForKey key card (AppState state) =
  AppState state { visibleCards = M.insert key card state.visibleCards }

-- Fake data
initialWeatherForecast :: WeatherCard
initialWeatherForecast = {
  key: "2459115"
, label: "New York, NY"
, created: "2016-07-22T01:00:00Z"
, channel: {
    astronomy: {
      sunrise: "5:43 am"
    , sunset: "8:21 pm"
    }
  , item: {
      condition: {
        text: "Windy"
      , date: "Thu, 21 Jul 2016 09:00 PM EDT"
      , temp: 56
      , code: 24
      }
    , forecast: [
        {code: 44, high: 86, low: 70}
      , {code: 44, high: 94, low: 73}
      , {code: 4, high: 95, low: 78}
      , {code: 24, high: 75, low: 89}
      , {code: 24, high: 89, low: 77}
      , {code: 44, high: 92, low: 79}
      , {code: 44, high: 89, low: 77}
      ]
    }
  , atmosphere: {humidity: 56}
  , wind: {
      speed: 25
    , direction: 195
    }
  }
}


Clean up the debug output

Clean up the debug output

module Main (App(..), main) where

import Prelude
import Control.Apply
import Control.Bind
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Console
import DOM
import DOM.Event.EventTypes (change, click, keydown)
import DOM.Event.Types (Event())
import DOM.HTML (window)
import DOM.HTML.Types (windowToEventTarget, htmlElementToEventTarget, htmlElementToElement)
import DOM.Node.Document (createElement)
import DOM.Node.Element (setAttribute)
import DOM.Node.Node (appendChild, setTextContent, parentElement)
import DOM.Node.Types (Element(), Node(), elementToNode, elementToEventTarget)
import Data.Enum
import Data.Foldable
import Data.Int
import Data.List
import Data.Maybe
import Data.Nullable (toMaybe)
import Data.String.Regex (regex, parseFlags, replace)
import Data.Traversable
import qualified Data.StrMap as SM

import Analytics
import DOMHelper
import Isomer
import Levels
import Sortable
import Storage
import Transformer
import Types

-- | Type synonyms for different combinations of effects
type EffIsomer = forall eff. Eff (isomer :: ISOMER | eff) Unit
type EffDOM    = forall eff. Eff (dom :: DOM | eff) Unit
type App       = forall eff. Eff (dom :: DOM, console :: CONSOLE, isomer :: ISOMER, storage :: STORAGE | eff) Unit

-- | RGB codes for the abstract colors
cubeColor :: Cube -> IsomerColor
cubeColor Cyan   = colorFromRGB   0 160 176
cubeColor Brown  = colorFromRGB 106  74  60
cubeColor Red    = colorFromRGB 204  51  63
cubeColor Orange = colorFromRGB 235 104  65
cubeColor Yellow = colorFromRGB 237 201  81

-- | Spacing between two walls
spacing :: Number
spacing = 5.5

-- | Like traverse_, but the function also takes an index parameter
traverseWithIndex_ :: forall a b m. (Applicative m) => (Int -> a -> m b) -> (List a) -> m Unit
traverseWithIndex_ f xs = go xs 0
    where go Nil _         = return unit
          go (Cons x xs) i = f i x *> go xs (i + 1)

-- | Traverse a StrMap while performing monadic side effects
traverseWithKey_ :: forall a m. (Monad m) => (String -> a -> m Unit) -> SM.StrMap a -> m Unit
traverseWithKey_ f sm = SM.foldM (const f) unit sm

-- | Render a single stack of cubes
renderStack :: IsomerInstance -> Number -> Number -> Stack -> EffIsomer
renderStack isomer y x stack =
    traverseWithIndex_ (\z -> renderCube isomer x (-spacing * y) (toNumber z)) $ map cubeColor stack

-- | Render a wall (multiple stacks)
renderWall :: IsomerInstance -> Number -> Wall -> EffIsomer
renderWall isomer y Nil =
    -- Render a gray placeholder for the empty wall
    renderBlock isomer 1.0 (-spacing * y) 0.0 5.0 0.9 0.1 (colorFromRGB 100 100 100)
renderWall isomer y wall =
    traverseWithIndex_ (\x -> renderStack isomer y (toNumber (length wall - x))) (reverse wall)

-- | Render a series of walls
renderWalls :: IsomerInstance -> (List Wall) -> EffIsomer
renderWalls isomer walls = do
    setIsomerConfig isomer 40.0 40.0 400.0
    traverseWithIndex_ (\y -> renderWall isomer (toNumber y)) walls

-- | Render the target shape
renderTarget :: IsomerInstance -> Wall -> EffIsomer
renderTarget isomer target = do
    setIsomerConfig isomer 30.0 1280.0 550.0
    renderWall isomer 0.0 target

-- | Get program (list of transformer ids) of the active level
getCurrentIds :: GameState -> (List TransformerId)
getCurrentIds gs = case (SM.lookup gs.currentLevel gs.levelState) of
                       Just ids -> ids
                       Nothing -> Nil

-- | Render all UI components, DOM and canvas
render :: Boolean -> GameState -> App
render setupUI gs = do
    doc <- getDocument
    isomer <- getIsomerInstance "canvas"

    let level   = getLevel gs.currentLevel
        chapter = getChapter gs.currentLevel
        tids    = getCurrentIds gs

    -- Set up UI, only if new level is loaded
    when setupUI $ do
        Just ulAvailable <- getElementById' "available" doc
        Just ulProgram   <- getElementById' "program" doc

        setInnerHTML "" ulAvailable
        setInnerHTML "" ulProgram

        let unused       = foldl (flip SM.delete) chapter.transformers tids
            insert sm id = case (getTransformerRecord chapter id) of
                               (Just tr) -> SM.insert id tr sm
                               Nothing ->   sm
            active =       foldl insert SM.empty tids

        -- create li elements for transformers
        traverseWithKey_ (appendTransformerElement ulAvailable) unused
        traverseWithKey_ (appendTransformerElement ulProgram) active

        -- set up mouse event handlers
        let installClickHandler li = addEventListener' click (clickLi (htmlElementToElement li)) (htmlElementToEventTarget li)
        children' ulAvailable >>= traverse_ installClickHandler
        children' ulProgram   >>= traverse_ installClickHandler

        withElementById "levels" doc $ \selectLevel -> do
            setInnerHTML "" selectLevel
            traverse_ (appendLevelElement selectLevel gs.currentLevel) allLevelIds

    let transformers = mapMaybe (getTransformer chapter) tids
    let steps = allSteps transformers level.initial

    -- On-canvas rendering
    clearCanvas isomer
    renderWalls isomer steps
    renderTarget isomer level.target

    -- DOM 'rendering'
    let solved = maybe false (== (level.target)) (last steps)
        visibility = if solved then "visible" else "hidden"
        cssAction = if solved then classAdd "flash" else classRemove "flash"

    withElementById "message" doc (setStyleAttribute "visibility" visibility <<< unsafeElementToHTMLElement)
    withElementById "solved" doc cssAction

    let helpHTML = maybe "" (nameToHTML <<< replaceTransformers chapter) level.help
    withElementById "help" doc (setInnerHTML helpHTML)

    -- Debug output:
    let toArray = fromList :: forall a. List a -> Array a
        toArrays = toArray <<< map toArray
    log $ "Program: " ++ show (toArray tids)
    log $ "Target: " ++ show (toArrays level.target)
    log "Steps:"
    traverse_ (print <<< toArrays) steps
    log ""

-- | Replace all occurences of a pattern in a string with a replacement
replaceAll :: String -> String -> String -> String
replaceAll pattern replacement = replace (regex pattern flags) replacement
    where flags = parseFlags "g"

-- | Replace color placeholders in the transformer description by colored rectangular divs
replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show (toList $ Cyan `enumFromTo` Yellow))
        where replaceColor s c = replaceAll (pattern c) (replacement c) s
              pattern c = "{" ++ c ++ "}"
              replacement c = "

"

-- | Replace stack markers
replaceStacks :: String -> String
replaceStacks = replaceAll "\\[" """
""" <<<
                replaceAll "\\]" "
"

-- | Render a transformer name as HTML
nameToHTML :: String -> String
nameToHTML = replaceColors <<< replaceStacks

-- | Replace transformer names by boxes
replaceTransformers :: Chapter -> String -> String
replaceTransformers ch initial = SM.fold replaceT initial ch.transformers
    where replaceT text id tr = replaceAll (pattern id) (replacement tr) text
          pattern id = "`" ++ id ++ "`"
          replacement tr = "" ++ tr.name ++ ""

-- | Clear all functions for the current level
resetLevel = modifyGameStateAndRender true mod
    where mod gs = gs { levelState = SM.insert gs.currentLevel Nil gs.levelState }

-- | Go to the previous level
prevLevel = modifyGameStateAndRender true mod
    where mod gs   = gs { currentLevel = prev gs.currentLevel }
          prev cur = fromMaybe cur $ before cur allLevelIds
          before _ Nil                   = Nothing
          before _ (Cons _ Nil)          = Nothing
          before x (Cons b (Cons x' xs)) = if x == x'
                                           then Just b
                                           else before x (x':xs)

-- | Go to the next level
nextLevel = do
    mgs <- loadGameState
    let gs' = fromMaybe initialGS mgs
    analyticsLevelChanged (next gs'.currentLevel)

    modifyGameStateAndRender true mod
    where mod gs   = gs { currentLevel = next gs.currentLevel }
          next cur = fromMaybe cur $ head =<< (tail $ dropWhile (/= cur) allLevelIds)

-- | General key press handler
keyPress :: Event -> App
keyPress event = do
    doc <- getDocument
    let kev = unsafeEventToKeyboardEvent event
        code = keyCode kev
        ctrlPressed = ctrlKey kev

    when (not ctrlPressed) $
        case code of
             -- 'r': reset lists
             82 ->  resetLevel
             -- '<-', 'p': previous level
             37 -> prevLevel
             80 -> prevLevel
             -- '->', 'n': next level
             39 -> nextLevel
             78 -> nextLevel
             _ -> return unit

    return unit

-- | Click handler for the
 elements (transformers)
clickLi :: Element -> Event -> App
clickLi liEl event = do
    newId <- unsafeGetAttribute "id" liEl
    Just ul <- toMaybe <$> parentElement (elementToNode liEl)
    ulId <- unsafeGetAttribute "id" ul
    modifyGameStateAndRender true (modify ulId newId)

    where modify ulId clicked gs = let program = getCurrentIds gs
                                       program' =
                                           if ulId == "available"
                                           then program `snoc` clicked
                                           else filter (/= clicked) program
                          in gs { levelState = SM.insert gs.currentLevel program' gs.levelState }

-- | Add a li-element corresponding to the given Transformer
appendTransformerElement :: Element -> String -> TransformerRecord -> EffDOM
appendTransformerElement ul id t = do
    doc <- getDocument
    li <- createElement "li" doc
    setAttribute "id" id li
    setInnerHTML (nameToHTML t.name) li
    appendChild (elementToNode li) (elementToNode ul)
    return unit

-- | Add an option-element corresponding to the given Level
appendLevelElement :: Element -> LevelId -> LevelId -> EffDOM
appendLevelElement select currentId lid = do
    let chapter = getChapter lid
        level = getLevel lid
    doc <- getDocument
    option <- createElement "option" doc
    setAttribute "value" lid option
    when (currentId == lid) $
        setAttribute "selected" "selected" option
    setTextContent (levelTitle lid level) (elementToNode option)
    appendChild (elementToNode option) (elementToNode select)
    return unit

-- | Initial game state for first-time visitors
initialGS :: GameState
initialGS = { currentLevel: firstLevel, levelState: SM.empty }

-- | Load, modify and store the game state. Render the new state
modifyGameStateAndRender :: Boolean
                         -> (GameState -> GameState)
                         -> forall eff. Eff (dom :: DOM, console :: CONSOLE, isomer :: ISOMER, storage :: STORAGE | eff) Unit
modifyGameStateAndRender setupUI modifyGS = do
    -- Load old game state from local storage
    mgs <- loadGameState
    let gs = fromMaybe initialGS mgs

    -- Modify by supplied function
    let gs' = modifyGS gs

    -- Render the new state and save back to local storage
    render setupUI gs'
    saveGameState gs'

-- | Event handler for a level change
levelChangeHandler :: Element -> Event -> App
levelChangeHandler selectLevel _ = do
    levelId <- getSelectedValue selectLevel

    analyticsLevelChanged levelId

    modifyGameStateAndRender true $ \gs ->
        gs { currentLevel = levelId }

-- | Event handler for a 'reprogram' (new instruction, re-ordering, ..)
reprogramHandler :: App
reprogramHandler = do
    doc <- getDocument

    -- Retrieve current 'program'
    Just ulAvailable <- getElementById' "program" doc
    lis <- children' ulAvailable
    let getId = unsafeGetAttribute "id" <<< htmlElementToElement
    program <- toList <$> traverse getId lis

    modifyGameStateAndRender false $ \gs ->
        gs { levelState = SM.insert gs.currentLevel program gs.levelState }

main :: App
main = do
    doc <- getDocument

    -- install sortable
    Just ulAvailable <- getElementById' "available" doc
    Just ulProgram   <- getElementById' "program" doc
    installSortable ulAvailable (return unit)
    installSortable ulProgram reprogramHandler

    -- set up keyboard event handlers
    win <- windowToEventTarget <$> window
    addEventListener' keydown keyPress win

    -- set up 'change' handler for the level selector
    withElementById "levels" doc $ \selectLevel ->
        addEventListener' change (levelChangeHandler selectLevel) (elementToEventTarget selectLevel)

    -- Click handlers for buttons
    withElementById "reset" doc $ \button ->
        addEventListener' click (const resetLevel) (elementToEventTarget button)

    withElementById "nextlevel" doc $ \button ->
        addEventListener' click (const nextLevel) (elementToEventTarget button)

    -- load game state (or set initial one)
    gs <- fromMaybe initialGS <$> loadGameState
    saveGameState gs

    -- render initial state
    render true gs

module Main (App(..), main) where

import Prelude
import Control.Apply
import Control.Bind
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Console
import DOM
import DOM.Event.EventTypes (change, click, keydown)
import DOM.Event.Types (Event())
import DOM.HTML (window)
import DOM.HTML.Types (windowToEventTarget, htmlElementToEventTarget, htmlElementToElement)
import DOM.Node.Document (createElement)
import DOM.Node.Element (setAttribute)
import DOM.Node.Node (appendChild, setTextContent, parentElement)
import DOM.Node.Types (Element(), Node(), elementToNode, elementToEventTarget)
import Data.Enum
import Data.Foldable
import Data.Int
import Data.List
import Data.Maybe
import Data.Nullable (toMaybe)
import Data.String.Regex (regex, parseFlags, replace)
import Data.Traversable
import qualified Data.StrMap as SM

import Analytics
import DOMHelper
import Isomer
import Levels
import Sortable
import Storage
import Transformer
import Types

-- | Type synonyms for different combinations of effects
type EffIsomer = forall eff. Eff (isomer :: ISOMER | eff) Unit
type EffDOM    = forall eff. Eff (dom :: DOM | eff) Unit
type App       = forall eff. Eff (dom :: DOM, console :: CONSOLE, isomer :: ISOMER, storage :: STORAGE | eff) Unit

-- | RGB codes for the abstract colors
cubeColor :: Cube -> IsomerColor
cubeColor Cyan   = colorFromRGB   0 160 176
cubeColor Brown  = colorFromRGB 106  74  60
cubeColor Red    = colorFromRGB 204  51  63
cubeColor Orange = colorFromRGB 235 104  65
cubeColor Yellow = colorFromRGB 237 201  81

-- | Spacing between two walls
spacing :: Number
spacing = 5.5

-- | Like traverse_, but the function also takes an index parameter
traverseWithIndex_ :: forall a b m. (Applicative m) => (Int -> a -> m b) -> (List a) -> m Unit
traverseWithIndex_ f xs = go xs 0
    where go Nil _         = return unit
          go (Cons x xs) i = f i x *> go xs (i + 1)

-- | Traverse a StrMap while performing monadic side effects
traverseWithKey_ :: forall a m. (Monad m) => (String -> a -> m Unit) -> SM.StrMap a -> m Unit
traverseWithKey_ f sm = SM.foldM (const f) unit sm

-- | Render a single stack of cubes
renderStack :: IsomerInstance -> Number -> Number -> Stack -> EffIsomer
renderStack isomer y x stack =
    traverseWithIndex_ (\z -> renderCube isomer x (-spacing * y) (toNumber z)) $ map cubeColor stack

-- | Render a wall (multiple stacks)
renderWall :: IsomerInstance -> Number -> Wall -> EffIsomer
renderWall isomer y Nil =
    -- Render a gray placeholder for the empty wall
    renderBlock isomer 1.0 (-spacing * y) 0.0 5.0 0.9 0.1 (colorFromRGB 100 100 100)
renderWall isomer y wall =
    traverseWithIndex_ (\x -> renderStack isomer y (toNumber (length wall - x))) (reverse wall)

-- | Render a series of walls
renderWalls :: IsomerInstance -> (List Wall) -> EffIsomer
renderWalls isomer walls = do
    setIsomerConfig isomer 40.0 40.0 400.0
    traverseWithIndex_ (\y -> renderWall isomer (toNumber y)) walls

-- | Render the target shape
renderTarget :: IsomerInstance -> Wall -> EffIsomer
renderTarget isomer target = do
    setIsomerConfig isomer 30.0 1280.0 550.0
    renderWall isomer 0.0 target

-- | Get program (list of transformer ids) of the active level
getCurrentIds :: GameState -> (List TransformerId)
getCurrentIds gs = case (SM.lookup gs.currentLevel gs.levelState) of
                       Just ids -> ids
                       Nothing -> Nil

-- | Render all UI components, DOM and canvas
render :: Boolean -> GameState -> App
render setupUI gs = do
    doc <- getDocument
    isomer <- getIsomerInstance "canvas"

    let level   = getLevel gs.currentLevel
        chapter = getChapter gs.currentLevel
        tids    = getCurrentIds gs

    -- Set up UI, only if new level is loaded
    when setupUI $ do
        Just ulAvailable <- getElementById' "available" doc
        Just ulProgram   <- getElementById' "program" doc

        setInnerHTML "" ulAvailable
        setInnerHTML "" ulProgram

        let unused       = foldl (flip SM.delete) chapter.transformers tids
            insert sm id = case (getTransformerRecord chapter id) of
                               (Just tr) -> SM.insert id tr sm
                               Nothing ->   sm
            active =       foldl insert SM.empty tids

        -- create li elements for transformers
        traverseWithKey_ (appendTransformerElement ulAvailable) unused
        traverseWithKey_ (appendTransformerElement ulProgram) active

        -- set up mouse event handlers
        let installClickHandler li = addEventListener' click (clickLi (htmlElementToElement li)) (htmlElementToEventTarget li)
        children' ulAvailable >>= traverse_ installClickHandler
        children' ulProgram   >>= traverse_ installClickHandler

        withElementById "levels" doc $ \selectLevel -> do
            setInnerHTML "" selectLevel
            traverse_ (appendLevelElement selectLevel gs.currentLevel) allLevelIds

    let transformers = mapMaybe (getTransformer chapter) tids
    let steps = allSteps transformers level.initial

    -- On-canvas rendering
    clearCanvas isomer
    renderWalls isomer steps
    renderTarget isomer level.target

    -- DOM 'rendering'
    let solved = maybe false (== (level.target)) (last steps)
        visibility = if solved then "visible" else "hidden"
        cssAction = if solved then classAdd "flash" else classRemove "flash"

    withElementById "message" doc (setStyleAttribute "visibility" visibility <<< unsafeElementToHTMLElement)
    withElementById "solved" doc cssAction

    let helpHTML = maybe "" (nameToHTML <<< replaceTransformers chapter) level.help
    withElementById "help" doc (setInnerHTML helpHTML)

    -- DEBUG:
    log $ "Program: " ++ show tids
    log $ "Initial: " ++ show level.initial
    log "Steps:"
    traverse_ print steps
    log "---"
    log $ "Target: " ++ show level.target
    log ""

-- | Replace all occurences of a pattern in a string with a replacement
replaceAll :: String -> String -> String -> String
replaceAll pattern replacement = replace (regex pattern flags) replacement
    where flags = parseFlags "g"

-- | Replace color placeholders in the transformer description by colored rectangular divs
replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show (toList $ Cyan `enumFromTo` Yellow))
        where replaceColor s c = replaceAll (pattern c) (replacement c) s
              pattern c = "{" ++ c ++ "}"
              replacement c = "

"

-- | Replace stack markers
replaceStacks :: String -> String
replaceStacks = replaceAll "\\[" """
""" <<<
                replaceAll "\\]" "
"

-- | Render a transformer name as HTML
nameToHTML :: String -> String
nameToHTML = replaceColors <<< replaceStacks

-- | Replace transformer names by boxes
replaceTransformers :: Chapter -> String -> String
replaceTransformers ch initial = SM.fold replaceT initial ch.transformers
    where replaceT text id tr = replaceAll (pattern id) (replacement tr) text
          pattern id = "`" ++ id ++ "`"
          replacement tr = "" ++ tr.name ++ ""

-- | Clear all functions for the current level
resetLevel = modifyGameStateAndRender true mod
    where mod gs = gs { levelState = SM.insert gs.currentLevel Nil gs.levelState }

-- | Go to the previous level
prevLevel = modifyGameStateAndRender true mod
    where mod gs   = gs { currentLevel = prev gs.currentLevel }
          prev cur = fromMaybe cur $ before cur allLevelIds
          before _ Nil                   = Nothing
          before _ (Cons _ Nil)          = Nothing
          before x (Cons b (Cons x' xs)) = if x == x'
                                           then Just b
                                           else before x (x':xs)

-- | Go to the next level
nextLevel = do
    mgs <- loadGameState
    let gs' = fromMaybe initialGS mgs
    analyticsLevelChanged (next gs'.currentLevel)

    modifyGameStateAndRender true mod
    where mod gs   = gs { currentLevel = next gs.currentLevel }
          next cur = fromMaybe cur $ head =<< (tail $ dropWhile (/= cur) allLevelIds)

-- | General key press handler
keyPress :: Event -> App
keyPress event = do
    doc <- getDocument
    let kev = unsafeEventToKeyboardEvent event
        code = keyCode kev
        ctrlPressed = ctrlKey kev

    when (not ctrlPressed) $
        case code of
             -- 'r': reset lists
             82 ->  resetLevel
             -- '<-', 'p': previous level
             37 -> prevLevel
             80 -> prevLevel
             -- '->', 'n': next level
             39 -> nextLevel
             78 -> nextLevel
             _ -> return unit

    return unit

-- | Click handler for the
 elements (transformers)
clickLi :: Element -> Event -> App
clickLi liEl event = do
    newId <- unsafeGetAttribute "id" liEl
    Just ul <- toMaybe <$> parentElement (elementToNode liEl)
    ulId <- unsafeGetAttribute "id" ul
    modifyGameStateAndRender true (modify ulId newId)

    where modify ulId clicked gs = let program = getCurrentIds gs
                                       program' =
                                           if ulId == "available"
                                           then program `snoc` clicked
                                           else filter (/= clicked) program
                          in gs { levelState = SM.insert gs.currentLevel program' gs.levelState }

-- | Add a li-element corresponding to the given Transformer
appendTransformerElement :: Element -> String -> TransformerRecord -> EffDOM
appendTransformerElement ul id t = do
    doc <- getDocument
    li <- createElement "li" doc
    setAttribute "id" id li
    setInnerHTML (nameToHTML t.name) li
    appendChild (elementToNode li) (elementToNode ul)
    return unit

-- | Add an option-element corresponding to the given Level
appendLevelElement :: Element -> LevelId -> LevelId -> EffDOM
appendLevelElement select currentId lid = do
    let chapter = getChapter lid
        level = getLevel lid
    doc <- getDocument
    option <- createElement "option" doc
    setAttribute "value" lid option
    when (currentId == lid) $
        setAttribute "selected" "selected" option
    setTextContent (levelTitle lid level) (elementToNode option)
    appendChild (elementToNode option) (elementToNode select)
    return unit

-- | Initial game state for first-time visitors
initialGS :: GameState
initialGS = { currentLevel: firstLevel, levelState: SM.empty }

-- | Load, modify and store the game state. Render the new state
modifyGameStateAndRender :: Boolean
                         -> (GameState -> GameState)
                         -> forall eff. Eff (dom :: DOM, console :: CONSOLE, isomer :: ISOMER, storage :: STORAGE | eff) Unit
modifyGameStateAndRender setupUI modifyGS = do
    -- Load old game state from local storage
    mgs <- loadGameState
    let gs = fromMaybe initialGS mgs

    -- Modify by supplied function
    let gs' = modifyGS gs

    -- Render the new state and save back to local storage
    render setupUI gs'
    saveGameState gs'

-- | Event handler for a level change
levelChangeHandler :: Element -> Event -> App
levelChangeHandler selectLevel _ = do
    levelId <- getSelectedValue selectLevel

    analyticsLevelChanged levelId

    modifyGameStateAndRender true $ \gs ->
        gs { currentLevel = levelId }

-- | Event handler for a 'reprogram' (new instruction, re-ordering, ..)
reprogramHandler :: App
reprogramHandler = do
    doc <- getDocument

    -- Retrieve current 'program'
    Just ulAvailable <- getElementById' "program" doc
    lis <- children' ulAvailable
    let getId = unsafeGetAttribute "id" <<< htmlElementToElement
    program <- toList <$> traverse getId lis

    modifyGameStateAndRender false $ \gs ->
        gs { levelState = SM.insert gs.currentLevel program gs.levelState }

main :: App
main = do
    doc <- getDocument

    -- install sortable
    Just ulAvailable <- getElementById' "available" doc
    Just ulProgram   <- getElementById' "program" doc
    installSortable ulAvailable (return unit)
    installSortable ulProgram reprogramHandler

    -- set up keyboard event handlers
    win <- windowToEventTarget <$> window
    addEventListener' keydown keyPress win

    -- set up 'change' handler for the level selector
    withElementById "levels" doc $ \selectLevel ->
        addEventListener' change (levelChangeHandler selectLevel) (elementToEventTarget selectLevel)

    -- Click handlers for buttons
    withElementById "reset" doc $ \button ->
        addEventListener' click (const resetLevel) (elementToEventTarget button)

    withElementById "nextlevel" doc $ \button ->
        addEventListener' click (const nextLevel) (elementToEventTarget button)

    -- load game state (or set initial one)
    gs <- fromMaybe initialGS <$> loadGameState
    saveGameState gs

    -- render initial state
    render true gs


Fix #347 (require termination in SQL num parser)

Adding an `eof` at the end of the parser causes `isSQLnum` to fail
properly in case the input is merely plain text that begins with a
number.

module Input.Notebook
  ( CellResultContent(..)
  , Input(..)
  , updateState
  , cellContent
  ) where

import Prelude
import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Bind (join)
import Data.Array (filter, modifyAt, (!!), elemIndex, (\\))
import Data.Date (Date(), toEpochMilliseconds)
import Data.Either (Either(..), isRight, either)
import Data.Foldable (intercalate, foldl, elem)
import Data.Function (on)

import Data.Maybe (Maybe(..), fromMaybe, maybe, isJust)
import Data.String (indexOf)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)
import Model.Notebook
import Model.Resource (Resource())
import Model.Notebook.Cell
import Model.Notebook.Cell.FileInput (_showFiles)
import Model.Notebook.Domain (_cells, addCell, insertCell, _dependencies, Notebook(), trash, ancestors)
import Model.Notebook.Port (Port(..), VarMapValue(), _PortResource, _VarMap)
import Optic.Core
import Optic.Fold ((^?))
import Optic.Setter (mapped)
import Text.Markdown.SlamDown (SlamDown(..), Block(..), Expr(..), Inline(..), FormField(..), TextBoxType(..), everything)
import Text.Markdown.SlamDown.Html (FormFieldValue(..), SlamDownEvent(..), SlamDownState(..), applySlamDownEvent, initSlamDownState)
import Text.Markdown.SlamDown.Parser (parseMd)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.String.Regex as Rx
import qualified Data.StrMap as SM
import qualified ECharts.Options as EC
import qualified Model.Notebook.Cell.JTableContent as JTC
import qualified Model.Notebook.Cell.Markdown as Ma
import qualified Text.Parsing.StringParser as SP
import qualified Text.Parsing.StringParser.Combinators as SP
import qualified Text.Parsing.StringParser.String as SP
import Model.Path (FilePath(), AnyPath())

data CellResultContent
  = AceContent String
  | JTableContent JTC.JTableContent
  | MarkdownContent

data Input
  = WithState (State -> State)
  | Dropdown Int
  | CloseDropdowns
  | AddCell CellContent
  | TrashCell CellId

  | RequestCellContent Cell
  | ReceiveCellContent Cell
  | ViewCellContent Cell
  | RefreshCell Cell

  | StartRunCell CellId Date
  | StopCell CellId
  | CellResult CellId Date (Either (NEL.NonEmpty FailureMessage) CellResultContent)

  | UpdateCell CellId (Cell -> Cell)
  | CellSlamDownEvent CellId SlamDownEvent
  | InsertCell Cell CellContent
  | SetEChartsOption String EC.Option
  | ResizeECharts String

  | UpdatedOutput CellId Port
  | ForceSave

updateState :: State -> Input -> State

updateState state (WithState f) =
  f state

updateState state (UpdateCell cellId fn) =
  state # _notebook.._cells..mapped %~ onCell cellId fn

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # _dropdowns %~
  ((fromMaybe (state ^. _dropdowns)) <<<
   (modifyAt i _{visible = visSet}) <<<
   (_{visible = false} <$>))

updateState state CloseDropdowns =
  state # (_dropdowns %~ (_{visible = false} <$>))
       .. (_notebook .. _cells .. mapped %~ _content .. _FileInput .. _showFiles .~ false)

updateState state (AddCell content) =
  state # _notebook %~ (fst <<< addCell content)

updateState state (InsertCell parent content) =
  state # _notebook %~ (fst <<< insertCell parent content)

updateState state (TrashCell cellId) =
  state # _notebook.._cells %~ filter (not <<< depends (state ^._notebook) cellId)
        # _notebook.._cells %~ filter (not <<< isCell cellId)
        # _notebook.._dependencies %~ trash cellId

updateState state (CellResult cellId date content) =
  let finished d = RunFinished $ on (-) toEpochMilliseconds date d

      fromState (RunningSince d) = cellContent content <<< setRunState (finished d)
      fromState a = setRunState a -- In bad state or cancelled. Leave content.

      f cell = fromState (cell ^. _runState) cell # (_hasRun .~ true)

  in state # _notebook.._cells..mapped %~ onCell cellId f

updateState state (ReceiveCellContent cell) =
  state # _notebook.._cells..mapped %~ onCell (cell ^. _cellId) (const $ setSlamDownStatus cell)

updateState state (StartRunCell cellId date) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState (RunningSince date) <<< (_expandedStatus .~ false))

updateState state (StopCell cellId) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState RunInitial)

updateState state (CellSlamDownEvent cellId event) =
  state # _notebook.._cells..mapped %~ onCell cellId (slamDownOutput <<< runSlamDownEvent event)
        # _notebook.._cells %~ syncParents
        # _requesting <>~ [cellId]

updateState state (UpdatedOutput cid newInput) =
  state # _notebook.._cells..mapped %~ changed
  where
  changed cell = if not $ elem (cell ^. _cellId) depIds
                 then cell
                 else cell # _input .~ newInput
  depIds =
    fst <$>
    L.filter (\x -> snd x == cid) (M.toList (state ^. _notebook .. _dependencies))

updateState state (RefreshCell cell) =
  let requesting = state ^. _requesting
      cid = cell ^. _cellId
  in if elem cid requesting
     then state
     else state # _refreshing <>~ [cell ^. _cellId]

updateState state i = state

_SlamDownState :: LensP SlamDownState (SM.StrMap FormFieldValue)
_SlamDownState = lens (\(SlamDownState m) -> m) (const SlamDownState)

-- TODO: We need a much better solution to this.
syncParents :: Array Cell -> Array Cell
syncParents cells = updateCell <$> cells
  where updateCell cell = fromMaybe cell $ fromParent cell
        fromParent cell = do
          pid <- cell ^. _parent
          parent <- M.lookup pid m
          return (cell # _input .~ (parent ^. _output))
        m = M.fromList <<< L.toList $ pair <$> cells
        pair cell = Tuple (cell ^. _cellId) cell

slamDownOutput :: Cell -> Cell
slamDownOutput cell =
  cell # _output .. _VarMap  %~ modifyVarMap
  where
    modifyVarMap m = foldl (\m (Tuple key val) -> SM.insert key val m) m tplLst
    tplLst = maybe L.Nil SM.toList ((fromFormValue <$>) <$> state)
    fromFormValue (SingleValue PlainText s) = quoteString s
    fromFormValue (SingleValue Date s) = "DATE '" ++ s ++ "'"
    fromFormValue (SingleValue Time s) = "TIME '" ++ s ++ "'"
    fromFormValue (SingleValue DateTime s) = "TIMESTAMP '" ++ processTimestamp s ++ "'"
    fromFormValue (MultipleValues s) = "[" <> intercalate ", " (quoteString <$> S.toList s) <> "]" -- TODO: is this anything like we want for multi-values?
    state :: Maybe (SM.StrMap FormFieldValue)
    state = cell ^? _content.._Markdown..Ma._state.._SlamDownState
    processTimestamp s = s ++ ":00Z"
    quoteString s | isSQLNum s = s
                  | otherwise = "'" ++ Rx.replace rxQuot "''" s ++ "'"
    rxQuot = Rx.regex "'" Rx.noFlags { global = true }
    rxT = Rx.regex "T" Rx.noFlags
    isSQLNum s = isRight $ flip SP.runParser s $ do
      SP.many1 SP.anyDigit
      SP.optional $ SP.string "." *> SP.many SP.anyDigit
      SP.optional $ (SP.string "e" <|> SP.string "E")
                 *> (SP.string "-" <|> SP.string "+")
                 *> SP.many SP.anyDigit
      SP.eof

slamDownFields :: SlamDown -> Array (Tuple String FormField)
slamDownFields = everything (const []) go
  where
  go (FormField s _ ff) = [Tuple s ff]
  go _ = []

setSlamDownStatus :: Cell -> Cell
setSlamDownStatus cell =
  let input' = cell ^? _content.._Markdown..Ma._input
      message = ("Exported fields: " <>) <<< intercalate ", " <<< (fst <$>)
      initial md =
        let fields = slamDownFields md
            updateState (SlamDownState s) = case initSlamDownState md of
              SlamDownState s' ->
                let removedKeys = SM.keys s \\ SM.keys s'
                    mergedSM = s `SM.union` s'
                    prunedSM = foldl (\f k -> SM.delete k f) mergedSM removedKeys
                in SlamDownState prunedSM
        in slamDownOutput (cell # _message .~ message fields
                                # _content .. _Markdown .. Ma._state %~ updateState)
  in maybe cell (initial <<< parseMd) input'

runSlamDownEvent :: SlamDownEvent -> Cell -> Cell
runSlamDownEvent event cell =
  cell # _content.._Markdown..Ma._state %~ flip applySlamDownEvent event

cellContent :: Either (NEL.NonEmpty FailureMessage) CellResultContent -> Cell -> Cell
cellContent = either (setFailures <<< NEL.toArray) success
  where
  success :: CellResultContent -> Cell -> Cell
  success (AceContent content) =
    setFailures [ ]
    <<< (_content.._AceContent .~ content)
  success (JTableContent content) =
    setFailures [ ]
    <<< (_content.._JTableContent .~ content)
  success MarkdownContent = setFailures [ ]

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

setFailures :: Array FailureMessage -> Cell -> Cell
setFailures fs (Cell o) = Cell $ o { failures = fs }

setRunState :: RunState -> Cell -> Cell
setRunState = modifyRunState <<< const

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'

depends :: Notebook -> CellId -> Cell -> Boolean
depends notebook cellId cell =
  isJust $ elemIndex cellId (ancestors (cell ^._cellId) (notebook ^._dependencies))

module Input.Notebook
  ( CellResultContent(..)
  , Input(..)
  , updateState
  , cellContent
  ) where

import Prelude
import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Bind (join)
import Data.Array (filter, modifyAt, (!!), elemIndex, (\\))
import Data.Date (Date(), toEpochMilliseconds)
import Data.Either (Either(..), isRight, either)
import Data.Foldable (intercalate, foldl, elem)
import Data.Function (on)

import Data.Maybe (Maybe(..), fromMaybe, maybe, isJust)
import Data.String (indexOf)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)
import Model.Notebook
import Model.Resource (Resource())
import Model.Notebook.Cell
import Model.Notebook.Cell.FileInput (_showFiles)
import Model.Notebook.Domain (_cells, addCell, insertCell, _dependencies, Notebook(), trash, ancestors)
import Model.Notebook.Port (Port(..), VarMapValue(), _PortResource, _VarMap)
import Optic.Core
import Optic.Fold ((^?))
import Optic.Setter (mapped)
import Text.Markdown.SlamDown (SlamDown(..), Block(..), Expr(..), Inline(..), FormField(..), TextBoxType(..), everything)
import Text.Markdown.SlamDown.Html (FormFieldValue(..), SlamDownEvent(..), SlamDownState(..), applySlamDownEvent, initSlamDownState)
import Text.Markdown.SlamDown.Parser (parseMd)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.String.Regex as Rx
import qualified Data.StrMap as SM
import qualified ECharts.Options as EC
import qualified Model.Notebook.Cell.JTableContent as JTC
import qualified Model.Notebook.Cell.Markdown as Ma
import qualified Text.Parsing.StringParser as SP
import qualified Text.Parsing.StringParser.Combinators as SP
import qualified Text.Parsing.StringParser.String as SP
import Model.Path (FilePath(), AnyPath())

data CellResultContent
  = AceContent String
  | JTableContent JTC.JTableContent
  | MarkdownContent

data Input
  = WithState (State -> State)
  | Dropdown Int
  | CloseDropdowns
  | AddCell CellContent
  | TrashCell CellId

  | RequestCellContent Cell
  | ReceiveCellContent Cell
  | ViewCellContent Cell
  | RefreshCell Cell

  | StartRunCell CellId Date
  | StopCell CellId
  | CellResult CellId Date (Either (NEL.NonEmpty FailureMessage) CellResultContent)

  | UpdateCell CellId (Cell -> Cell)
  | CellSlamDownEvent CellId SlamDownEvent
  | InsertCell Cell CellContent
  | SetEChartsOption String EC.Option
  | ResizeECharts String

  | UpdatedOutput CellId Port
  | ForceSave

updateState :: State -> Input -> State

updateState state (WithState f) =
  f state

updateState state (UpdateCell cellId fn) =
  state # _notebook.._cells..mapped %~ onCell cellId fn

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # _dropdowns %~
  ((fromMaybe (state ^. _dropdowns)) <<<
   (modifyAt i _{visible = visSet}) <<<
   (_{visible = false} <$>))

updateState state CloseDropdowns =
  state # (_dropdowns %~ (_{visible = false} <$>))
       .. (_notebook .. _cells .. mapped %~ _content .. _FileInput .. _showFiles .~ false)

updateState state (AddCell content) =
  state # _notebook %~ (fst <<< addCell content)

updateState state (InsertCell parent content) =
  state # _notebook %~ (fst <<< insertCell parent content)

updateState state (TrashCell cellId) =
  state # _notebook.._cells %~ filter (not <<< depends (state ^._notebook) cellId)
        # _notebook.._cells %~ filter (not <<< isCell cellId)
        # _notebook.._dependencies %~ trash cellId

updateState state (CellResult cellId date content) =
  let finished d = RunFinished $ on (-) toEpochMilliseconds date d

      fromState (RunningSince d) = cellContent content <<< setRunState (finished d)
      fromState a = setRunState a -- In bad state or cancelled. Leave content.

      f cell = fromState (cell ^. _runState) cell # (_hasRun .~ true)

  in state # _notebook.._cells..mapped %~ onCell cellId f

updateState state (ReceiveCellContent cell) =
  state # _notebook.._cells..mapped %~ onCell (cell ^. _cellId) (const $ setSlamDownStatus cell)

updateState state (StartRunCell cellId date) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState (RunningSince date) <<< (_expandedStatus .~ false))

updateState state (StopCell cellId) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState RunInitial)

updateState state (CellSlamDownEvent cellId event) =
  state # _notebook.._cells..mapped %~ onCell cellId (slamDownOutput <<< runSlamDownEvent event)
        # _notebook.._cells %~ syncParents
        # _requesting <>~ [cellId]

updateState state (UpdatedOutput cid newInput) =
  state # _notebook.._cells..mapped %~ changed
  where
  changed cell = if not $ elem (cell ^. _cellId) depIds
                 then cell
                 else cell # _input .~ newInput
  depIds =
    fst <$>
    L.filter (\x -> snd x == cid) (M.toList (state ^. _notebook .. _dependencies))

updateState state (RefreshCell cell) =
  let requesting = state ^. _requesting
      cid = cell ^. _cellId
  in if elem cid requesting
     then state
     else state # _refreshing <>~ [cell ^. _cellId]

updateState state i = state

_SlamDownState :: LensP SlamDownState (SM.StrMap FormFieldValue)
_SlamDownState = lens (\(SlamDownState m) -> m) (const SlamDownState)

-- TODO: We need a much better solution to this.
syncParents :: Array Cell -> Array Cell
syncParents cells = updateCell <$> cells
  where updateCell cell = fromMaybe cell $ fromParent cell
        fromParent cell = do
          pid <- cell ^. _parent
          parent <- M.lookup pid m
          return (cell # _input .~ (parent ^. _output))
        m = M.fromList <<< L.toList $ pair <$> cells
        pair cell = Tuple (cell ^. _cellId) cell

slamDownOutput :: Cell -> Cell
slamDownOutput cell =
  cell # _output .. _VarMap  %~ modifyVarMap
  where
    modifyVarMap m = foldl (\m (Tuple key val) -> SM.insert key val m) m tplLst
    tplLst = maybe L.Nil SM.toList ((fromFormValue <$>) <$> state)
    fromFormValue (SingleValue PlainText s) = quoteString s
    fromFormValue (SingleValue Date s) = "DATE '" ++ s ++ "'"
    fromFormValue (SingleValue Time s) = "TIME '" ++ s ++ "'"
    fromFormValue (SingleValue DateTime s) = "TIMESTAMP '" ++ processTimestamp s ++ "'"
    fromFormValue (MultipleValues s) = "[" <> intercalate ", " (quoteString <$> S.toList s) <> "]" -- TODO: is this anything like we want for multi-values?
    state :: Maybe (SM.StrMap FormFieldValue)
    state = cell ^? _content.._Markdown..Ma._state.._SlamDownState
    processTimestamp s = s ++ ":00Z"
    quoteString s | isSQLNum s = s
                  | otherwise = "'" ++ Rx.replace rxQuot "''" s ++ "'"
    rxQuot = Rx.regex "'" Rx.noFlags { global = true }
    rxT = Rx.regex "T" Rx.noFlags
    isSQLNum s = isRight $ flip SP.runParser s $ do
      SP.many1 SP.anyDigit
      SP.optional $ SP.string "." *> SP.many SP.anyDigit
      SP.optional $ (SP.string "e" <|> SP.string "E")
                 *> (SP.string "-" <|> SP.string "+")
                 *> SP.many SP.anyDigit

slamDownFields :: SlamDown -> Array (Tuple String FormField)
slamDownFields = everything (const []) go
  where
  go (FormField s _ ff) = [Tuple s ff]
  go _ = []

setSlamDownStatus :: Cell -> Cell
setSlamDownStatus cell =
  let input' = cell ^? _content.._Markdown..Ma._input
      message = ("Exported fields: " <>) <<< intercalate ", " <<< (fst <$>)
      initial md =
        let fields = slamDownFields md
            updateState (SlamDownState s) = case initSlamDownState md of
              SlamDownState s' ->
                let removedKeys = SM.keys s \\ SM.keys s'
                    mergedSM = s `SM.union` s'
                    prunedSM = foldl (\f k -> SM.delete k f) mergedSM removedKeys
                in SlamDownState prunedSM
        in slamDownOutput (cell # _message .~ message fields
                                # _content .. _Markdown .. Ma._state %~ updateState)
  in maybe cell (initial <<< parseMd) input'

runSlamDownEvent :: SlamDownEvent -> Cell -> Cell
runSlamDownEvent event cell =
  cell # _content.._Markdown..Ma._state %~ flip applySlamDownEvent event

cellContent :: Either (NEL.NonEmpty FailureMessage) CellResultContent -> Cell -> Cell
cellContent = either (setFailures <<< NEL.toArray) success
  where
  success :: CellResultContent -> Cell -> Cell
  success (AceContent content) =
    setFailures [ ]
    <<< (_content.._AceContent .~ content)
  success (JTableContent content) =
    setFailures [ ]
    <<< (_content.._JTableContent .~ content)
  success MarkdownContent = setFailures [ ]

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

setFailures :: Array FailureMessage -> Cell -> Cell
setFailures fs (Cell o) = Cell $ o { failures = fs }

setRunState :: RunState -> Cell -> Cell
setRunState = modifyRunState <<< const

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'

depends :: Notebook -> CellId -> Cell -> Boolean
depends notebook cellId cell =
  isJust $ elemIndex cellId (ancestors (cell ^._cellId) (notebook ^._dependencies))


preliminaries of different screens

preliminaries of different screens

module Main where

import Prelude

import Control.Monad.Eff (Eff())

import Data.Maybe.Unsafe (fromJust)
import Data.Nullable (toMaybe)
import Data.List (List(..), (:))

import Signal (Signal(), constant, foldp, runSignal, sampleOn)
import Signal.Time (every, second)
import Signal.Channel (Chan(), Channel(), channel, send, subscribe)

import DOM (DOM())
import DOM.HTML (window)
import DOM.HTML.Document (body)
import DOM.HTML.Types (htmlElementToElement)
import DOM.HTML.Window (document)

import React
import React.DOM as D
import React.DOM.Props as P

type State a = { clicks :: Number
               , cps :: Number
               , clickBurst :: Number
               , upgradesBought :: List Upgrade
               , screen :: Screen
               | a }
type GameState = State ()
type Environment = State ( channel :: Channel Action )
type Component = Environment -> ReactElement

mkEnv :: Channel Action -> GameState -> Environment
mkEnv channel state = { clicks: state.clicks
                      , channel: channel
                      , clickBurst: state.clickBurst
                      , upgradesBought: state.upgradesBought
                      , screen: state.screen
                      , cps: state.cps }

initialState :: GameState
initialState = { clicks: 0.0
               , cps: 0.0
               , upgradesBought: Nil
               , screen: Game
               , clickBurst: 1.0 }

data Action = Click
            | AutoClick
            | Buy Upgrade
            | Switch Screen
            | Reset

data Upgrade = CPS Number
             | Burst Number

data Screen = Game
            | Settings
            | SaveLoad

instance showUpgrade :: Show Upgrade where
  show (CPS n) = "buy CPS upgrade +" ++ show n
  show (Burst n) = "buy click upgrade +" ++ show n

genericButtonWithText :: Action -> String -> Component
genericButtonWithText act str env =
  D.button [P.onClick \ _ -> send env.channel act] [D.text str]

foldComponent :: Array Component -> Component
foldComponent arr = \ env -> D.div' $ arr <*> [env]

clickButton :: Component
clickButton = genericButtonWithText Click "click me!"

resetButton :: Component
resetButton = genericButtonWithText Reset "reset"

buyButton :: Component
buyButton = foldComponent [upgrade (CPS 1.0), upgrade (Burst 1.0)]

upgrade :: Upgrade -> Component
upgrade up = genericButtonWithText (Buy up) (show up)

controls :: Component
controls env = D.div' $ flip apply [env] [clickButton, resetButton, buyButton]

currentClicks :: Component
currentClicks env = D.text (show env.clicks)

view :: Component
view env = case env.screen of
                Game -> showGame env
                Settings -> showSettings env
                SaveLoad -> showSaveLoad env

showGame :: Component
showGame = foldComponent [changeView, controls, currentClicks]

showSettings :: Component
showSettings = foldComponent [changeView, settingsText]
  where
    settingsText _ = D.text "Settings"

showSaveLoad :: Component
showSaveLoad = foldComponent [changeView, saveLoadText]
  where
    saveLoadText _ = D.text "Save/Load game"

changeView :: Component
changeView env = D.div' [ genericButtonWithText (Switch Game) "Game" env
                        , genericButtonWithText (Switch Settings) "Settings" env
                        , genericButtonWithText (Switch SaveLoad) "Save/Load" env ]

component :: Environment -> ReactClass Unit
component env = createClass (spec unit \ _ -> pure (view env))

step :: Action -> GameState -> GameState
step Click state = state { clicks = state.clicks + state.clickBurst }
step AutoClick state = state { clicks = state.clicks + state.cps }
step (Buy (CPS n)) state =
  state { cps = state.cps + n
        , upgradesBought = (CPS n) : state.upgradesBought }
step (Buy (Burst n)) state =
  state { clickBurst = state.clickBurst + n
        , upgradesBought = (Burst n) : state.upgradesBought }
step (Switch screen) state = state { screen = screen }
step Reset _ = initialState

updateRate :: Signal Number
updateRate = every second

cps :: Signal Action
cps = sampleOn updateRate (constant AutoClick)

main :: forall eff. Eff ( chan :: Chan, dom :: DOM | eff ) Unit
main = do
  body' <- getBody
  channel <- channel Reset
  let actions = subscribe channel
      gameState = foldp step initialState (cps <> actions)
      game = gameState <#> mkEnv channel >>> (\ env -> render (ui env) body') >>> void
  runSignal game
  where
    ui env = D.div' [createFactory (component env) unit]
    getBody = do
      win <- window
      doc <- document win
      elm <- fromJust <$> toMaybe <$> body doc
      pure $ htmlElementToElement elm

module Main where

import Prelude

import Control.Monad.Eff (Eff())

import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe (fromJust)
import Data.Nullable (toMaybe)
import Data.List (List(..), (:))

import Signal (Signal(), constant, foldp, runSignal, sampleOn)
import Signal.Time (every, second)
import Signal.Channel (Chan(), Channel(), channel, send, subscribe)

import DOM (DOM())
import DOM.HTML (window)
import DOM.HTML.Document (body)
import DOM.HTML.Types (htmlElementToElement)
import DOM.HTML.Window (document)

import React
import React.DOM as D
import React.DOM.Props as P

type State a = { clicks :: Number
               , cps :: Number
               , clickBurst :: Number
               , upgradesBought :: List Upgrade
               | a }
type GameState = State ()
type Environment = State ( channel :: Channel Action )
type Component = Environment -> ReactElement

mkEnv :: Channel Action -> GameState -> Environment
mkEnv channel state = { clicks: state.clicks
                      , channel: channel
                      , clickBurst: state.clickBurst
                      , upgradesBought: state.upgradesBought
                      , cps: state.cps }

initialState :: GameState
initialState = { clicks: 0.0
               , cps: 0.0
               , upgradesBought: Nil
               , clickBurst: 1.0 }

data Action = Click
            | AutoClick
            | Buy Upgrade
            | Reset

data Upgrade = CPS Number
             | Burst Number

instance showUpgrade :: Show Upgrade where
  show (CPS n) = "buy CPS upgrade +" ++ show n
  show (Burst n) = "buy click upgrade +" ++ show n

genericButtonWithText :: Action -> String -> Environment -> ReactElement
genericButtonWithText act str env =
  D.button [P.onClick \ _ -> send env.channel act] [D.text str]

clickButton :: Component
clickButton = genericButtonWithText Click "click me!"

resetButton :: Component
resetButton = genericButtonWithText Reset "reset"

buyButton :: Component
buyButton env = D.div' $ flip apply [env] [ upgrade (CPS 1.0)
                                          , upgrade (Burst 1.0)
                                          ]

upgrade :: Upgrade -> Component
upgrade up = genericButtonWithText (Buy up) (show up)

controls :: Component
controls env = D.div' $ flip apply [env] [clickButton, resetButton, buyButton]

currentClicks :: Component
currentClicks env = D.text (show env.clicks)

view :: Component
view env = D.div' $ flip apply [env] [controls, currentClicks]

component :: Environment -> ReactClass Unit
component env = createClass (spec unit \ _ -> pure (view env))

step :: Action -> GameState -> GameState
step Click state = state { clicks = state.clicks + state.clickBurst }
step AutoClick state = state { clicks = state.clicks + state.cps }
step (Buy (CPS n)) state = state { cps = state.cps + n, upgradesBought = (CPS n) : state.upgradesBought }
step (Buy (Burst n)) state = state { clickBurst = state.clickBurst + n, upgradesBought = (Burst n) : state.upgradesBought }
step Reset _ = initialState

updateRate :: Signal Number
updateRate = every second

cps :: Signal Action
cps = sampleOn updateRate (constant AutoClick)

main :: forall eff. Eff ( chan :: Chan, dom :: DOM | eff ) Unit
main = do
  body' <- getBody
  channel <- channel Reset
  let actions = subscribe channel
      gameState = foldp step initialState (cps <> actions)
      game = gameState <#> mkEnv channel >>> (\ env -> render (ui env) body') >>> void
  runSignal game
  where
    ui env = D.div' [createFactory (component env) unit]
    getBody = do
      win <- window
      doc <- document win
      elm <- fromJust <$> toMaybe <$> body doc
      pure $ htmlElementToElement elm


initial support for keyboard events

initial support for keyboard events

module Main (main) where

import Control.Monad.Eff
import Data.Array
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Document
import Data.DOM.Simple.Window
import Data.DOM.Simple.Types
import DOM
import Data.Enum
import Data.Foldable
import Data.Maybe
import Data.Traversable
import Data.String.Regex (regex, parseFlags, replace)
import Debug.Trace

import Types
import Transformer
import Sortable
import Isomer

initial :: Wall
initial = [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]]

target :: Wall
target = [[Yellow], [Yellow, Yellow], [Yellow]]

cubeColor :: Cube -> IsomerColor
cubeColor Blue = colorFromRGB 0 160 176
cubeColor Brown = colorFromRGB 106 74 60
cubeColor Red = colorFromRGB 204 51 63
cubeColor Orange = colorFromRGB 235 104 65
cubeColor Yellow = colorFromRGB 237 201 81

mapIndexed :: forall a b. (Number -> a -> b) -> [a] -> [b]
mapIndexed f xs = zipWith f (0 .. (length xs - 1)) xs

renderStack :: forall eff. IsomerInstance -> Number -> Number -> Stack -> Eff (isomer :: Isomer | eff) Unit
renderStack isomer y x stack =
    sequence_ $ mapIndexed (renderCube isomer x (-6 * y)) $ map cubeColor stack

renderWall :: forall eff. IsomerInstance -> Number -> Wall -> Eff (isomer :: Isomer | eff) Unit
renderWall isomer y wall =
    sequence_ $ mapIndexed (\x stack -> renderStack isomer y (length wall - x) stack) (reverse wall)

renderWalls :: forall eff. IsomerInstance -> [Wall] -> Eff (isomer :: Isomer | eff) Unit
renderWalls isomer walls = do
    setIsomerConfig isomer 40 40 400
    sequence_ $ mapIndexed (renderWall isomer) walls

renderTarget isomer target = do
    setIsomerConfig isomer 22 1200 250
    renderWall isomer 0 target

renderAll isomer = do
    doc <- document globalWindow
    Just ulAvailable <- getElementById "program" doc
    lis <- children ulAvailable
    ids <- sequence $ map (getAttribute "id") lis
    let fs = catMaybes $ map getTransformerById ids

    trace $ "IDs: " ++ show ids
    trace $ "Initial: " ++ show initial
    trace "Steps:"
    let steps = allSteps fs initial
    traverse_ (show >>> trace) steps
    trace "---"
    trace ""

    clearCanvas isomer
    renderWalls isomer steps
    renderTarget isomer target

getTransformerById :: String -> Maybe Transformer
getTransformerById id = (\x -> x.function) <$> (head $ filter (\t -> t.id == id) transformers)

type TransformerRecord = {
    id :: String,
    name :: String,
    function :: Transformer
}

transformers :: [TransformerRecord]
transformers = [
    {
        id: "stackEqual",
        name: "stackEqual",
        function: tStackEqual
    }, {
        id: "mapClone",
        name: "map({X} ↦ {X}{X})",
        function: map $ concatMap (\x -> [x, x])
    }, {
        id: "flatten",
        name: "flatten",
        function: tFlatten
    }, {
        id: "replaceYbyB",
        name: "map({Yellow} ↦ {Brown})",
        function: tReplace Yellow Brown
    }, {
        id: "replaceYbyBY",
        name: "map({Yellow} ↦ {Brown}{Yellow})",
        function: tReplaceMultiple Yellow [Brown, Yellow]
    }, {
        id: "replaceBbyBBB",
        name: "map({Brown} ↦ {Brown}{Brown}{Brown})",
        function: tReplaceMultiple Brown [Brown, Brown, Brown]
    }, {
        id: "replaceBbyOO",
        name: "map({Brown} ↦ {Orange}{Orange})",
        function: tReplaceMultiple Brown [Orange, Orange]
    }, {
        id: "rejectO",
        name: "reject({Orange})",
        function: map (reject (== Orange)) >>> tClearEmpty
    }, {
        id: "pushY",
        name: "map(push({Yellow}))",
        function: map (flip snoc Yellow)
    }, {
        id: "tail",
        name: "map(tail)",
        function: tTail
    }
]

replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show (Blue `enumFromTo` Yellow))
        where replaceColor s c = replace (regex (pattern c) rf) (replacement c) s
              rf = parseFlags "g"
              pattern c = "{" ++ c ++ "}"
              replacement c = "

"

keyPress :: forall eff. HTMLDocument -> DOMEvent -> Eff (dom :: DOM | eff) Unit
keyPress doc event = do
    code <- keyCode event
    case code of
         -- 'g': generate new puzzle
         71 -> return unit
         -- 'r': reset lists
         82 -> resetUI doc
    return unit

resetUI :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) Unit
resetUI doc = do
    Just ulAvailable <- getElementById "available" doc
    let html = mconcat $ map (\t -> "
" ++ replaceColors t.name ++ "
") transformers
    setInnerHTML html ulAvailable
    Just ulProgram <- getElementById "program" doc
    setInnerHTML "" ulProgram

main = do
    isomer <- getIsomerInstance "canvas"

    -- install sortable
    doc <- document globalWindow

    let dummyHandler = return unit
    getElementById "available" doc >>= (\(Just el) -> installSortable el dummyHandler)
    getElementById "program" doc >>= (\(Just el) -> installSortable el (renderAll isomer))

    -- keyboard events
    addKeyboardEventListener KeydownEvent (keyPress doc) globalWindow

    resetUI doc
    renderAll isomer

module Main (main) where

import Control.Monad.Eff
import Data.Array
import Data.DOM.Simple.Window
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.Foldable
import Data.Maybe
import Data.Traversable
import Data.String.Regex (regex, parseFlags, replace)
import Debug.Trace

import Types
import Transformer
import Sortable
import Isomer

initial :: Wall
initial = [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]]

target :: Wall
target = [[Yellow], [Yellow, Yellow], [Yellow]]

cubeColor :: Cube -> IsomerColor
cubeColor Blue = colorFromRGB 0 160 176
cubeColor Brown = colorFromRGB 106 74 60
cubeColor Red = colorFromRGB 204 51 63
cubeColor Orange = colorFromRGB 235 104 65
cubeColor Yellow = colorFromRGB 237 201 81

mapIndexed :: forall a b. (Number -> a -> b) -> [a] -> [b]
mapIndexed f xs = zipWith f (0 .. (length xs - 1)) xs

renderStack :: forall eff. IsomerInstance -> Number -> Number -> Stack -> Eff (isomer :: Isomer | eff) Unit
renderStack isomer y x stack =
    sequence_ $ mapIndexed (renderCube isomer x (-6 * y)) $ map cubeColor stack

renderWall :: forall eff. IsomerInstance -> Number -> Wall -> Eff (isomer :: Isomer | eff) Unit
renderWall isomer y wall =
    sequence_ $ mapIndexed (\x stack -> renderStack isomer y (length wall - x) stack) (reverse wall)

renderWalls :: forall eff. IsomerInstance -> [Wall] -> Eff (isomer :: Isomer | eff) Unit
renderWalls isomer walls = do
    setIsomerConfig isomer 40 40 400
    sequence_ $ mapIndexed (renderWall isomer) walls

renderTarget isomer target = do
    setIsomerConfig isomer 22 1200 250
    renderWall isomer 0 target

sortHandler isomer = do
    doc <- document globalWindow
    Just ulAvailable <- getElementById "program" doc
    lis <- children ulAvailable
    ids <- sequence $ map (getAttribute "id") lis
    let fs = catMaybes $ map getTransformerById ids

    trace $ "IDs: " ++ show ids
    trace $ "Initial: " ++ show initial
    trace "Steps:"
    let steps = allSteps fs initial
    traverse_ (show >>> trace) steps
    trace "---"
    trace ""

    clearCanvas isomer
    renderWalls isomer steps
    renderTarget isomer target

getTransformerById :: String -> Maybe Transformer
getTransformerById id = (\x -> x.function) <$> (head $ filter (\t -> t.id == id) transformers)

type TransformerRecord = {
    id :: String,
    name :: String,
    function :: Transformer
}

transformers :: [TransformerRecord]
transformers = [
    {
        id: "stackEqual",
        name: "stackEqual",
        function: tStackEqual
    }, {
        id: "mapClone",
        name: "map({X} ↦ {X}{X})",
        function: map $ concatMap (\x -> [x, x])
    }, {
        id: "flatten",
        name: "flatten",
        function: tFlatten
    }, {
        id: "replaceYbyB",
        name: "map({Yellow} ↦ {Brown})",
        function: tReplace Yellow Brown
    }, {
        id: "replaceYbyBY",
        name: "map({Yellow} ↦ {Brown}{Yellow})",
        function: tReplaceMultiple Yellow [Brown, Yellow]
    }, {
        id: "replaceBbyBBB",
        name: "map({Brown} ↦ {Brown}{Brown}{Brown})",
        function: tReplaceMultiple Brown [Brown, Brown, Brown]
    }, {
        id: "replaceBbyOO",
        name: "map({Brown} ↦ {Orange}{Orange})",
        function: tReplaceMultiple Brown [Orange, Orange]
    }, {
        id: "rejectO",
        name: "reject({Orange})",
        function: map (reject (== Orange)) >>> tClearEmpty
    }, {
        id: "pushY",
        name: "map(push({Yellow}))",
        function: map (flip snoc Yellow)
    }, {
        id: "tail",
        name: "map(tail)",
        function: tTail
    }
]

replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show [Brown, Orange, Red, Yellow, Blue]) -- TODO
      where replaceColor s c = replace (regex (pattern c) rf) (replacement c) s
            rf = parseFlags "g"
            pattern c = "{" ++ c ++ "}"
            replacement c = "

"

main = do
    isomer <- getIsomerInstance "canvas"

    -- install sortable
    doc <- document globalWindow

    let dummyHandler = return unit
    getElementById "available" doc >>= (\(Just el) -> installSortable el dummyHandler)
    getElementById "program" doc >>= (\(Just el) -> installSortable el (sortHandler isomer))

    Just ulAvailable <- getElementById "available" doc
    let html = mconcat $ map (\t -> "
" ++ replaceColors t.name ++ "
") transformers
    setInnerHTML html ulAvailable

    -- initial rendering
    sortHandler isomer


Allow for psc-package.json defining project. Fix #34

module PscIde.Project where

import Prelude
import Node.Path as NP
import Control.Monad.Eff (Eff)
import Data.Maybe (Maybe(..))
import Data.String (Pattern(..), contains)
import Node.FS (FS) as FS
import Node.FS.Sync (exists) as FS

-- | Get PureScript project root given a .purs file (identified by presence of bower.json)
getRoot :: forall eff'. NP.FilePath -> Eff (fs :: FS.FS | eff') (Maybe NP.FilePath)
getRoot path =
  let parent = getParent path
      bower = NP.concat [path, "bower.json"]
      pscPackage = NP.concat [path, "psc-package.json"] in
  if path == "" || path == parent then
    pure Nothing
  else if contains (Pattern "bower_components") path || contains (Pattern ".psc-package") path then
    getRoot parent
  else do
    hasBower <- FS.exists bower
    hasPscPackage <- FS.exists pscPackage
    if hasBower || hasPscPackage then pure $ Just path else getRoot parent

  where
    getParent :: NP.FilePath -> NP.FilePath
    getParent p = NP.concat [p, ".."]

module PscIde.Project where

import Prelude
import Node.Path as NP
import Control.Monad.Eff (Eff)
import Data.Maybe (Maybe(..))
import Data.String (Pattern(..), contains)
import Node.FS (FS) as FS
import Node.FS.Sync (exists) as FS

-- | Get PureScript project root given a .purs file (identified by presence of bower.json)
getRoot :: forall eff'. NP.FilePath -> Eff (fs :: FS.FS | eff') (Maybe NP.FilePath)
getRoot path =
  let parent = getParent path
      bower = NP.concat [path, "bower.json"] in
  if path == "" || path == parent then
    pure Nothing
  else if contains (Pattern "bower_components") path then
    getRoot parent
  else do
    hasBower <- FS.exists bower
    if hasBower then pure $ Just path else getRoot parent

  where
    getParent :: NP.FilePath -> NP.FilePath
    getParent p = NP.concat [p, ".."]