Refactoring options

Refactoring options

Using a typeclass approach for generating command line arguments from
options.

module GulpPurescript.Options
  ( pscOptions
  , pscOptionsNoOutput
  , pscMakeOptions
  , pscDocsOptions
  ) where

import Control.Alt ((<|>))

import Data.Array (concat, singleton)
import Data.Either (Either(..), either)
import Data.Foreign (Foreign(), ForeignError(TypeMismatch), F())
import Data.Foreign.Class (IsForeign, read, readProp)
import Data.Foreign.Keys (keys)
import Data.Foreign.NullOrUndefined (NullOrUndefined(..), runNullOrUndefined)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Traversable (for)
import Data.Tuple (Tuple())
import Data.Tuple.Nested (tuple2)

noPreludeOpt = "no-prelude"

noPreludeKey = "noPrelude"

noOptsOpt = "no-opts"

noOptsKey = "noOpts"

noMagicDoOpt = "no-magic-do"

noMagicDoKey = "noMagicDo"

noTcoOpt = "no-tco"

noTcoKey = "noTco"

verboseErrorsOpt = "verbose-errors"

verboseErrorsKey = "verboseErrors"

outputOpt = "output"

outputKey = outputOpt

browserNamespaceOpt = "browser-namespace"

browserNamespaceKey = "browserNamespace"

commentsOpt = "comments"

commentsKey = commentsOpt

noPrefixOpt = "no-prefix"

noPrefixKey = "noPrefix"

mainOpt = "main"

mainKey = mainOpt

moduleOpt = "module"

moduleKey = moduleOpt

codegenOpt = "codegen"

codegenKey = codegenOpt

externsOpt = "externs"

externsKey = externsOpt

formatOpt = "format"

formatKey = formatOpt

ffiOpt = "ffi"

ffiKey = ffiOpt

docgenOpt = "docgen"

docgenKey = docgenOpt

newtype Psc
  = Psc { noPrelude :: NullOrUndefined Boolean
        , noTco :: NullOrUndefined Boolean
        , noMagicDo :: NullOrUndefined Boolean
        , main :: NullOrUndefined (Either Boolean String)
        , noOpts :: NullOrUndefined Boolean
        , verboseErrors :: NullOrUndefined Boolean
        , comments :: NullOrUndefined Boolean
        , browserNamespace :: NullOrUndefined String
        , "module" :: NullOrUndefined [String]
        , codegen :: NullOrUndefined [String]
        , output :: NullOrUndefined String
        , externs :: NullOrUndefined String
        , noPrefix :: NullOrUndefined Boolean
        , ffi :: NullOrUndefined PathArray
        }

newtype PscMake
  = PscMake { noPrelude :: NullOrUndefined Boolean
            , noOpts :: NullOrUndefined Boolean
            , noMagicDo :: NullOrUndefined Boolean
            , noTco :: NullOrUndefined Boolean
            , verboseErrors :: NullOrUndefined Boolean
            , comments :: NullOrUndefined Boolean
            , noPrefix :: NullOrUndefined Boolean
            , output :: NullOrUndefined String
            , ffi :: NullOrUndefined PathArray
            }

newtype PscDocs
  = PscDocs { format :: NullOrUndefined Format
            , docgen :: NullOrUndefined Docgen
            }

newtype Docgen = Docgen Foreign

newtype PathArray = PathArray [String]

data Format = Markdown | ETags | CTags

instance isForeignEither :: (IsForeign a, IsForeign b) => IsForeign (Either a b) where
  read a = (Left <$> read a :: F a) <|>
           (Right <$> read a :: F b)

instance isForeignPsc :: IsForeign Psc where
  read obj =
    Psc <$> ({ noPrelude: _
             , noTco: _
             , noMagicDo: _
             , main: _
             , noOpts: _
             , verboseErrors: _
             , comments: _
             , browserNamespace: _
             , "module": _
             , codegen: _
             , output: _
             , externs: _
             , noPrefix: _
             , ffi: _
             } <$> readProp noPreludeKey obj
               <*> readProp noTcoKey obj
               <*> readProp noMagicDoKey obj
               <*> readProp mainKey obj
               <*> readProp noOptsKey obj
               <*> readProp verboseErrorsKey obj
               <*> readProp commentsKey obj
               <*> readProp browserNamespaceKey obj
               <*> readProp moduleKey obj
               <*> readProp codegenKey obj
               <*> readProp outputKey obj
               <*> readProp externsKey obj
               <*> readProp noPrefixKey obj
               <*> readProp ffiKey obj)

instance isForeignPscMake :: IsForeign PscMake where
  read obj =
    PscMake <$> ({ output: _
                 , noPrelude: _
                 , noTco: _
                 , noMagicDo: _
                 , noOpts: _
                 , verboseErrors: _
                 , comments: _
                 , noPrefix: _
                 , ffi: _
                 } <$> readProp outputKey obj
                   <*> readProp noPreludeKey obj
                   <*> readProp noTcoKey obj
                   <*> readProp noMagicDoKey obj
                   <*> readProp noOptsKey obj
                   <*> readProp verboseErrorsKey obj
                   <*> readProp commentsKey obj
                   <*> readProp noPrefixKey obj
                   <*> readProp ffiKey obj)

instance isForeignPscDocs :: IsForeign PscDocs where
  read obj =
    PscDocs <$> ({ format: _
                 , docgen: _
                 } <$> readProp formatKey obj
                   <*> readProp docgenOpt obj)

instance isForeignPathArray :: IsForeign PathArray where
  read val = PathArray <$> read val

instance isForeignDocgen :: IsForeign Docgen where
  read val = Docgen <$> read val

instance isForeignFormat :: IsForeign Format where
  read val = read val >>= (\a -> case a of
                                      "markdown" -> Right Markdown
                                      "etags" -> Right ETags
                                      "ctags" -> Right CTags
                                      a -> Left $ TypeMismatch "Format" a)

class CommandLineOption a where
  opt :: String -> NullOrUndefined a -> [String]

instance commandLineOptionBoolean :: CommandLineOption Boolean where
  opt key val = maybe [] (\a -> if a then ["--" ++ key] else []) (runNullOrUndefined val)

instance commandLineOptionString :: CommandLineOption String where
  opt key val = maybe [] (\a -> ["--" ++ key ++ "=" ++ a]) (runNullOrUndefined val)

instance commandLineOptionEither :: (CommandLineOption a, CommandLineOption b) => CommandLineOption (Either a b) where
  opt key val = maybe [] (either (\a -> opt key (NullOrUndefined $ Just a))
                                 (\a -> opt key (NullOrUndefined $ Just a)))
                      (runNullOrUndefined val)

instance commandLineOptionArray :: (CommandLineOption a) => CommandLineOption [a] where
  opt key val = concat $ opt key <$> (NullOrUndefined <<< Just)
                                 <$> (fromMaybe [] $ runNullOrUndefined val)

instance commandLineOptionPathArray :: CommandLineOption PathArray where
  opt key val =  opt key (NullOrUndefined ((\(PathArray a) -> a >>= expandGlob) <$> (runNullOrUndefined val)))

foreign import expandGlob
  """
  var expandGlob = (function () {
    var glob = require("glob");
    return function (pattern) {
      return glob.sync(pattern);
    };
  }());
  """ :: String -> [String]

instance commandLineOptionDocgen :: CommandLineOption Docgen where
  opt key val =  opt key (NullOrUndefined (parseDocgen <$> (runNullOrUndefined val)))

parseDocgen :: Docgen -> [String]
parseDocgen (Docgen obj) = either (const []) id $ parseName obj
                                              <|> parseList obj
                                              <|> parseObj obj
                                              <|> pure []
  where
    parseName :: Foreign -> F [String]
    parseName obj = singleton <$> read obj

    parseList :: Foreign -> F [String]
    parseList obj = read obj

    parseObj :: Foreign -> F [String]
    parseObj obj = do
      modules <- keys obj
      for modules \m -> (\f -> m ++ ":" ++ f) <$> readProp m obj

instance commandLineOptionFormat :: CommandLineOption Format where
  opt key val = opt key (maybe (NullOrUndefined Nothing)
                               (\a -> case a of
                                           Markdown -> NullOrUndefined (Just "markdown")
                                           ETags -> NullOrUndefined (Just "etags")
                                           CTags -> NullOrUndefined (Just "ctags"))
                               (runNullOrUndefined val))

foldPscOptions :: Psc -> [String]
foldPscOptions (Psc a) = opt noPreludeOpt a.noPrelude <>
                         opt noTcoOpt a.noTco <>
                         opt noMagicDoOpt a.noMagicDo <>
                         opt mainOpt a.main <>
                         opt noOptsOpt a.noOpts <>
                         opt verboseErrorsOpt a.verboseErrors <>
                         opt commentsOpt a.comments <>
                         opt browserNamespaceOpt a.browserNamespace <>
                         opt moduleOpt a."module" <>
                         opt codegenOpt a.codegen <>
                         opt outputOpt a.output <>
                         opt externsOpt a.externs <>
                         opt noPrefixOpt a.noPrefix <>
                         opt ffiOpt a.ffi

pscOptions :: Foreign -> Either ForeignError [String]
pscOptions opts = foldPscOptions <$> (read opts :: F Psc)

pscOptionsNoOutput :: Foreign -> Either ForeignError (Tuple (Maybe String) [String])
pscOptionsNoOutput opts = fold <$> parsed
  where parsed = read opts :: F Psc
        fold (Psc a) = tuple2 (runNullOrUndefined a.output)
                              (foldPscOptions (Psc $ a { output = NullOrUndefined Nothing }))

pscMakeOptions :: Foreign -> Either ForeignError [String]
pscMakeOptions opts = fold <$> parsed
  where parsed = read opts :: F PscMake
        fold (PscMake a) = opt outputOpt a.output <>
                           opt noPreludeOpt a.noPrelude <>
                           opt noTcoOpt a.noTco <>
                           opt noMagicDoOpt a.noMagicDo <>
                           opt noOptsOpt a.noOpts <>
                           opt verboseErrorsOpt a.verboseErrors <>
                           opt commentsOpt a.comments <>
                           opt noPrefixOpt a.noPrefix <>
                           opt ffiOpt a.ffi

pscDocsOptions :: Foreign -> Either ForeignError [String]
pscDocsOptions opts = fold <$> parsed
  where parsed = read opts :: F PscDocs
        fold (PscDocs a) = opt formatOpt a.format <>
                           opt docgenOpt a.docgen

module GulpPurescript.Options
  ( pscOptions
  , pscOptionsNoOutput
  , pscMakeOptions
  , pscDocsOptions
  ) where

import Control.Alt ((<|>))

import Data.Array (concat, singleton)
import Data.Either (Either(..), either)
import Data.Foreign (Foreign(), ForeignError(TypeMismatch), F())
import Data.Foreign.Class (IsForeign, read, readProp)
import Data.Foreign.Keys (keys)
import Data.Foreign.NullOrUndefined (NullOrUndefined(..), runNullOrUndefined)
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Traversable (for)
import Data.Tuple (Tuple())
import Data.Tuple.Nested (tuple2)

noPreludeOpt = "no-prelude"

noPreludeKey = "noPrelude"

noOptsOpt = "no-opts"

noOptsKey = "noOpts"

noMagicDoOpt = "no-magic-do"

noMagicDoKey = "noMagicDo"

noTcoOpt = "no-tco"

noTcoKey = "noTco"

verboseErrorsOpt = "verbose-errors"

verboseErrorsKey = "verboseErrors"

outputOpt = "output"

outputKey = outputOpt

browserNamespaceOpt = "browser-namespace"

browserNamespaceKey = "browserNamespace"

commentsOpt = "comments"

commentsKey = commentsOpt

noPrefixOpt = "no-prefix"

noPrefixKey = "noPrefix"

mainOpt = "main"

mainKey = mainOpt

moduleOpt = "module"

moduleKey = moduleOpt

codegenOpt = "codegen"

codegenKey = codegenOpt

externsOpt = "externs"

externsKey = externsOpt

formatOpt = "format"

formatKey = formatOpt

ffiOpt = "ffi"

ffiKey = ffiOpt

docgenOpt = "docgen"

docgenKey = docgenOpt

newtype Psc
  = Psc { noPrelude :: NullOrUndefined Boolean
        , noTco :: NullOrUndefined Boolean
        , noMagicDo :: NullOrUndefined Boolean
        , main :: NullOrUndefined (Either Boolean String)
        , noOpts :: NullOrUndefined Boolean
        , verboseErrors :: NullOrUndefined Boolean
        , comments :: NullOrUndefined Boolean
        , browserNamespace :: NullOrUndefined String
        , "module" :: NullOrUndefined [String]
        , codegen :: NullOrUndefined [String]
        , output :: NullOrUndefined String
        , externs :: NullOrUndefined String
        , noPrefix :: NullOrUndefined Boolean
        , ffi :: NullOrUndefined [String]
        }

newtype PscMake
  = PscMake { noPrelude :: NullOrUndefined Boolean
            , noOpts :: NullOrUndefined Boolean
            , noMagicDo :: NullOrUndefined Boolean
            , noTco :: NullOrUndefined Boolean
            , verboseErrors :: NullOrUndefined Boolean
            , comments :: NullOrUndefined Boolean
            , noPrefix :: NullOrUndefined Boolean
            , output :: NullOrUndefined String
            , ffi :: NullOrUndefined [String]
            }

newtype PscDocs
  = PscDocs { format :: NullOrUndefined Format
            , docgen :: NullOrUndefined Foreign
            }

data Format = Markdown | ETags | CTags

instance isForeignEither :: (IsForeign a, IsForeign b) => IsForeign (Either a b) where
  read a = (Left <$> read a :: F a) <|>
           (Right <$> read a :: F b)

instance isForeignPsc :: IsForeign Psc where
  read obj =
    Psc <$> ({ noPrelude: _
             , noTco: _
             , noMagicDo: _
             , main: _
             , noOpts: _
             , verboseErrors: _
             , comments: _
             , browserNamespace: _
             , "module": _
             , codegen: _
             , output: _
             , externs: _
             , noPrefix: _
             , ffi: _
             } <$> readProp noPreludeKey obj
               <*> readProp noTcoKey obj
               <*> readProp noMagicDoKey obj
               <*> readProp mainKey obj
               <*> readProp noOptsKey obj
               <*> readProp verboseErrorsKey obj
               <*> readProp commentsKey obj
               <*> readProp browserNamespaceKey obj
               <*> readProp moduleKey obj
               <*> readProp codegenKey obj
               <*> readProp outputKey obj
               <*> readProp externsKey obj
               <*> readProp noPrefixKey obj
               <*> readProp ffiKey obj)

instance isForeignPscMake :: IsForeign PscMake where
  read obj =
    PscMake <$> ({ output: _
                 , noPrelude: _
                 , noTco: _
                 , noMagicDo: _
                 , noOpts: _
                 , verboseErrors: _
                 , comments: _
                 , noPrefix: _
                 , ffi: _
                 } <$> readProp outputKey obj
                   <*> readProp noPreludeKey obj
                   <*> readProp noTcoKey obj
                   <*> readProp noMagicDoKey obj
                   <*> readProp noOptsKey obj
                   <*> readProp verboseErrorsKey obj
                   <*> readProp commentsKey obj
                   <*> readProp noPrefixKey obj
                   <*> readProp ffiKey obj)

instance isForeignPscDocs :: IsForeign PscDocs where
  read obj =
    PscDocs <$> ({ format: _
                 , docgen: _
                 } <$> readProp formatKey obj
                   <*> readProp docgenOpt obj)

instance isForeignFormat :: IsForeign Format where
  read val = read val >>= (\a -> case a of
                                      "markdown" -> Right Markdown
                                      "etags" -> Right ETags
                                      "ctags" -> Right CTags
                                      a -> Left $ TypeMismatch "Format" a)

mkBoolean :: String -> NullOrUndefined Boolean -> [String]
mkBoolean key opt = maybe [] (\a -> if a then ["--" ++ key] else []) (runNullOrUndefined opt)

mkString :: String -> NullOrUndefined String -> [String]
mkString key opt = maybe [] (\a -> ["--" ++ key ++ "=" ++ a]) (runNullOrUndefined opt)

mkBooleanString :: String -> NullOrUndefined (Either Boolean String) -> [String]
mkBooleanString key opt = maybe [] (either (\a -> mkBoolean key (NullOrUndefined $ Just a))
                                           (\a -> mkString key (NullOrUndefined $ Just a)))
                                   (runNullOrUndefined opt)

mkStringArray :: String -> NullOrUndefined [String] -> [String]
mkStringArray key opt = concat $ mkString key <$> (NullOrUndefined <<< Just)
                                              <$> (fromMaybe [] $ runNullOrUndefined opt)

mkPathArray :: String -> NullOrUndefined [String] -> [String]
mkPathArray key opt = concat $ mkString key <$> (NullOrUndefined <<< Just)
                                            <$> (fromMaybe [] (runNullOrUndefined opt) >>= expandGlob)

mkDocgen :: String -> NullOrUndefined Foreign -> [String]
mkDocgen key opt = concat $ mkString key <$> (NullOrUndefined <<< Just)
                                         <$> (maybe [] parse (runNullOrUndefined opt))
  where
  parse :: Foreign -> [String]
  parse obj = either (const []) id $ parseName obj
                                 <|> parseList obj
                                 <|> parseObj obj
                                 <|> pure []

  parseName :: Foreign -> F [String]
  parseName obj = singleton <$> read obj

  parseList :: Foreign -> F [String]
  parseList obj = read obj

  parseObj :: Foreign -> F [String]
  parseObj obj = do
    modules <- keys obj
    for modules \m -> (\f -> m ++ ":" ++ f) <$> readProp m obj

foreign import expandGlob
  """
  var expandGlob = (function () {
    var glob = require("glob");
    return function (pattern) {
      return glob.sync(pattern);
    };
  }());
  """ :: String -> [String]

mkFormat :: String -> NullOrUndefined Format -> [String]
mkFormat key opt = mkString key (maybe j (\a -> case a of
                                                     Markdown -> i "markdown"
                                                     ETags -> i "etags"
                                                     CTags -> i "ctags") $ runNullOrUndefined opt)
  where i a = NullOrUndefined $ Just a
        j = NullOrUndefined Nothing

foldPscOptions :: Psc -> [String]
foldPscOptions (Psc a) = mkBoolean noPreludeOpt a.noPrelude <>
                         mkBoolean noTcoOpt a.noTco <>
                         mkBoolean noMagicDoOpt a.noMagicDo <>
                         mkBooleanString mainOpt a.main <>
                         mkBoolean noOptsOpt a.noOpts <>
                         mkBoolean verboseErrorsOpt a.verboseErrors <>
                         mkBoolean commentsOpt a.comments <>
                         mkString browserNamespaceOpt a.browserNamespace <>
                         mkStringArray moduleOpt a."module" <>
                         mkStringArray codegenOpt a.codegen <>
                         mkString outputOpt a.output <>
                         mkString externsOpt a.externs <>
                         mkBoolean noPrefixOpt a.noPrefix <>
                         mkPathArray ffiOpt a.ffi

pscOptions :: Foreign -> Either ForeignError [String]
pscOptions opts = foldPscOptions <$> (read opts :: F Psc)

pscOptionsNoOutput :: Foreign -> Either ForeignError (Tuple (Maybe String) [String])
pscOptionsNoOutput opts = fold <$> parsed
  where parsed = read opts :: F Psc
        fold (Psc a) = tuple2 (runNullOrUndefined a.output)
                              (foldPscOptions (Psc $ a { output = NullOrUndefined Nothing }))

pscMakeOptions :: Foreign -> Either ForeignError [String]
pscMakeOptions opts = fold <$> parsed
  where parsed = read opts :: F PscMake
        fold (PscMake a) = mkString outputOpt a.output <>
                           mkBoolean noPreludeOpt a.noPrelude <>
                           mkBoolean noTcoOpt a.noTco <>
                           mkBoolean noMagicDoOpt a.noMagicDo <>
                           mkBoolean noOptsOpt a.noOpts <>
                           mkBoolean verboseErrorsOpt a.verboseErrors <>
                           mkBoolean commentsOpt a.comments <>
                           mkBoolean noPrefixOpt a.noPrefix <>
                           mkPathArray ffiOpt a.ffi

pscDocsOptions :: Foreign -> Either ForeignError [String]
pscDocsOptions opts = fold <$> parsed
  where parsed = read opts :: F PscDocs
        fold (PscDocs a) = mkFormat formatOpt a.format <>
                           mkDocgen docgenOpt a.docgen


Simplify matches

Simplify matches

module Routing
  ( RoutingEffects
  , foldHashes
  , hashes
  , matches
  , matchesWith
  , match
  , matchWith
  ) where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (REF, newRef, readRef, writeRef)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener, removeEventListener)
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes (hashchange)
import DOM.HTML.Types (windowToEventTarget)
import Data.Either (Either)
import Data.Foldable (class Foldable, find)
import Data.Maybe (Maybe(..), maybe)
import Global (decodeURIComponent)
import Routing.Hash (getHash)
import Routing.Match (Match, runMatch)
import Routing.Parser (parse)

type RoutingEffects eff =
  ( dom :: DOM
  , ref :: REF
  | eff
  )

-- | Folds effectfully over hash changes given a callback and an initial hash.
-- | The provided String is the hash portion of the `Location` with the '#'
-- | prefix stripped. Returns an effect which will remove the listener.
foldHashes
  :: forall eff a
   . (a -> String -> Eff (RoutingEffects eff) a)
  -> (String -> Eff (RoutingEffects eff) a)
  -> Eff (RoutingEffects eff) (Eff (RoutingEffects eff) Unit)
foldHashes cb init = do
  ref <- newRef =<< init =<< getHash
  win <- windowToEventTarget <$> window
  let listener = eventListener \_ -> writeRef ref =<< join (cb <$> readRef ref <*> getHash)
  addEventListener hashchange listener false win
  pure $ removeEventListener hashchange listener false win

-- | Runs the callback on every hash change providing the previous hash and the
-- | latest hash. The provided String is the hash portion of the `Location` with
-- | the '#' prefix stripped. Returns an effect which will remove the listener.
hashes
  :: forall eff
   . (Maybe String -> String -> Eff (RoutingEffects eff) Unit)
  -> Eff (RoutingEffects eff) (Eff (RoutingEffects eff) Unit)
hashes = matchesWith Just

-- | Runs the callback on every hash change using a given `Match` parser to
-- | extract a route from the hash. If a hash fails to parse, it is ignored.
-- | To avoid dropping hashes, provide a fallback alternative in your parser.
-- | Returns an effect which will remove the listener.
matches
  :: forall eff a
   . Match a
  -> (Maybe a -> a -> Eff (RoutingEffects eff) Unit)
  -> Eff (RoutingEffects eff) (Eff (RoutingEffects eff) Unit)
matches = matchesWith <<< match

-- | Runs the callback on every hash change using a given custom parser to
-- | extract a route from the hash. If a hash fails to parse, it is ignored.
-- | To avoid dropping hashes, provide a fallback alternative in your parser.
-- | Returns an effect which will remove the listener.
matchesWith
  :: forall eff f a
   . Foldable f
  => (String -> f a)
  -> (Maybe a -> a -> Eff (RoutingEffects eff) Unit)
  -> Eff (RoutingEffects eff) (Eff (RoutingEffects eff) Unit)
matchesWith parser cb = foldHashes go (go Nothing)
  where
  go a =
    maybe (pure a) (\b -> Just b <$ cb a b)
      <<< find (const true)
      <<< parser

-- | Runs a `Match` parser.
match :: forall a. Match a -> String -> Either String a
match = matchWith decodeURIComponent

-- | Runs a `Match` parser given a custom String decoder.
matchWith :: forall a. (String -> String) -> Match a -> String -> Either String a
matchWith decoder matcher = runMatch matcher <<< parse decoder

module Routing
  ( RoutingEffects
  , foldHashes
  , hashes
  , matches
  , matchesWith
  , match
  , matchWith
  ) where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (REF, newRef, readRef, writeRef)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener, removeEventListener)
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes (hashchange)
import DOM.HTML.Types (windowToEventTarget)
import Data.Either (Either)
import Data.Foldable (class Foldable, find)
import Data.Maybe (Maybe(..), maybe)
import Global (decodeURIComponent)
import Routing.Hash (getHash)
import Routing.Match (Match, runMatch)
import Routing.Parser (parse)

type RoutingEffects eff =
  ( dom :: DOM
  , ref :: REF
  | eff
  )

-- | Folds effectfully over hash changes given a callback and an initial hash.
-- | The provided String is the hash portion of the `Location` with the '#'
-- | prefix stripped. Returns an effect which will remove the listener.
foldHashes
  :: forall eff a
   . (a -> String -> Eff (RoutingEffects eff) a)
  -> (String -> Eff (RoutingEffects eff) a)
  -> Eff (RoutingEffects eff) (Eff (RoutingEffects eff) Unit)
foldHashes cb init = do
  ref <- newRef =<< init =<< getHash
  win <- windowToEventTarget <$> window
  let listener = eventListener \_ -> writeRef ref =<< join (cb <$> readRef ref <*> getHash)
  addEventListener hashchange listener false win
  pure $ removeEventListener hashchange listener false win

-- | Runs the callback on every hash change providing the previous hash and the
-- | latest hash. The provided String is the hash portion of the `Location` with
-- | the '#' prefix stripped. Returns an effect which will remove the listener.
hashes
  :: forall eff
   . (Maybe String -> String -> Eff (RoutingEffects eff) Unit)
  -> Eff (RoutingEffects eff) (Eff (RoutingEffects eff) Unit)
hashes = matchesWith Just

-- | Runs the callback on every hash change using a given `Match` parser to
-- | extract a route from the hash. If a hash fails to parse, it is ignored.
-- | To avoid dropping hashes, provide a fallback alternative in your parser.
-- | Returns an effect which will remove the listener.
matches
  :: forall eff a
   . Match a
  -> (Maybe a -> a -> Eff (RoutingEffects eff) Unit)
  -> Eff (RoutingEffects eff) (Eff (RoutingEffects eff) Unit)
matches matcher = matchesWith (matchWith decodeURIComponent matcher)

-- | Runs the callback on every hash change using a given custom parser to
-- | extract a route from the hash. If a hash fails to parse, it is ignored.
-- | To avoid dropping hashes, provide a fallback alternative in your parser.
-- | Returns an effect which will remove the listener.
matchesWith
  :: forall eff f a
   . Foldable f
  => (String -> f a)
  -> (Maybe a -> a -> Eff (RoutingEffects eff) Unit)
  -> Eff (RoutingEffects eff) (Eff (RoutingEffects eff) Unit)
matchesWith parser cb = foldHashes go (go Nothing)
  where
  go a =
    maybe (pure a) (\b -> Just b <$ cb a b)
      <<< find (const true)
      <<< parser

-- | Runs a `Match` parser.
match :: forall a. Match a -> String -> Either String a
match = matchWith decodeURIComponent

-- | Runs a `Match` parser given a custom String decoder.
matchWith :: forall a. (String -> String) -> Match a -> String -> Either String a
matchWith decoder matcher = runMatch matcher <<< parse decoder


Expan on Semigroup's documentation to explain purposes behind newtypes

module Data.Semigroup
  ( class Semigroup, append, (<>)
  , class SemigroupRecord, appendRecord
  ) where

import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Unit (Unit, unit)
import Data.Void (Void, absurd)
import Prim.Row as Row
import Prim.RowList as RL
import Record.Unsafe (unsafeGet, unsafeSet)
import Type.Data.RowList (RLProxy(..))

-- | The `Semigroup` type class identifies an associative operation on a type.
-- |
-- | Instances are required to satisfy the following law:
-- |
-- | - Associativity: `(x <> y) <> z = x <> (y <> z)`
-- |
-- | One example of a `Semigroup` is `String`, with `(<>)` defined as string
-- | concatenation. Another example is `List a`, with `(<>)` defined as
-- | list concatenation.
-- |
-- | There are two other ways to implement an instance for this type class
-- | regardless of which type is used. These instances can be used by
-- | wrapping the values in one of the two newtypes below:
-- | 1. `First` - Use the first argument every time: `append first _ = first`.
-- | 2. `Last` - Use the last argument every time: `append _ last = last`.
class Semigroup a where
  append :: a -> a -> a

infixr 5 append as <>

instance semigroupString :: Semigroup String where
  append = concatString

instance semigroupUnit :: Semigroup Unit where
  append _ _ = unit

instance semigroupVoid :: Semigroup Void where
  append _ = absurd

instance semigroupFn :: Semigroup s' => Semigroup (s -> s') where
  append f g x = f x <> g x

instance semigroupArray :: Semigroup (Array a) where
  append = concatArray

instance semigroupRecord :: (RL.RowToList row list, SemigroupRecord list row row) => Semigroup (Record row) where
  append = appendRecord (RLProxy :: RLProxy list)

foreign import concatString :: String -> String -> String
foreign import concatArray :: forall a. Array a -> Array a -> Array a

-- | A class for records where all fields have `Semigroup` instances, used to
-- | implement the `Semigroup` instance for records.
class SemigroupRecord rowlist row subrow | rowlist -> subrow where
  appendRecord :: RLProxy rowlist -> Record row -> Record row -> Record subrow

instance semigroupRecordNil :: SemigroupRecord RL.Nil row () where
  appendRecord _ _ _ = {}

instance semigroupRecordCons
    :: ( IsSymbol key
       , Row.Cons key focus subrowTail subrow
       , SemigroupRecord rowlistTail row subrowTail
       , Semigroup focus
       )
    => SemigroupRecord (RL.Cons key focus rowlistTail) row subrow where
  appendRecord _ ra rb = insert (get ra <> get rb) tail
    where
      key = reflectSymbol (SProxy :: SProxy key)
      get = unsafeGet key :: Record row -> focus
      insert = unsafeSet key :: focus -> Record subrowTail -> Record subrow
      tail = appendRecord (RLProxy :: RLProxy rowlistTail) ra rb

module Data.Semigroup
  ( class Semigroup, append, (<>)
  , class SemigroupRecord, appendRecord
  ) where

import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Unit (Unit, unit)
import Data.Void (Void, absurd)
import Prim.Row as Row
import Prim.RowList as RL
import Record.Unsafe (unsafeGet, unsafeSet)
import Type.Data.RowList (RLProxy(..))

-- | The `Semigroup` type class identifies an associative operation on a type.
-- |
-- | Instances are required to satisfy the following law:
-- |
-- | - Associativity: `(x <> y) <> z = x <> (y <> z)`
-- |
-- | One example of a `Semigroup` is `String`, with `(<>)` defined as string
-- | concatenation. Another example is `List a`, with `(<>)` defined as
-- | list concatenation.
class Semigroup a where
  append :: a -> a -> a

infixr 5 append as <>

instance semigroupString :: Semigroup String where
  append = concatString

instance semigroupUnit :: Semigroup Unit where
  append _ _ = unit

instance semigroupVoid :: Semigroup Void where
  append _ = absurd

instance semigroupFn :: Semigroup s' => Semigroup (s -> s') where
  append f g x = f x <> g x

instance semigroupArray :: Semigroup (Array a) where
  append = concatArray

instance semigroupRecord :: (RL.RowToList row list, SemigroupRecord list row row) => Semigroup (Record row) where
  append = appendRecord (RLProxy :: RLProxy list)

foreign import concatString :: String -> String -> String
foreign import concatArray :: forall a. Array a -> Array a -> Array a

-- | A class for records where all fields have `Semigroup` instances, used to
-- | implement the `Semigroup` instance for records.
class SemigroupRecord rowlist row subrow | rowlist -> subrow where
  appendRecord :: RLProxy rowlist -> Record row -> Record row -> Record subrow

instance semigroupRecordNil :: SemigroupRecord RL.Nil row () where
  appendRecord _ _ _ = {}

instance semigroupRecordCons
    :: ( IsSymbol key
       , Row.Cons key focus subrowTail subrow
       , SemigroupRecord rowlistTail row subrowTail
       , Semigroup focus
       )
    => SemigroupRecord (RL.Cons key focus rowlistTail) row subrow where
  appendRecord _ ra rb = insert (get ra <> get rb) tail
    where
      key = reflectSymbol (SProxy :: SProxy key)
      get = unsafeGet key :: Record row -> focus
      insert = unsafeSet key :: focus -> Record subrowTail -> Record subrow
      tail = appendRecord (RLProxy :: RLProxy rowlistTail) ra rb


Improvements to Input.Notebook.slamDownOutput

- rename it to cellUpdateVarMap; add documentation
- remove a few unnecessary type conversions
- add some type signatures
- limit scope of some locally defined values
- use case split when it clarifies structure better than pattern
  matching

{-
Copyright 2015 SlamData, Inc.

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

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

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

module 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 SlamDown

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 (cellUpdateVarMap <<< 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

-- | Renders the cell's `SlamDownState` into a string map of `VarMapValue`s and
-- | appends it to the cell's output `VarMap`.
cellUpdateVarMap :: Cell -> Cell
cellUpdateVarMap cell =
  cell # _output .. _VarMap  %~ SM.union (renderFormFieldValue <$> slamDownState)
  where
    slamDownState :: SM.StrMap FormFieldValue
    slamDownState = cell ^? _content .. _Markdown .. Ma._state .. _SlamDownState # fromMaybe SM.empty

    renderFormFieldValue :: FormFieldValue -> VarMapValue
    renderFormFieldValue formFieldValue =
      case formFieldValue of
        SingleValue ty s ->
          case ty of
            PlainText -> quoteString s
            Numeric | isSQLNum s -> s
                    | otherwise -> quoteString s
            Date -> "DATE '" ++ s ++ "'"
            Time -> "TIME '" ++ s ++ "'"
            DateTime -> "TIMESTAMP '" ++ s ++ ":00Z'"
        MultipleValues s ->
          "[" <> intercalate ", " (quoteString <$> S.toList s) <> "]"
          -- TODO: is this anything like we want for multi-values?

    quoteString :: String -> String
    quoteString s = "'" ++ Rx.replace rxQuot "''" s ++ "'"
      where
        rxQuot :: Rx.Regex
        rxQuot = Rx.regex "'" Rx.noFlags { global = true }

    isSQLNum :: String -> Boolean
    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 -> L.List (Tuple String FormField)
slamDownFields = everything (const L.Nil) go
  where
  go (FormField s _ ff) = L.singleton (Tuple s ff)
  go _ = L.Nil

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 prunedSM = foldl (flip SM.delete) s $ keysToPrune s $ SM.fromList fields
                    mergedSM = prunedSM `SM.union` s'
                in SlamDownState mergedSM
        in cellUpdateVarMap (cell # _message .~ message fields
                                  # _content .. _Markdown .. Ma._state %~ updateState)
  in maybe cell (initial <<< parseMd) input'

  where
    -- | Returns the keys that are either not present in the new state, or have had their types changed.
    keysToPrune :: SM.StrMap FormFieldValue -> SM.StrMap FormField -> Array _
    keysToPrune oldState newState =
      SM.foldMap
        (\key oldVal ->
            case Tuple oldVal (SM.lookup key newState) of
               Tuple (SingleValue tbt1 _) (Just (TextBox tbt2 _)) -> if tbt1 == tbt2 then [] else [key]
               Tuple _ Nothing -> [key]
               _ -> [])
        oldState

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 content) =
    setFailures [ ]
    <<< (_content.._Markdown..Ma._evaluated ?~ content)

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))

{-
Copyright 2015 SlamData, Inc.

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

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

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

module 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 SlamDown

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 Numeric s) = quoteStringNumeric 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 = "'" ++ Rx.replace rxQuot "''" s ++ "'"
    quoteStringNumeric s | isSQLNum s = s
                         | otherwise = quoteString 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 -> L.List (Tuple String FormField)
slamDownFields = everything (const L.Nil) go
  where
  go (FormField s _ ff) = L.singleton (Tuple s ff)
  go _ = L.Nil

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 prunedSM = foldl (flip SM.delete) s $ keysToPrune s $ SM.fromList fields
                    mergedSM = prunedSM `SM.union` s'
                in SlamDownState mergedSM
        in slamDownOutput (cell # _message .~ message fields
                                # _content .. _Markdown .. Ma._state %~ updateState)
  in maybe cell (initial <<< parseMd) input'

  where
    -- | Returns the keys that are either not present in the new state, or have had their types changed.
    keysToPrune :: SM.StrMap FormFieldValue -> SM.StrMap FormField -> Array _
    keysToPrune oldState newState =
      SM.foldMap
        (\key oldVal ->
            case Tuple oldVal (SM.lookup key newState) of
               Tuple (SingleValue tbt1 _) (Just (TextBox tbt2 _)) -> if tbt1 == tbt2 then [] else [key]
               Tuple _ Nothing -> [key]
               _ -> [])
        oldState

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 content) =
    setFailures [ ]
    <<< (_content.._Markdown..Ma._evaluated ?~ content)

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))


Generalize test

Generalize test

module Main where

import Data.Array
import Data.Function (on)
import Data.Foldable (foldr)

import Merge
import Tree

import Test.QuickCheck
import Test.QuickCheck.LCG

isSorted :: forall a. (Ord a) => [a] -> Boolean
isSorted (x1 : t@(x2 : xs)) = x1 <= x2 && isSorted t
isSorted _ = true

isSubarrayOf :: forall a. (Eq a) => [a] -> [a] -> Boolean
isSubarrayOf xs ys = ys `intersect` xs == xs

newtype Sorted a = Sorted [a]

sorted :: forall a. Sorted a -> [a]
sorted (Sorted xs) = xs

instance arbSorted :: (Arbitrary a, Ord a) => Arbitrary (Sorted a) where
  arbitrary = Sorted <<< sort <$> arbitrary

numbers :: [Number] -> [Number]
numbers = id

numberToBool :: (Number -> Boolean) -> Number -> Boolean
numberToBool = id

instance arbTree :: (Arbitrary a, Ord a) => Arbitrary (Tree a) where
  arbitrary = fromArray <<< sorted <$> arbitrary

main = do
  -- Tests for module 'Merge'

  quickCheck $ \xs ys -> isSorted $ merge (sorted xs) (sorted ys)
  quickCheck $ \xs ys -> xs `isSubarrayOf` merge xs ys

  quickCheck $ \xs ys -> isSorted $ numbers $ mergePoly (sorted xs) (sorted ys)
  quickCheck $ \xs ys -> numbers xs `isSubarrayOf` mergePoly xs ys

  quickCheck $ \xs ys f -> isSorted $ map f $ mergeWith (numberToBool f) (sortBy (compare `on` f) xs) (sortBy (compare `on` f) ys)
  quickCheck $ \xs ys f -> xs `isSubarrayOf` mergeWith (numberToBool f) xs ys

  -- Tests for module 'Tree'

  quickCheck $ \t a -> member a $ insert a (t :: Tree Number)
  quickCheck $ \t xs -> isSorted $ toArray $ foldr insert t $ numbers xs

module Main where

import Data.Array
import Data.Function (on)
import Data.Foldable (foldr)

import Merge
import Tree

import Test.QuickCheck
import Test.QuickCheck.LCG

isSorted :: forall a. (Ord a) => [a] -> Boolean
isSorted (x1 : t@(x2 : xs)) = x1 <= x2 && isSorted t
isSorted _ = true

isSubarrayOf :: forall a. (Eq a) => [a] -> [a] -> Boolean
isSubarrayOf xs ys = ys `intersect` xs == xs

newtype Sorted a = Sorted [a]

sorted :: forall a. Sorted a -> [a]
sorted (Sorted xs) = xs

instance arbSorted :: (Arbitrary a, Ord a) => Arbitrary (Sorted a) where
  arbitrary = Sorted <<< sort <$> arbitrary

numbers :: [Number] -> [Number]
numbers = id

numberToBool :: (Number -> Boolean) -> Number -> Boolean
numberToBool = id

instance arbTree :: (Arbitrary a, Ord a) => Arbitrary (Tree a) where
  arbitrary = fromArray <<< sorted <$> arbitrary

main = do
  -- Tests for module 'Merge'

  quickCheck $ \xs ys -> isSorted $ merge (sorted xs) (sorted ys)
  quickCheck $ \xs ys -> xs `isSubarrayOf` merge xs ys

  quickCheck $ \xs ys -> isSorted $ numbers $ mergePoly (sorted xs) (sorted ys)
  quickCheck $ \xs ys -> numbers xs `isSubarrayOf` mergePoly xs ys

  quickCheck $ \xs ys f -> isSorted $ map f $ mergeWith (numberToBool f) (sortBy (compare `on` f) xs) (sortBy (compare `on` f) ys)
  quickCheck $ \xs ys f -> xs `isSubarrayOf` mergeWith (numberToBool f) xs ys

  -- Tests for module 'Tree'

  quickCheck $ \t a -> member a $ insert a (t :: Tree Number)
  quickCheck $ \xs -> isSorted $ toArray $ foldr insert Leaf $ numbers xs