Prevent `done` from running multiple times for subscriptions (#448)

module Halogen.Aff.Driver.Eval where

import Prelude

import Control.Applicative.Free (hoistFreeAp, retractFreeAp)
import Control.Coroutine as CR
import Control.Monad.Aff (Aff, attempt, forkAff, forkAll)
import Control.Monad.Aff.Unsafe (unsafeCoerceAff)
import Control.Monad.Aff.AVar as AV
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Ref (REF, Ref, readRef, modifyRef, modifyRef', writeRef, newRef)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Fork (fork)
import Control.Monad.Free (foldFree)
import Control.Monad.Trans.Class (lift)
import Control.Parallel (parallel, sequential)

import Data.Coyoneda (Coyoneda, unCoyoneda)
import Data.Either (Either(..))
import Data.List (List, (:))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.StrMap as SM
import Data.Tuple (Tuple(..))

import Halogen.Aff.Driver.State (DriverState(..), LifecycleHandlers, unDriverStateX)
import Halogen.Aff.Effects (HalogenEffects)
import Halogen.Data.OrdBox (unOrdBox)
import Halogen.Query.EventSource as ES
import Halogen.Query.ForkF as FF
import Halogen.Query.HalogenM (HalogenM(..), HalogenF(..), HalogenAp(..))
import Halogen.Query.InputF (InputF(..), RefLabel(..))

import Unsafe.Reference (unsafeRefEq)

parSequenceAff_
  :: forall eff a
   . L.List (Aff (avar :: AV.AVAR, ref :: REF | eff) a)
  -> Aff (avar :: AV.AVAR, ref :: REF | eff) Unit
parSequenceAff_ = case _ of
  L.Nil -> pure unit
  L.Cons a L.Nil -> void a
  as@(L.Cons _ tail) -> do
    var <- AV.makeVar
    ref <- liftEff $ newRef tail
    let
      run a = do
        attempt a >>= case _ of
          Left err -> AV.putVar var (Just err)
          Right _ ->
            liftEff (readRef ref) >>=
              case _ of
                L.Nil -> AV.putVar var Nothing
                L.Cons _ xs -> liftEff $ writeRef ref xs
    _ <- forkAll (run <$> as)
    AV.peekVar var >>= case _ of
      Nothing -> pure unit
      Just err -> throwError err

handleLifecycle
  :: forall eff a
   . Ref (LifecycleHandlers eff)
  -> Eff (HalogenEffects eff) a
  -> Aff (HalogenEffects eff) a
handleLifecycle lchs f = do
  liftEff $ writeRef lchs { initializers: L.Nil, finalizers: L.Nil }
  result <- liftEff f
  { initializers, finalizers } <- liftEff $ readRef lchs
  void $ forkAll finalizers
  parSequenceAff_ initializers
  pure result

type Renderer h r eff
  = forall s f z g p i o
   . Ref (LifecycleHandlers eff)
  -> Ref (DriverState h r s f z g p i o eff)
  -> Eff (HalogenEffects eff) Unit

eval
  :: forall h r eff s'' f z g'' p'' i o a
   . Renderer h r eff
  -> Ref (DriverState h r s'' f z g'' p'' i o eff)
  -> InputF a (z a)
  -> Aff (HalogenEffects eff) a
eval render r =
  case _ of
    RefUpdate (RefLabel p) el next -> do
      liftEff $ modifyRef r \(DriverState st) ->
        DriverState st { refs = SM.alter (const el) p st.refs }
      pure next
    Query q -> evalF r q

  where

  go
    :: forall s' f' z' g' p' i' o'
     . Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> HalogenF s' z' g' p' o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  go ref = case _ of
    State f -> do
      DriverState (st@{ state, lifecycleHandlers }) <- liftEff (readRef ref)
      case f state of
        Tuple a state'
          | unsafeRefEq state state' -> pure a
          | otherwise -> do
              liftEff $ writeRef ref (DriverState (st { state = state' }))
              handleLifecycle lifecycleHandlers (render lifecycleHandlers ref)
              pure a
    Subscribe es next -> do
      DriverState ({ subscriptions, fresh }) <- liftEff (readRef ref)
      void $ forkAff do
        { producer, done } <- ES.unEventSource es
        i <- liftEff $ modifyRef' fresh (\i -> { state: i + 1, value: i })
        let
          done' = do
            subs <- liftEff $ readRef subscriptions
            when (maybe false (M.member i) subs) do
              done
              liftEff $ modifyRef subscriptions (map (M.delete i))
        liftEff $ modifyRef subscriptions (map (M.insert i done'))
        let
          consumer = do
            q <- CR.await
            subs <- lift $ liftEff (readRef subscriptions)
            when (isJust subs) do
              s <- lift $ evalF ref q
              when (s == ES.Listening) consumer
        CR.runProcess (consumer `CR.pullFrom` producer)
        done'
      pure next
    Lift aff ->
      aff
    Halt msg ->
      throwError (error msg)
    GetSlots k -> do
      DriverState { children } <- liftEff (readRef ref)
      pure $ k $ map unOrdBox $ M.keys children
    CheckSlot p k -> do
      DriverState { component, children } <- liftEff (readRef ref)
      pure $ k $ M.member (component.mkOrdBox p) children
    ChildQuery p cq ->
      evalChildQuery ref p cq
    Raise o a -> do
      DriverState { handler, pendingOuts } <- liftEff (readRef ref)
      queuingHandler handler pendingOuts o
      pure a
    Par (HalogenAp p) ->
      sequential $ retractFreeAp $ hoistFreeAp (parallel <<< evalM ref) p
    Fork f ->
      FF.unFork (\(FF.ForkF fx k) →
        k <<< map unsafeCoerceAff <$> fork (evalM ref fx)) f
    GetRef (RefLabel p) k -> do
      DriverState { component, refs } <- liftEff (readRef ref)
      pure $ k $ SM.lookup p refs

  evalChildQuery
    :: forall s' f' z' g' p' i' o'
     . Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> p'
    -> Coyoneda g'
    ~> Aff (HalogenEffects eff)
  evalChildQuery ref p = unCoyoneda \k q -> do
    DriverState st <- liftEff (readRef ref)
    case M.lookup (st.component.mkOrdBox p) st.children of
      Just var -> do
        dsx <- liftEff (readRef var)
        unDriverStateX (\ds -> case ds.prjQuery q of
          Just q' -> k <$> evalF ds.selfRef q'
          Nothing -> throwError (error "Query projection failed for child query")) dsx
      Nothing -> throwError (error "Slot lookup failed for child query")

  evalF
    :: forall s' f' z' g' p' i' o'
     . Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> z'
    ~> Aff (HalogenEffects eff)
  evalF ref q = do
    DriverState st <- liftEff (readRef ref)
    case st.component.eval q of
      HalogenM fx -> foldFree (go ref) fx

  evalM
    :: forall s' f' z' g' p' i' o'
     . Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> HalogenM s' z' g' p' o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  evalM ref (HalogenM q) = foldFree (go ref) q

queuingHandler
  :: forall a eff
   . (a -> Aff (HalogenEffects eff) Unit)
  -> Ref (Maybe (List (Aff (HalogenEffects eff) Unit)))
  -> a
  -> Aff (HalogenEffects eff) Unit
queuingHandler handler ref message = do
  queue <- liftEff (readRef ref)
  case queue of
    Nothing ->
      handler message
    Just p ->
      liftEff $ writeRef ref (Just (handler message : p))

module Halogen.Aff.Driver.Eval where

import Prelude

import Control.Applicative.Free (hoistFreeAp, retractFreeAp)
import Control.Coroutine as CR
import Control.Monad.Aff (Aff, attempt, forkAff, forkAll)
import Control.Monad.Aff.Unsafe (unsafeCoerceAff)
import Control.Monad.Aff.AVar as AV
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Ref (REF, Ref, readRef, modifyRef, modifyRef', writeRef, newRef)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Fork (fork)
import Control.Monad.Free (foldFree)
import Control.Monad.Trans.Class (lift)
import Control.Parallel (parallel, sequential)

import Data.Coyoneda (Coyoneda, unCoyoneda)
import Data.Either (Either(..))
import Data.List (List, (:))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..), isJust)
import Data.StrMap as SM
import Data.Tuple (Tuple(..))

import Halogen.Aff.Driver.State (DriverState(..), LifecycleHandlers, unDriverStateX)
import Halogen.Aff.Effects (HalogenEffects)
import Halogen.Data.OrdBox (unOrdBox)
import Halogen.Query.EventSource as ES
import Halogen.Query.ForkF as FF
import Halogen.Query.HalogenM (HalogenM(..), HalogenF(..), HalogenAp(..))
import Halogen.Query.InputF (InputF(..), RefLabel(..))

import Unsafe.Reference (unsafeRefEq)

parSequenceAff_
  :: forall eff a
   . L.List (Aff (avar :: AV.AVAR, ref :: REF | eff) a)
  -> Aff (avar :: AV.AVAR, ref :: REF | eff) Unit
parSequenceAff_ = case _ of
  L.Nil -> pure unit
  L.Cons a L.Nil -> void a
  as@(L.Cons _ tail) -> do
    var <- AV.makeVar
    ref <- liftEff $ newRef tail
    let
      run a = do
        attempt a >>= case _ of
          Left err -> AV.putVar var (Just err)
          Right _ ->
            liftEff (readRef ref) >>=
              case _ of
                L.Nil -> AV.putVar var Nothing
                L.Cons _ xs -> liftEff $ writeRef ref xs
    _ <- forkAll (run <$> as)
    AV.peekVar var >>= case _ of
      Nothing -> pure unit
      Just err -> throwError err

handleLifecycle
  :: forall eff a
   . Ref (LifecycleHandlers eff)
  -> Eff (HalogenEffects eff) a
  -> Aff (HalogenEffects eff) a
handleLifecycle lchs f = do
  liftEff $ writeRef lchs { initializers: L.Nil, finalizers: L.Nil }
  result <- liftEff f
  { initializers, finalizers } <- liftEff $ readRef lchs
  void $ forkAll finalizers
  parSequenceAff_ initializers
  pure result

type Renderer h r eff
  = forall s f z g p i o
   . Ref (LifecycleHandlers eff)
  -> Ref (DriverState h r s f z g p i o eff)
  -> Eff (HalogenEffects eff) Unit

eval
  :: forall h r eff s'' f z g'' p'' i o a
   . Renderer h r eff
  -> Ref (DriverState h r s'' f z g'' p'' i o eff)
  -> InputF a (z a)
  -> Aff (HalogenEffects eff) a
eval render r =
  case _ of
    RefUpdate (RefLabel p) el next -> do
      liftEff $ modifyRef r \(DriverState st) ->
        DriverState st { refs = SM.alter (const el) p st.refs }
      pure next
    Query q -> evalF r q

  where

  go
    :: forall s' f' z' g' p' i' o'
     . Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> HalogenF s' z' g' p' o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  go ref = case _ of
    State f -> do
      DriverState (st@{ state, lifecycleHandlers }) <- liftEff (readRef ref)
      case f state of
        Tuple a state'
          | unsafeRefEq state state' -> pure a
          | otherwise -> do
              liftEff $ writeRef ref (DriverState (st { state = state' }))
              handleLifecycle lifecycleHandlers (render lifecycleHandlers ref)
              pure a
    Subscribe es next -> do
      DriverState ({ subscriptions, fresh }) <- liftEff (readRef ref)
      void $ forkAff do
        { producer, done } <- ES.unEventSource es
        i <- liftEff do
          i <- modifyRef' fresh (\i -> { state: i + 1, value: i })
          modifyRef subscriptions (map (M.insert i done))
          pure i
        let
          consumer = do
            q <- CR.await
            subs <- lift $ liftEff (readRef subscriptions)
            when (isJust subs) do
              s <- lift $ evalF ref q
              when (s == ES.Listening) consumer
        CR.runProcess (consumer `CR.pullFrom` producer)
        done
        liftEff $ modifyRef subscriptions (map (M.delete i))
      pure next
    Lift aff ->
      aff
    Halt msg ->
      throwError (error msg)
    GetSlots k -> do
      DriverState { children } <- liftEff (readRef ref)
      pure $ k $ map unOrdBox $ M.keys children
    CheckSlot p k -> do
      DriverState { component, children } <- liftEff (readRef ref)
      pure $ k $ M.member (component.mkOrdBox p) children
    ChildQuery p cq ->
      evalChildQuery ref p cq
    Raise o a -> do
      DriverState { handler, pendingOuts } <- liftEff (readRef ref)
      queuingHandler handler pendingOuts o
      pure a
    Par (HalogenAp p) ->
      sequential $ retractFreeAp $ hoistFreeAp (parallel <<< evalM ref) p
    Fork f ->
      FF.unFork (\(FF.ForkF fx k) →
        k <<< map unsafeCoerceAff <$> fork (evalM ref fx)) f
    GetRef (RefLabel p) k -> do
      DriverState { component, refs } <- liftEff (readRef ref)
      pure $ k $ SM.lookup p refs

  evalChildQuery
    :: forall s' f' z' g' p' i' o'
     . Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> p'
    -> Coyoneda g'
    ~> Aff (HalogenEffects eff)
  evalChildQuery ref p = unCoyoneda \k q -> do
    DriverState st <- liftEff (readRef ref)
    case M.lookup (st.component.mkOrdBox p) st.children of
      Just var -> do
        dsx <- liftEff (readRef var)
        unDriverStateX (\ds -> case ds.prjQuery q of
          Just q' -> k <$> evalF ds.selfRef q'
          Nothing -> throwError (error "Query projection failed for child query")) dsx
      Nothing -> throwError (error "Slot lookup failed for child query")

  evalF
    :: forall s' f' z' g' p' i' o'
     . Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> z'
    ~> Aff (HalogenEffects eff)
  evalF ref q = do
    DriverState st <- liftEff (readRef ref)
    case st.component.eval q of
      HalogenM fx -> foldFree (go ref) fx

  evalM
    :: forall s' f' z' g' p' i' o'
     . Ref (DriverState h r s' f' z' g' p' i' o' eff)
    -> HalogenM s' z' g' p' o' (Aff (HalogenEffects eff))
    ~> Aff (HalogenEffects eff)
  evalM ref (HalogenM q) = foldFree (go ref) q

queuingHandler
  :: forall a eff
   . (a -> Aff (HalogenEffects eff) Unit)
  -> Ref (Maybe (List (Aff (HalogenEffects eff) Unit)))
  -> a
  -> Aff (HalogenEffects eff) Unit
queuingHandler handler ref message = do
  queue <- liftEff (readRef ref)
  case queue of
    Nothing ->
      handler message
    Just p ->
      liftEff $ writeRef ref (Just (handler message : p))


Add encodeURLPiece function

Add encodeURLPiece function

module Servant.PureScript.Util where

import Prelude
import Control.Monad.Error.Class (class MonadError, throwError)
import Data.Argonaut.Core (Json)
import Data.Argonaut.Parser (jsonParser)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (intercalate)
import Data.Foreign (ForeignError, Foreign, readString)
import Data.Generic (class Generic)
import Global (encodeURIComponent)
import Network.HTTP.Affjax (AffjaxResponse)
import Network.HTTP.StatusCode (StatusCode(..))
import Servant.PureScript.Affjax (AjaxError(DecodingError, ParsingError, UnexpectedHTTPStatus))
import Servant.PureScript.Settings (SPSettings_(SPSettings_))
import Unsafe.Coerce (unsafeCoerce)

getResult :: forall a m. (Generic a, MonadError AjaxError m) => (Json -> Either String a) -> AffjaxResponse String -> m a
getResult decode resp = do
  let stCode = case resp.status of StatusCode code -> code
  fVal <- if stCode >= 200 && stCode < 300
            then pure resp.response
            else throwError $ UnexpectedHTTPStatus resp
  jVal <- throwLeft <<< lmap (reportError ParsingError fVal) <<< jsonParser $ fVal
  throwLeft <<< lmap (reportError DecodingError (show jVal)) <<< decode $ jVal

throwLeft :: forall a e m. MonadError e m => Either e a -> m a
throwLeft (Left e) = throwError e
throwLeft (Right a) = pure a

-- encodeListQuery :: forall a b. Generic a => Settings b -> String -> Array a -> String
encodeListQuery opts'@(SPSettings_ opts) fName = intercalate "&" <<< map (encodeQueryItem opts' fName)

-- | The given name is assumed to be already escaped.
-- encodeQueryItem :: forall a b. Generic a => SPSettings_ b -> String -> a -> String
encodeQueryItem opts'@(SPSettings_ opts) fName val = fName <> "=" <> encodeURLPiece opts' val

-- | Call opts.toURLPiece and encode the resulting string with encodeURIComponent.
-- toEscapedURLPiece :: forall a params. Generic a => SPSettings_ params -> a -> String
encodeURLPiece (SPSettings_ opts) = encodeURIComponent <<< unsafeCoerce opts.toURLPiece

reportError :: (String -> AjaxError) -> String -> String  -> AjaxError
reportError err source msg = err $ msg <> ", source: '" <> source <> "'"

module Servant.PureScript.Util where

import Prelude
import Control.Monad.Error.Class (class MonadError, throwError)
import Data.Argonaut.Core (Json)
import Data.Argonaut.Parser (jsonParser)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (intercalate)
import Data.Foreign (ForeignError, Foreign, readString)
import Data.Generic (class Generic)
import Global (encodeURIComponent)
import Network.HTTP.Affjax (AffjaxResponse)
import Network.HTTP.StatusCode (StatusCode(..))
import Servant.PureScript.Affjax (AjaxError(DecodingError, ParsingError, UnexpectedHTTPStatus))
import Servant.PureScript.Settings (SPSettings_(SPSettings_))
import Unsafe.Coerce (unsafeCoerce)

getResult :: forall a m. (Generic a, MonadError AjaxError m) => (Json -> Either String a) -> AffjaxResponse String -> m a
getResult decode resp = do
  let stCode = case resp.status of StatusCode code -> code
  fVal <- if stCode >= 200 && stCode < 300
            then pure resp.response
            else throwError $ UnexpectedHTTPStatus resp
  jVal <- throwLeft <<< lmap (reportError ParsingError fVal) <<< jsonParser $ fVal
  throwLeft <<< lmap (reportError DecodingError (show jVal)) <<< decode $ jVal

throwLeft :: forall a e m. MonadError e m => Either e a -> m a
throwLeft (Left e) = throwError e
throwLeft (Right a) = pure a

-- encodeListQuery :: forall a b. Generic a => Settings b -> String -> Array a -> String
encodeListQuery opts'@(SPSettings_ opts) fName = intercalate "&" <<< map (encodeQueryItem opts' fName)

-- | The given name is assumed to be already escaped.
-- encodeQueryItem :: forall a b. Generic a => SPSettings_ b -> String -> a -> String
encodeQueryItem (SPSettings_ opts) fName val = fName <> "=" <> (encodeURIComponent <<< unsafeCoerce opts.toURLPiece) val

reportError :: (String -> AjaxError) -> String -> String  -> AjaxError
reportError err source msg = err $ msg <> ", source: '" <> source <> "'"


add comments and complexity notes

add comments and complexity notes

-- | These functions allow PureScript strings to be treated as if they were
-- | sequences of Unicode code points instead of their true underlying
-- | implementation (sequences of UTF-16 code units). For nearly all uses of
-- | strings, these functions should be preferred over the ones in Data.String.
module Data.String.CodePoints
  ( module StringReExports
  , CodePoint()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  , count
  , drop
  , dropWhile
  , fromCodePointArray
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , length
  , singleton
  , splitAt
  , take
  , takeWhile
  , toCodePointArray
  , uncons
  ) where

import Prelude

import Data.Array as Array
import Data.Char as Char
import Data.List (List(Cons, Nil), fromFoldable)
import Data.Maybe (Maybe(Just, Nothing))
import Data.String as String
import Data.String.Unsafe as Unsafe
-- WARN: This list must be updated to re-export any exports added to Data.String. That makes me sad.
import Data.String (Pattern(..), Replacement(..), charAt, charCodeAt, contains, fromCharArray, joinWith, localeCompare, null, replace, replaceAll, split, stripPrefix, stripSuffix, toChar, toCharArray, toLower, toUpper, trim) as StringReExports
import Data.Tuple (Tuple(Tuple))
import Data.Unfoldable (unfoldr)

-- | CodePoint is an Int bounded between 0 and 0x10FFFF, corresponding to
-- | Unicode code points.
newtype CodePoint = CodePoint Int

derive instance eqCodePoint :: Eq CodePoint
derive instance ordCodePoint :: Ord CodePoint

-- I would prefer that this smart constructor not need to exist and instead
-- CodePoint just implements Enum, but the Enum module already depends on this
-- one. To avoid the circular dependency, we just expose these two functions.
codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

unsurrogate :: Int -> Int -> CodePoint
unsurrogate lead trail = CodePoint ((lead - 0xD800) * 0x400 + (trail - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

fromCharCode :: Int -> String
fromCharCode = String.singleton <<< Char.fromCharCode

-- WARN: this function expects the String parameter to be non-empty
unsafeCodePointAt0 :: String -> CodePoint
unsafeCodePointAt0 = _unsafeCodePointAt0 unsafeCodePointAt0Fallback

foreign import _unsafeCodePointAt0
  :: (String -> CodePoint)
  -> String
  -> CodePoint

unsafeCodePointAt0Fallback :: String -> CodePoint
unsafeCodePointAt0Fallback s =
  if isLead cu0 && isTrail cu1
     then unsurrogate cu0 cu1
     else CodePoint cu0
  where
    cu0 = Unsafe.charCodeAt 0 s
    cu1 = Unsafe.charCodeAt 1 s

-- | Returns the first code point of the string after dropping the given number
-- | of code points from the beginning, if there is such a code point. Operates
-- | in constant space and in time linear to `n`.
codePointAt :: Int -> String -> Maybe CodePoint
codePointAt 0 "" = Nothing
codePointAt 0 s = Just (unsafeCodePointAt0 s)
codePointAt n s = _codePointAt codePointAtFallback Just Nothing unsafeCodePointAt0 n s

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> (String -> CodePoint)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = Array.index (toCodePointArray s) n

-- | Returns the number of code points in the leading sequence of code points
-- | which all match the given predicate. Operates in constant space and in
-- | time linear to the length of the given string.
count :: (CodePoint -> Boolean) -> String -> Int
count = _count isLead isTrail unsurrogate

foreign import _count
  :: (Int -> Boolean)
  -> (Int -> Boolean)
  -> (Int -> Int -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

-- | Drops the given number of code points from the beginning of the given
-- | string. If the string does not have that many code points, returns the
-- | empty string. Operates in space and time linear to the length of the given
-- | string.
drop :: Int -> String -> String
drop n s = fromCodePointArray (Array.drop n (toCodePointArray s))

-- | Drops the leading sequence of code points which all match the given
-- | predicate from the given string. Operates in space and time linear to the
-- | length of the given string.
dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | Creates a string from an array of code points. Operates in space and time
-- | linear to the length of the given array.
fromCodePointArray :: Array CodePoint -> String
fromCodePointArray = _fromCodePointArray singletonFallback

foreign import _fromCodePointArray
  :: (CodePoint -> String)
  -> Array CodePoint
  -> String

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the given string. Returns Nothing when no matches are found.
indexOf :: String.Pattern -> String -> Maybe Int
indexOf p s = (\i -> length (String.take i s)) <$> String.indexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the given string. Pattern matches preceding the given index
-- | will be ignored. Returns Nothing when no matches are found.
indexOf' :: String.Pattern -> Int -> String -> Maybe Int
indexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (String.take k s')) <$> String.indexOf p s'

-- | Returns the number of code points preceding the last match of the given
-- | pattern in the given string. Returns Nothing when no matches are found.
lastIndexOf :: String.Pattern -> String -> Maybe Int
lastIndexOf p s = (\i -> length (String.take i s)) <$> String.lastIndexOf p s

-- | Returns the number of code points preceding the first match of the given
-- | pattern in the given string. Pattern matches following the given index
-- | will be ignored. Returns Nothing when no matches are found.
lastIndexOf' :: String.Pattern -> Int -> String -> Maybe Int
lastIndexOf' p i s =
  let i' = String.length (take i s) in
  (\k -> length (String.take k s)) <$> String.lastIndexOf' p i' s

-- | Returns the number of code points in the given string. Operates in
-- | constant space and time linear to the length of the string.
length :: String -> Int
length = Array.length <<< toCodePointArray

-- | Creates a string containing just the given code point. Operates in
-- | constant space and time.
singleton :: CodePoint -> String
singleton = _singleton singletonFallback

foreign import _singleton
  :: (CodePoint -> String)
  -> CodePoint
  -> String

singletonFallback :: CodePoint -> String
singletonFallback (CodePoint cp) | cp <= 0xFFFF = fromCharCode cp
singletonFallback (CodePoint cp) = fromCharCode lead <> fromCharCode trail
  where
    lead = ((cp - 0x10000) / 0x400) + 0xD800
    trail = (cp - 0x10000) `mod` 0x400 + 0xDC00

-- | Returns a record with strings created from the code points on either side
-- | of the given index. If the index is not within the string, Nothing is
-- | returned.
splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt i s =
  let cps = toCodePointArray s in
  if i < 0 || Array.length cps < i
    then Nothing
    else Just {
        before: fromCodePointArray (Array.take i cps),
        after: fromCodePointArray (Array.drop i cps)
      }

-- | Returns a string containing the given number of code points from the
-- | beginning of the given string. If the string does not have that many code
-- | points, returns the empty string. Operates in space and time linear to the
-- | given number.
take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n s = fromCodePointArray (Array.take n (toCodePointArray s))

-- | Returns a string containing the leading sequence of code points which all
-- | match the given predicate from the given string. Operates in space and
-- | time linear to the given number.
takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Creates an array of code points from a string. Operates in space and time
-- | linear to the length of the given string.
toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback unsafeCodePointAt0

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> (String -> CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr decode (fromFoldable (Char.toCharCode <$> String.toCharArray s))
  where
  decode :: List Int -> Maybe (Tuple CodePoint (List Int))
  decode (Cons cu0 (Cons cu1 rest)) | isLead cu0 && isTrail cu1
    = Just (Tuple (unsurrogate cu0 cu1) rest)
  decode (Cons cu rest) = Just (Tuple (CodePoint cu) rest)
  decode Nil = Nothing

-- | Returns a record with the first code point and the remaining code points
-- | of the given string. Returns Nothing if the string is empty. Operates in
-- | space and time linear to the length of the string.
uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s  = { head: _, tail: drop 1 s } <$> codePointAt 0 s

-- | These functions allow PureScript strings to be treated as if they were
-- | sequences of Unicode code points instead of their true underlying
-- | implementation (sequences of UTF-16 code units). For nearly all uses of
-- | strings, these functions should be preferred over the ones in Data.String.
module Data.String.CodePoints
  ( module StringReExports
  , CodePoint()
  , codePointAt
  , codePointFromInt
  , codePointToInt
  , count
  , drop
  , dropWhile
  , fromCodePointArray
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , length
  , singleton
  , splitAt
  , take
  , takeWhile
  , toCodePointArray
  , uncons
  ) where

import Prelude

import Data.Array as Array
import Data.Char as Char
import Data.List (List(Cons, Nil), fromFoldable)
import Data.Maybe (Maybe(Just, Nothing))
import Data.String as String
import Data.String.Unsafe as Unsafe
-- WARN: This list must be updated to re-export any exports added to Data.String. That makes me sad.
import Data.String (Pattern(..), Replacement(..), charAt, charCodeAt, contains, fromCharArray, joinWith, localeCompare, null, replace, replaceAll, split, stripPrefix, stripSuffix, toChar, toCharArray, toLower, toUpper, trim) as StringReExports
import Data.Tuple (Tuple(Tuple))
import Data.Unfoldable (unfoldr)

-- | CodePoint is an Int bounded between 0 and 0x10FFFF, corresponding to
-- | Unicode code points.
newtype CodePoint = CodePoint Int

derive instance eqCodePoint :: Eq CodePoint
derive instance ordCodePoint :: Ord CodePoint

-- I would prefer that this smart constructor not need to exist and instead
-- CodePoint just implements Enum, but the Enum module already depends on this
-- one. To avoid the circular dependency, we just expose these two functions.
codePointFromInt :: Int -> Maybe CodePoint
codePointFromInt n | 0 <= n && n <= 0x10FFFF = Just (CodePoint n)
codePointFromInt n = Nothing

codePointToInt :: CodePoint -> Int
codePointToInt (CodePoint n) = n

unsurrogate :: Int -> Int -> CodePoint
unsurrogate lead trail = CodePoint ((lead - 0xD800) * 0x400 + (trail - 0xDC00) + 0x10000)

isLead :: Int -> Boolean
isLead cu = 0xD800 <= cu && cu <= 0xDBFF

isTrail :: Int -> Boolean
isTrail cu = 0xDC00 <= cu && cu <= 0xDFFF

fromCharCode :: Int -> String
fromCharCode = String.singleton <<< Char.fromCharCode

unsafeCodePointAt0 :: String -> CodePoint
unsafeCodePointAt0 = _unsafeCodePointAt0 unsafeCodePointAt0Fallback

foreign import _unsafeCodePointAt0
  :: (String -> CodePoint)
  -> String
  -> CodePoint

unsafeCodePointAt0Fallback :: String -> CodePoint
unsafeCodePointAt0Fallback s =
  if isLead cu0 && isTrail cu1
     then unsurrogate cu0 cu1
     else CodePoint cu0
  where
    cu0 = Unsafe.charCodeAt 0 s
    cu1 = Unsafe.charCodeAt 1 s

codePointAt :: Int -> String -> Maybe CodePoint
codePointAt 0 "" = Nothing
codePointAt 0 s = Just (unsafeCodePointAt0 s)
codePointAt n s = _codePointAt codePointAtFallback Just Nothing unsafeCodePointAt0 n s

foreign import _codePointAt
  :: (Int -> String -> Maybe CodePoint)
  -> (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> (String -> CodePoint)
  -> Int
  -> String
  -> Maybe CodePoint

codePointAtFallback :: Int -> String -> Maybe CodePoint
codePointAtFallback n s = Array.index (toCodePointArray s) n

count :: (CodePoint -> Boolean) -> String -> Int
count = _count isLead isTrail unsurrogate

foreign import _count
  :: (Int -> Boolean)
  -> (Int -> Boolean)
  -> (Int -> Int -> CodePoint)
  -> (CodePoint -> Boolean)
  -> String
  -> Int

drop :: Int -> String -> String
drop n s = fromCodePointArray (Array.drop n (toCodePointArray s))

dropWhile :: (CodePoint -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

fromCodePointArray :: Array CodePoint -> String
fromCodePointArray = _fromCodePointArray singletonFallback

foreign import _fromCodePointArray
  :: (CodePoint -> String)
  -> Array CodePoint
  -> String

indexOf :: String.Pattern -> String -> Maybe Int
indexOf p s = (\i -> length (String.take i s)) <$> String.indexOf p s

indexOf' :: String.Pattern -> Int -> String -> Maybe Int
indexOf' p i s =
  let s' = drop i s in
  (\k -> i + length (String.take k s')) <$> String.indexOf p s'

lastIndexOf :: String.Pattern -> String -> Maybe Int
lastIndexOf p s = (\i -> length (String.take i s)) <$> String.lastIndexOf p s

lastIndexOf' :: String.Pattern -> Int -> String -> Maybe Int
lastIndexOf' p i s =
  let i' = String.length (take i s) in
  (\k -> length (String.take k s)) <$> String.lastIndexOf' p i' s

length :: String -> Int
length = Array.length <<< toCodePointArray

singleton :: CodePoint -> String
singleton = _singleton singletonFallback

foreign import _singleton
  :: (CodePoint -> String)
  -> CodePoint
  -> String

singletonFallback :: CodePoint -> String
singletonFallback (CodePoint cp) | cp <= 0xFFFF = fromCharCode cp
singletonFallback (CodePoint cp) = fromCharCode lead <> fromCharCode trail
  where
    lead = ((cp - 0x10000) / 0x400) + 0xD800
    trail = (cp - 0x10000) `mod` 0x400 + 0xDC00

splitAt :: Int -> String -> Maybe { before :: String, after :: String }
splitAt i s =
  let cps = toCodePointArray s in
  if i < 0 || Array.length cps < i
    then Nothing
    else Just {
        before: fromCodePointArray (Array.take i cps),
        after: fromCodePointArray (Array.drop i cps)
      }

take :: Int -> String -> String
take = _take takeFallback

foreign import _take :: (Int -> String -> String) -> Int -> String -> String

takeFallback :: Int -> String -> String
takeFallback n s = fromCodePointArray (Array.take n (toCodePointArray s))

takeWhile :: (CodePoint -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

toCodePointArray :: String -> Array CodePoint
toCodePointArray = _toCodePointArray toCodePointArrayFallback unsafeCodePointAt0

foreign import _toCodePointArray
  :: (String -> Array CodePoint)
  -> (String -> CodePoint)
  -> String
  -> Array CodePoint

toCodePointArrayFallback :: String -> Array CodePoint
toCodePointArrayFallback s = unfoldr decode (fromFoldable (Char.toCharCode <$> String.toCharArray s))
  where
  decode :: List Int -> Maybe (Tuple CodePoint (List Int))
  decode (Cons cu0 (Cons cu1 rest)) | isLead cu0 && isTrail cu1
    = Just (Tuple (unsurrogate cu0 cu1) rest)
  decode (Cons cu rest) = Just (Tuple (CodePoint cu) rest)
  decode Nil = Nothing

uncons :: String -> Maybe { head :: CodePoint, tail :: String }
uncons s  = { head: _, tail: drop 1 s } <$> codePointAt 0 s


Added items to mine level

Added items to mine level

module Level where

import Data.Char
import Data.String (String)
import qualified Data.String as S
import Data.Array ((..), (!!), updateAt, map, length)
import qualified Data.Array.Unsafe as U
import Data.Maybe
import GameData
import Utils
import Astar

data Tile = Air        | Water      | BrickWall
          | Ground     | Grass      | Wall      | SWall
          | DoorLocked | DoorClosed | DoorOpen
          | BgCave     | BgHouse
          | Bush       | Stairs
          | Trunk      | Leaves

data Level = Level
    { width  :: Number
    , height :: Number
    , tiles  :: [Tile]
    }

isTileSolid :: Tile -> Boolean
isTileSolid Ground     = true
isTileSolid Grass      = true
isTileSolid Wall       = true
isTileSolid BrickWall  = true
isTileSolid SWall      = true
isTileSolid DoorLocked = true
isTileSolid DoorClosed = true
isTileSolid _          = false

isTileTransparent :: Tile -> Boolean
isTileTransparent Ground     = false
isTileTransparent Grass      = false
isTileTransparent Wall       = false
isTileTransparent BrickWall  = false
isTileTransparent SWall      = false
isTileTransparent DoorLocked = false
isTileTransparent DoorClosed = false
isTileTransparent Bush       = false
isTileTransparent Water      = false
isTileTransparent Leaves     = false
isTileTransparent _          = true

isTileClimbable :: Tile -> Boolean
isTileClimbable Stairs     = true
isTileClimbable Water      = true
isTileClimbable DoorOpen   = true
isTileClimbable DoorClosed = true
isTileClimbable DoorLocked = true
isTileClimbable Leaves     = true
isTileClimbable _          = false

-- Calculates tile weights for pathfinding.
levelWeights :: Level -> [[Number]]
levelWeights l@(Level level) = do
    y <- 0 .. (level.height - 1)
    [makeRow y 0]
    where
        makeRow :: Number -> Number -> [Number]
        makeRow i x | x < level.width = tileWeight {x: x, y: i} : makeRow i (x + 1)
        makeRow i x | otherwise       = []

        tileWeight :: Point -> Number
        tileWeight p | canWalkOn p || canClimbOn p = 1
        tileWeight p | otherwise                   = 0

        getTile' :: Point -> Tile
        getTile' = fromMaybe Ground <<< getTile l

        canWalkOn :: Point -> Boolean
        canWalkOn p = blocked (p .+. {x:0, y:1}) && not (blocked p)

        canClimbOn :: Point -> Boolean
        canClimbOn = isTileClimbable <<< getTile'

        blocked :: Point -> Boolean
        blocked = blocksNpc <<< getTile'

        blocksNpc :: Tile -> Boolean
        blocksNpc DoorOpen   = false
        blocksNpc DoorClosed = false
        blocksNpc DoorLocked = false
        blocksNpc t = isTileSolid t

newLevel :: Number -> Number -> Level
newLevel w h = Level { width: w, height: h, tiles: replicate (w * h) Air }

emptyLevel :: Level
emptyLevel = Level { width: 0, height: 0, tiles: [] }

index :: Level -> Number -> Number -> Number
index (Level level) x y = x + y * level.width

getTile :: Level -> Point -> Maybe Tile
getTile l@(Level level) p | p.x >= 0 && p.y > 0 && p.x < level.width && p.y < level.height =
    level.tiles !! index l p.x p.y
getTile l@(Level level) p | p.y >= level.height = Just Ground
getTile l@(Level level) p | otherwise = Just Air

setTile :: Level -> Point -> Tile -> Level
setTile l@(Level level) p newTile =
    Level $ level { tiles = updateAt (index l p.x p.y) newTile level.tiles }

isValidMove :: Level -> Point -> Boolean
isValidMove level = not <<< isTileSolid <<< fromMaybe Air <<< getTile level

isTransparent :: Level -> Point -> Boolean
isTransparent level = isTileTransparent <<< fromMaybe Air <<< getTile level

isClimbable :: Level -> Point -> Boolean
isClimbable level = isTileClimbable <<< fromMaybe Air <<< getTile level

inFreeFall :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
inFreeFall level c = isValidMove level (c.pos .+. {x:0, y: 1}) || c.vel.y < 0

-- Returns all points inside level.
levelPoints :: Level -> [Point]
levelPoints (Level level) = do
    x' <- 0 .. (level.width - 1)
    y' <- 0 .. (level.height - 1)
    return {x: x', y: y'}

stringToLevel :: [String] -> Level
stringToLevel strs = Level $ { width: S.length (U.head strs), height: length strs, tiles: makeTiles strs }
    where
        makeTiles :: [String] -> [Tile]
        makeTiles (x:xs) = map charToTile (S.toCharArray x) ++ makeTiles xs
        makeTiles _      = []

        charToTile :: Char -> Tile
        charToTile c | c == makeChar "." = Air
        charToTile c | c == makeChar "#" = Ground
        charToTile c | c == makeChar "G" = Grass
        charToTile c | c == makeChar "S" = Wall
        charToTile c | c == makeChar "W" = SWall
        charToTile c | c == makeChar "$" = BrickWall
        charToTile c | c == makeChar "*" = DoorLocked
        charToTile c | c == makeChar "+" = DoorClosed
        charToTile c | c == makeChar "|" = DoorOpen
        charToTile c | c == makeChar "c" = BgCave
        charToTile c | c == makeChar "C" = BgHouse
        charToTile c | c == makeChar "B" = Bush
        charToTile c | c == makeChar "=" = Water
        charToTile c | c == makeChar "<" = Stairs
        charToTile c | c == makeChar "I" = Trunk
        charToTile c | c == makeChar "%" = Leaves
        charToTile _ = Air

type LevelDefinition =
    { name      :: String
    , plan      :: [String]
    , itemPos   :: [Point]
    , lootPos   :: [Point]
    , npcPos    :: [{ p :: Point, ctype :: CreatureType, ai :: AIState }]
    , startPos  :: Point
    }

allLevels :: [LevelDefinition]
allLevels = [{ name: "a small village"
             , plan: tutorialLevel
             , itemPos: [p 55 6, p 62 5, p 23 9]
             , lootPos: [p 40 9, p 48 9, p 64 9, p 66 9, p 21 9, p 22 9]
             , npcPos: [patrol (p 59 9)]
             , startPos: {x: 2, y: 7}}

            ,{ name: "a small castle"
             , plan: castleLevel
             , itemPos: [p 30 13, p 45 13, p 72 13, p 76 6, p 27 6]
             , lootPos: [p 24 10, p 24 13, p 39 16, p 69 13, p 70 13, p 71 13]
             , npcPos: [patrol (p 37 10), patrol (p 72 10), aIdle (p 76 3), aIdle (p 24 6)]
             , startPos: {x: 2, y: 15}}

            ,{ name: "a small town with clock tower"
             , plan: clockTower
             , itemPos: [p 31 14, p 24 9, p 29 2, p 43 14, p 56 17]
             , lootPos: [p 19 17, p 10 16, p 11 16, p 40 11, p 40 14, p 42 14, p 44 17]
             , npcPos: [aIdle (p 24 6), patrol (p 60 17), patrol (p 33 6)]
             , startPos: {x: 2, y: 15}}

            ,{ name: "a hidden pirate cove"
             , plan: pirateCove
             , itemPos: [p 34 14, p 25 14, p 30 11, p 35 11, p 78 13]
             , lootPos: [p 54 13, p 23 14, p 24 14, p 28 11, p 76 13, p 74 13]
             , npcPos: [patrol (p 77 13), patrol (p 46 13)]
             , startPos: {x: 3, y: 13}}

            ,{ name: "a mine enterance"
             , plan: mines
             , itemPos: [p 17 20, p 17 22, p 70 5, p 3 15, p 30 12, p 37 17, p 43 17]
             , lootPos: [p 59 21, p 5 24, p 7 24, p 37 2, p 74 5, p 72 5, p 27 10, p 4 10, p 6 10, p 18 15, p 37 22]
             , npcPos: [patrol (p 59 24), idler (p 28 15)]
             , startPos: {x: 6, y: 5}}]
    where
        p x y = {x: x, y: y}

        idler p' = { p: p', ctype: Guard, ai: Idle p' }
        patrol p' = { p: p', ctype: Guard, ai: Patrol p' }

        aIdle p' = { p: p', ctype: Archer, ai: Idle p' }

emptyLevel' :: [String]
emptyLevel' =
    ["................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"]

tutorialLevel :: [String]
tutorialLevel =
    ["................................................................................"
    ,"................................................................................"
    ,"...............................................................................S"
    ,"...............................................................................S"
    ,"..................................................SSSSSSS.................%%.. S"
    ,"...............................%................SSSCCCCCS................%%%%..S"
    ,"......................####....%%%...............I.+CCCCCS.....SSSSSSS...%%I%...S"
    ,"................B..GG#####....%I%%....SSSS*S..SSSSSSS<SSS.....SCCCCCS.....I....S"
    ,"#####GG..B......GGG##ccc###....I......SCCC<S..SCCCSCC<CCS.....SCCCCCS.....I....S"
    ,"#######GGGG===GG#####ccccccB.B.I..GG..*CCC<*..*CCC+CC<CC*.....*CCCCC*...B.IB...S"
    ,"###########===#############GGGGGGG##GGSSSSSSGGSSSSSSSSSSSGGGGGGGGGGGGGGGGGGGGGGG"
    ,"###########==###################################################################"
    ,"################################################################################"]

castleLevel :: [String]
castleLevel =
    ["...............................................................................$"
    ,"...............................................................................$"
    ,"...............................................................................$"
    ,"..........................................................................$....$"
    ,"..........................................................................$$$$*$"
    ,"...........................................................................$CC<$"
    ,"......................$.....$..............................................$CC<$"
    ,"......................$$$$+$$..............................................$$$+$"
    ,".......................$CC<$.....................$$$$$$$$$$$$$$$...........$CC<$"
    ,".......................$CC<$.....................$CCCCCCC$CCCCC$...........$CC<$"
    ,".......................$CC<*.....................*CCCCCCC+CCCCC*...........*CC<$"
    ,".......................$$$+$$$$$$*$$$$$$$$$$$$$$$$$$+$$$$$$$$$$$$$$$$$$$$$$$$$$$"
    ,"...................%...$CC<$CCCCC<CCCC$CCCCCCCCCC$CC<CCCC$CCCCCCCCCC$CCCCCC$CCC$"
    ,"..................%%%%.$CC<$CCCCC<CCCC+CCCCCCCCCC+CC<CCCC$CCCCCCCCCC$CCCCCC*CCC$"
    ,"..................%I%..$$$+$$$$$$$$$$$$$$$$$$$$$$$$$+$$$$$CCCCCCCCCC$$$$$$$$$$C$"
    ,"#..................I...$CC<$CCCCCCC$CCCCCC$CCCCCCCCC<CCCC$CCCCICICCC$CCCCCCCCC$$"
    ,"##G.B.......B......I...*CC<+CCCCCCC+CCCCCC*CCCCCCCCC<CCCC*CCCC$=$CCC*CCCCCCCC$$$"
    ,"###GG====GGGGGGGGGGGGGG$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$=$$$$$$$$$$$$$$$$"
    ,"######=======##################=======############ccccccc######=################"
    ,"#######================########=#####=#####=========#c#cc######=################"
    ,"#########====#########==========#####=======#########c##========################"
    ,"################################################################################"]

clockTower :: [String]
clockTower =
    ["......................................................................."
    ,"......................................................................."
    ,"......................................................................."
    ,"............................SSS........................................"
    ,"...........................SSSSS......................................."
    ,"..........................SSSSSSS......................................"
    ,"..........................I.....I......................................"
    ,".........................SSSS*SSSS....................................."
    ,"..........................ICC<CCI.....................................S"
    ,"..........................SCC<CCS.....................................S"
    ,"..........................SSS+SSS.....................................S"
    ,"..........................SCC<CCS.....................................S"
    ,"..........................SCC<CCS......SSSSSSS........................S"
    ,"............%.............ICC<CCI......SCCCCCS........................S"
    ,"...........%%%............SCC<CCS......SCCCCC*..S.....................S"
    ,"...........%I%...SSSS+SS..SSS+SSS......SSSSSSSSSSSS..SSSSSSSSSS.......S"
    ,"####........I....SCCC<CS..SCC<CCS......SCCCCCCCCCCS..SCCCCCCCCS.......S"
    ,"####......B.I....*CCC<C*..*CC<CC*......*CCCCCCCCCC*..*CCCCCCCC*....B..S"
    ,"########GGGGGG###################################################GGGGG#"
    ,"#######################################################################"]

pirateCove :: [String]
pirateCove =
    ["................................................................................"
    ,"................................................................................"
    ,".................................%.............................................."
    ,"................................%%%............................................I"
    ,"................................%I%............................................S"
    ,".................................I.....B......................................SS"
    ,".................................I.B..GGGG.....................................S"
    ,"............................B.GGGGGGGG#########.............................I..S"
    ,"............................GG#####################........................SSSSS"
    ,".........................###############################....................I..S"
    ,".......................####ccccc#cccc#ccc################......................S"
    ,"......................#####ccccc*cccc*ccccc##########ccc.......................S"
    ,"......................#####c#############ccccccc####cccc........I....I.........S"
    ,".....................##ccc##c##############ccccccc+cccccc.......SSSSSSCCCCCCCCCS"
    ,"####................###ccc+ccccccccccccc+cc#########SSSSSS==========SSSSSSSSSSSS"
    ,"#######...........################################========================SSSSSS"
    ,"###########======#################=============================================S"
    ,"#############======================#############################################"
    ,"################################################################################"]

mines :: [String]
mines =
    ["...................................#############################################"
    ,"........................%........%%#############################################"
    ,"...........%%..........%%%......%%%*cccccccccccccccccccccccccccccccccccccccccc##"
    ,"...........%%%........%%I%.....%%%%##########################################<##"
    ,"...........%I%..........I%......%I%##############cccc#################CCCCC##<##"
    ,"....B.......I.......B..BI........I.+ccccccccccccIccccIccccccccccccccc*CCCCC##<##"
    ,"GGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGG#################cc#######c#################<##"
    ,"#################################################cc########c#################<##"
    ,"########################################cccccccccc#########c#################<##"
    ,"####CCCC##################CCCC#################c<##########c####cc###########<##"
    ,"####CCCC*cccccccccccccccc*CCCC+ccccccccccccccccc<ccccccccccccccccccccccc#####<##"
    ,"###########<###################################c<##############ccc###########<##"
    ,"###cccccccc<##################ccccc#############cc##############c###cc#######<##"
    ,"####cc#####<######################cc#############ccccccccc########ccccc######<##"
    ,"###cc######<#####CCCC############cc###############cc########c######c#########<##"
    ,"###ccccccccccccc*CCCC+cccccccccccccccccccccccccccccccccccccccccccccc#########<##"
    ,"#######c##############################c######c#############cc################c##"
    ,"#######ccccccccccccccccccccccccc#####cc###cccccc#############################c##"
    ,"###############################c#############################################c##"
    ,"######c############cccccccccccccccc<<<<<cccccccccccccccccc*cccccccc*cccccccc*cc#"
    ,"#####ccc#########ccc################ccc#######################################<#"
    ,"####ccccc##########c################ccc#################ccccccc###############<#"
    ,"###IccCCcI#######cccccccccccc#######cccc###############cc#####cc##############<#"
    ,"##cIcCCcCIc########################cc#c###############cc#######cc#############<#"
    ,"#CCIccCCcIcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc<#"
    ,"################################################################################"]

module Level where

import Data.Char
import Data.String (String)
import qualified Data.String as S
import Data.Array ((..), (!!), updateAt, map, length)
import qualified Data.Array.Unsafe as U
import Data.Maybe
import GameData
import Utils
import Astar

data Tile = Air        | Water      | BrickWall
          | Ground     | Grass      | Wall      | SWall
          | DoorLocked | DoorClosed | DoorOpen
          | BgCave     | BgHouse
          | Bush       | Stairs
          | Trunk      | Leaves

data Level = Level
    { width  :: Number
    , height :: Number
    , tiles  :: [Tile]
    }

isTileSolid :: Tile -> Boolean
isTileSolid Ground     = true
isTileSolid Grass      = true
isTileSolid Wall       = true
isTileSolid BrickWall  = true
isTileSolid SWall      = true
isTileSolid DoorLocked = true
isTileSolid DoorClosed = true
isTileSolid _          = false

isTileTransparent :: Tile -> Boolean
isTileTransparent Ground     = false
isTileTransparent Grass      = false
isTileTransparent Wall       = false
isTileTransparent BrickWall  = false
isTileTransparent SWall      = false
isTileTransparent DoorLocked = false
isTileTransparent DoorClosed = false
isTileTransparent Bush       = false
isTileTransparent Water      = false
isTileTransparent Leaves     = false
isTileTransparent _          = true

isTileClimbable :: Tile -> Boolean
isTileClimbable Stairs     = true
isTileClimbable Water      = true
isTileClimbable DoorOpen   = true
isTileClimbable DoorClosed = true
isTileClimbable DoorLocked = true
isTileClimbable Leaves     = true
isTileClimbable _          = false

-- Calculates tile weights for pathfinding.
levelWeights :: Level -> [[Number]]
levelWeights l@(Level level) = do
    y <- 0 .. (level.height - 1)
    [makeRow y 0]
    where
        makeRow :: Number -> Number -> [Number]
        makeRow i x | x < level.width = tileWeight {x: x, y: i} : makeRow i (x + 1)
        makeRow i x | otherwise       = []

        tileWeight :: Point -> Number
        tileWeight p | canWalkOn p || canClimbOn p = 1
        tileWeight p | otherwise                   = 0

        getTile' :: Point -> Tile
        getTile' = fromMaybe Ground <<< getTile l

        canWalkOn :: Point -> Boolean
        canWalkOn p = blocked (p .+. {x:0, y:1}) && not (blocked p)

        canClimbOn :: Point -> Boolean
        canClimbOn = isTileClimbable <<< getTile'

        blocked :: Point -> Boolean
        blocked = blocksNpc <<< getTile'

        blocksNpc :: Tile -> Boolean
        blocksNpc DoorOpen   = false
        blocksNpc DoorClosed = false
        blocksNpc DoorLocked = false
        blocksNpc t = isTileSolid t

newLevel :: Number -> Number -> Level
newLevel w h = Level { width: w, height: h, tiles: replicate (w * h) Air }

emptyLevel :: Level
emptyLevel = Level { width: 0, height: 0, tiles: [] }

index :: Level -> Number -> Number -> Number
index (Level level) x y = x + y * level.width

getTile :: Level -> Point -> Maybe Tile
getTile l@(Level level) p | p.x >= 0 && p.y > 0 && p.x < level.width && p.y < level.height =
    level.tiles !! index l p.x p.y
getTile l@(Level level) p | p.y >= level.height = Just Ground
getTile l@(Level level) p | otherwise = Just Air

setTile :: Level -> Point -> Tile -> Level
setTile l@(Level level) p newTile =
    Level $ level { tiles = updateAt (index l p.x p.y) newTile level.tiles }

isValidMove :: Level -> Point -> Boolean
isValidMove level = not <<< isTileSolid <<< fromMaybe Air <<< getTile level

isTransparent :: Level -> Point -> Boolean
isTransparent level = isTileTransparent <<< fromMaybe Air <<< getTile level

isClimbable :: Level -> Point -> Boolean
isClimbable level = isTileClimbable <<< fromMaybe Air <<< getTile level

inFreeFall :: forall r. Level -> { pos :: Point, vel :: Point | r } -> Boolean
inFreeFall level c = isValidMove level (c.pos .+. {x:0, y: 1}) || c.vel.y < 0

-- Returns all points inside level.
levelPoints :: Level -> [Point]
levelPoints (Level level) = do
    x' <- 0 .. (level.width - 1)
    y' <- 0 .. (level.height - 1)
    return {x: x', y: y'}

stringToLevel :: [String] -> Level
stringToLevel strs = Level $ { width: S.length (U.head strs), height: length strs, tiles: makeTiles strs }
    where
        makeTiles :: [String] -> [Tile]
        makeTiles (x:xs) = map charToTile (S.toCharArray x) ++ makeTiles xs
        makeTiles _      = []

        charToTile :: Char -> Tile
        charToTile c | c == makeChar "." = Air
        charToTile c | c == makeChar "#" = Ground
        charToTile c | c == makeChar "G" = Grass
        charToTile c | c == makeChar "S" = Wall
        charToTile c | c == makeChar "W" = SWall
        charToTile c | c == makeChar "$" = BrickWall
        charToTile c | c == makeChar "*" = DoorLocked
        charToTile c | c == makeChar "+" = DoorClosed
        charToTile c | c == makeChar "|" = DoorOpen
        charToTile c | c == makeChar "c" = BgCave
        charToTile c | c == makeChar "C" = BgHouse
        charToTile c | c == makeChar "B" = Bush
        charToTile c | c == makeChar "=" = Water
        charToTile c | c == makeChar "<" = Stairs
        charToTile c | c == makeChar "I" = Trunk
        charToTile c | c == makeChar "%" = Leaves
        charToTile _ = Air

type LevelDefinition =
    { name      :: String
    , plan      :: [String]
    , itemPos   :: [Point]
    , lootPos   :: [Point]
    , npcPos    :: [{ p :: Point, ctype :: CreatureType, ai :: AIState }]
    , startPos  :: Point
    }

allLevels :: [LevelDefinition]
allLevels = [{ name: "a small village"
             , plan: tutorialLevel
             , itemPos: [p 55 6, p 62 5, p 23 9]
             , lootPos: [p 40 9, p 48 9, p 64 9, p 66 9, p 21 9, p 22 9]
             , npcPos: [patrol (p 59 9)]
             , startPos: {x: 2, y: 7}}

            ,{ name: "a small castle"
             , plan: castleLevel
             , itemPos: [p 30 13, p 45 13, p 72 13, p 76 6, p 27 6]
             , lootPos: [p 24 10, p 24 13, p 39 16, p 69 13, p 70 13, p 71 13]
             , npcPos: [patrol (p 37 10), patrol (p 72 10), aIdle (p 76 3), aIdle (p 24 6)]
             , startPos: {x: 2, y: 15}}

            ,{ name: "a small town with clock tower"
             , plan: clockTower
             , itemPos: [p 31 14, p 24 9, p 29 2, p 43 14, p 56 17]
             , lootPos: [p 19 17, p 10 16, p 11 16, p 40 11, p 40 14, p 42 14, p 44 17]
             , npcPos: [aIdle (p 24 6), patrol (p 60 17), patrol (p 33 6)]
             , startPos: {x: 2, y: 15}}

            ,{ name: "a hidden pirate cove"
             , plan: pirateCove
             , itemPos: [p 34 14, p 25 14, p 30 11, p 35 11, p 78 13]
             , lootPos: [p 54 13, p 23 14, p 24 14, p 28 11, p 76 13, p 74 13]
             , npcPos: [patrol (p 77 13), patrol (p 46 13)]
             , startPos: {x: 3, y: 13}}]
    where
        p x y = {x: x, y: y}

        idler p' = { p: p', ctype: Guard, ai: Idle p' }
        patrol p' = { p: p', ctype: Guard, ai: Patrol p' }

        aIdle p' = { p: p', ctype: Archer, ai: Idle p' }

emptyLevel' :: [String]
emptyLevel' =
    ["................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"
    ,"................................................................................"]

tutorialLevel :: [String]
tutorialLevel =
    ["................................................................................"
    ,"................................................................................"
    ,"...............................................................................S"
    ,"...............................................................................S"
    ,"..................................................SSSSSSS.................%%.. S"
    ,"...............................%................SSSCCCCCS................%%%%..S"
    ,"......................####....%%%...............I.+CCCCCS.....SSSSSSS...%%I%...S"
    ,"................B..GG#####....%I%%....SSSS*S..SSSSSSS<SSS.....SCCCCCS.....I....S"
    ,"#####GG..B......GGG##ccc###....I......SCCC<S..SCCCSCC<CCS.....SCCCCCS.....I....S"
    ,"#######GGGG===GG#####ccccccB.B.I..GG..*CCC<*..*CCC+CC<CC*.....*CCCCC*...B.IB...S"
    ,"###########===#############GGGGGGG##GGSSSSSSGGSSSSSSSSSSSGGGGGGGGGGGGGGGGGGGGGGG"
    ,"###########==###################################################################"
    ,"################################################################################"]

castleLevel :: [String]
castleLevel =
    ["...............................................................................$"
    ,"...............................................................................$"
    ,"...............................................................................$"
    ,"..........................................................................$....$"
    ,"..........................................................................$$$$*$"
    ,"...........................................................................$CC<$"
    ,"......................$.....$..............................................$CC<$"
    ,"......................$$$$+$$..............................................$$$+$"
    ,".......................$CC<$.....................$$$$$$$$$$$$$$$...........$CC<$"
    ,".......................$CC<$.....................$CCCCCCC$CCCCC$...........$CC<$"
    ,".......................$CC<*.....................*CCCCCCC+CCCCC*...........*CC<$"
    ,".......................$$$+$$$$$$*$$$$$$$$$$$$$$$$$$+$$$$$$$$$$$$$$$$$$$$$$$$$$$"
    ,"...................%...$CC<$CCCCC<CCCC$CCCCCCCCCC$CC<CCCC$CCCCCCCCCC$CCCCCC$CCC$"
    ,"..................%%%%.$CC<$CCCCC<CCCC+CCCCCCCCCC+CC<CCCC$CCCCCCCCCC$CCCCCC*CCC$"
    ,"..................%I%..$$$+$$$$$$$$$$$$$$$$$$$$$$$$$+$$$$$CCCCCCCCCC$$$$$$$$$$C$"
    ,"#..................I...$CC<$CCCCCCC$CCCCCC$CCCCCCCCC<CCCC$CCCCICICCC$CCCCCCCCC$$"
    ,"##G.B.......B......I...*CC<+CCCCCCC+CCCCCC*CCCCCCCCC<CCCC*CCCC$=$CCC*CCCCCCCC$$$"
    ,"###GG====GGGGGGGGGGGGGG$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$=$$$$$$$$$$$$$$$$"
    ,"######=======##################=======############ccccccc######=################"
    ,"#######================########=#####=#####=========#c#cc######=################"
    ,"#########====#########==========#####=======#########c##========################"
    ,"################################################################################"]

clockTower :: [String]
clockTower =
    ["......................................................................."
    ,"......................................................................."
    ,"......................................................................."
    ,"............................SSS........................................"
    ,"...........................SSSSS......................................."
    ,"..........................SSSSSSS......................................"
    ,"..........................I.....I......................................"
    ,".........................SSSS*SSSS....................................."
    ,"..........................ICC<CCI.....................................S"
    ,"..........................SCC<CCS.....................................S"
    ,"..........................SSS+SSS.....................................S"
    ,"..........................SCC<CCS.....................................S"
    ,"..........................SCC<CCS......SSSSSSS........................S"
    ,"............%.............ICC<CCI......SCCCCCS........................S"
    ,"...........%%%............SCC<CCS......SCCCCC*..S.....................S"
    ,"...........%I%...SSSS+SS..SSS+SSS......SSSSSSSSSSSS..SSSSSSSSSS.......S"
    ,"####........I....SCCC<CS..SCC<CCS......SCCCCCCCCCCS..SCCCCCCCCS.......S"
    ,"####......B.I....*CCC<C*..*CC<CC*......*CCCCCCCCCC*..*CCCCCCCC*....B..S"
    ,"########GGGGGG###################################################GGGGG#"
    ,"#######################################################################"]

pirateCove :: [String]
pirateCove =
    ["................................................................................"
    ,"................................................................................"
    ,".................................%.............................................."
    ,"................................%%%............................................I"
    ,"................................%I%............................................S"
    ,".................................I.....B......................................SS"
    ,".................................I.B..GGGG.....................................S"
    ,"............................B.GGGGGGGG#########.............................I..S"
    ,"............................GG#####################........................SSSSS"
    ,".........................###############################....................I..S"
    ,".......................####ccccc#cccc#ccc################......................S"
    ,"......................#####ccccc*cccc*ccccc##########ccc.......................S"
    ,"......................#####c#############ccccccc####cccc........I....I.........S"
    ,".....................##ccc##c##############ccccccc+cccccc.......SSSSSSCCCCCCCCCS"
    ,"####................###ccc+ccccccccccccc+cc#########SSSSSS==========SSSSSSSSSSSS"
    ,"#######...........################################========================SSSSSS"
    ,"###########======#################=============================================S"
    ,"#############======================#############################################"
    ,"################################################################################"]

mines :: [String]
mines =
    ["...................................#############################################"
    ,"........................%........%%#############################################"
    ,"...........%%..........%%%......%%%*cccccccccccccccccccccccccccccccccccccccccc##"
    ,"...........%%%........%%I%.....%%%%##########################################<##"
    ,"...........%I%..........I%......%I%##############cccc#################CCCCC##<##"
    ,"....B.......I.......B..BI........I.+ccccccccccccIccccIccccccccccccccc*CCCCC##<##"
    ,"GGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGG#################cc#######c#################<##"
    ,"#################################################cc########c#################<##"
    ,"########################################cccccccccc#########c#################<##"
    ,"####CCCC##################CCCC#################c<##########c####cc###########<##"
    ,"####CCCC*cccccccccccccccc*CCCC+ccccccccccccccccc<ccccccccccccccccccccccc#####<##"
    ,"###########<###################################c<##############ccc###########<##"
    ,"###cccccccc<##################ccccc#############cc##############c###cc#######<##"
    ,"####cc#####<######################cc#############ccccccccc########ccccc######<##"
    ,"###cc######<#####CCCC############cc###############cc########c######c#########<##"
    ,"###ccccccccccccc*CCCC+cccccccccccccccccccccccccccccccccccccccccccccc#########<##"
    ,"######################################c######c#############cc################c##"
    ,"#######ccccccccccccccccccccccccc#####cc###cccccc#############################c##"
    ,"###############################c#############################################c##"
    ,"######c############cccccccccccccccc<<<<<cccccccccccccccccc*cccccccc*cccccccc*cc#"
    ,"#####ccc#########ccc################ccc#######################################<#"
    ,"####ccccc##########c################ccc#################ccccccc###############<#"
    ,"###IccCCcI#######cccccccccccc#######cccc###############cc#####cc##############<#"
    ,"##cIcCCcCIc########################cc#c###############cc#######cc#############<#"
    ,"#CCIccCCcIcccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc<#"
    ,"################################################################################"]


Update for change in strings

Update for change in strings

-- | This module defines types and functions for working with _foreign_
-- | data.

module Foreign
  ( Foreign
  , ForeignError(..)
  , MultipleErrors(..)
  , F
  , renderForeignError
  , toForeign
  , unsafeFromForeign
  , unsafeReadTagged
  , typeOf
  , tagOf
  , isNull
  , isUndefined
  , isArray
  , readString
  , readChar
  , readBoolean
  , readNumber
  , readInt
  , readArray
  , readNull
  , readUndefined
  , readNullOrUndefined
  , fail
  ) where

import Prelude

import Control.Monad.Except (Except, throwError, mapExcept)

import Data.Either (Either(..), either)
import Data.Int as Int
import Data.List.NonEmpty (NonEmptyList)
import Data.List.NonEmpty as NEL
import Data.Maybe (Maybe(..), maybe)
import Data.String.CodeUnits (toChar)

-- | A type for _foreign data_.
-- |
-- | Foreign data is data from any external _unknown_ or _unreliable_
-- | source, for which it cannot be guaranteed that the runtime representation
-- | conforms to that of any particular type.
-- |
-- | Suitable applications of `Foreign` are
-- |
-- | - To represent responses from web services
-- | - To integrate with external JavaScript libraries.
foreign import data Foreign :: Type

-- | A type for foreign type errors
data ForeignError
  = ForeignError String
  | TypeMismatch String String
  | ErrorAtIndex Int ForeignError
  | ErrorAtProperty String ForeignError
  | JSONError String

derive instance eqForeignError :: Eq ForeignError
derive instance ordForeignError :: Ord ForeignError

instance showForeignError :: Show ForeignError where
  show (ForeignError msg) = "(ForeignError " <> show msg <> ")"
  show (ErrorAtIndex i e) = "(ErrorAtIndex " <> show i <> " " <> show e <> ")"
  show (ErrorAtProperty prop e) = "(ErrorAtProperty " <> show prop <> " " <> show e <> ")"
  show (JSONError s) = "(JSONError " <> show s <> ")"
  show (TypeMismatch exps act) = "(TypeMismatch " <> show exps <> " " <> show act <> ")"

-- | A type for accumulating multiple `ForeignError`s.
type MultipleErrors = NonEmptyList ForeignError

renderForeignError :: ForeignError -> String
renderForeignError (ForeignError msg) = msg
renderForeignError (ErrorAtIndex i e) = "Error at array index " <> show i <> ": " <> show e
renderForeignError (ErrorAtProperty prop e) = "Error at property " <> show prop <> ": " <> show e
renderForeignError (JSONError s) = "JSON error: " <> s
renderForeignError (TypeMismatch exp act) = "Type mismatch: expected " <> exp <> ", found " <> act

-- | An error monad, used in this library to encode possible failures when
-- | dealing with foreign data.
-- |
-- | The `Alt` instance for `Except` allows us to accumulate errors,
-- | unlike `Either`, which preserves only the last error.
type F = Except MultipleErrors

-- | Coerce any value to the a `Foreign` value.
foreign import toForeign :: forall a. a -> Foreign

-- | Unsafely coerce a `Foreign` value.
foreign import unsafeFromForeign :: forall a. Foreign -> a

-- | Read the Javascript _type_ of a value
foreign import typeOf :: Foreign -> String

-- | Read the Javascript _tag_ of a value.
-- |
-- | This function wraps the `Object.toString` method.
foreign import tagOf :: Foreign -> String

-- | Unsafely coerce a `Foreign` value when the value has a particular `tagOf`
-- | value.
unsafeReadTagged :: forall a. String -> Foreign -> F a
unsafeReadTagged tag value
  | tagOf value == tag = pure (unsafeFromForeign value)
  | otherwise = fail $ TypeMismatch tag (tagOf value)

-- | Test whether a foreign value is null
foreign import isNull :: Foreign -> Boolean

-- | Test whether a foreign value is undefined
foreign import isUndefined :: Foreign -> Boolean

-- | Test whether a foreign value is an array
foreign import isArray :: Foreign -> Boolean

-- | Attempt to coerce a foreign value to a `String`.
readString :: Foreign -> F String
readString = unsafeReadTagged "String"

-- | Attempt to coerce a foreign value to a `Char`.
readChar :: Foreign -> F Char
readChar value = mapExcept (either (const error) fromString) (readString value)
  where
  fromString = maybe error pure <<< toChar
  error = Left $ NEL.singleton $ TypeMismatch "Char" (tagOf value)

-- | Attempt to coerce a foreign value to a `Boolean`.
readBoolean :: Foreign -> F Boolean
readBoolean = unsafeReadTagged "Boolean"

-- | Attempt to coerce a foreign value to a `Number`.
readNumber :: Foreign -> F Number
readNumber = unsafeReadTagged "Number"

-- | Attempt to coerce a foreign value to an `Int`.
readInt :: Foreign -> F Int
readInt value = mapExcept (either (const error) fromNumber) (readNumber value)
  where
  fromNumber = maybe error pure <<< Int.fromNumber
  error = Left $ NEL.singleton $ TypeMismatch "Int" (tagOf value)

-- | Attempt to coerce a foreign value to an array.
readArray :: Foreign -> F (Array Foreign)
readArray value
  | isArray value = pure $ unsafeFromForeign value
  | otherwise = fail $ TypeMismatch "array" (tagOf value)

readNull :: Foreign -> F (Maybe Foreign)
readNull value
  | isNull value = pure Nothing
  | otherwise = pure (Just value)

readUndefined :: Foreign -> F (Maybe Foreign)
readUndefined value
  | isUndefined value = pure Nothing
  | otherwise = pure (Just value)

readNullOrUndefined :: Foreign -> F (Maybe Foreign)
readNullOrUndefined value
  | isNull value || isUndefined value = pure Nothing
  | otherwise = pure (Just value)

-- | Throws a failure error in `F`.
fail :: forall a. ForeignError -> F a
fail = throwError <<< NEL.singleton

-- | This module defines types and functions for working with _foreign_
-- | data.

module Foreign
  ( Foreign
  , ForeignError(..)
  , MultipleErrors(..)
  , F
  , renderForeignError
  , toForeign
  , unsafeFromForeign
  , unsafeReadTagged
  , typeOf
  , tagOf
  , isNull
  , isUndefined
  , isArray
  , readString
  , readChar
  , readBoolean
  , readNumber
  , readInt
  , readArray
  , readNull
  , readUndefined
  , readNullOrUndefined
  , fail
  ) where

import Prelude

import Control.Monad.Except (Except, throwError, mapExcept)

import Data.Either (Either(..), either)
import Data.Int as Int
import Data.List.NonEmpty (NonEmptyList)
import Data.List.NonEmpty as NEL
import Data.Maybe (Maybe(..), maybe)
import Data.String (toChar)

-- | A type for _foreign data_.
-- |
-- | Foreign data is data from any external _unknown_ or _unreliable_
-- | source, for which it cannot be guaranteed that the runtime representation
-- | conforms to that of any particular type.
-- |
-- | Suitable applications of `Foreign` are
-- |
-- | - To represent responses from web services
-- | - To integrate with external JavaScript libraries.
foreign import data Foreign :: Type

-- | A type for foreign type errors
data ForeignError
  = ForeignError String
  | TypeMismatch String String
  | ErrorAtIndex Int ForeignError
  | ErrorAtProperty String ForeignError
  | JSONError String

derive instance eqForeignError :: Eq ForeignError
derive instance ordForeignError :: Ord ForeignError

instance showForeignError :: Show ForeignError where
  show (ForeignError msg) = "(ForeignError " <> show msg <> ")"
  show (ErrorAtIndex i e) = "(ErrorAtIndex " <> show i <> " " <> show e <> ")"
  show (ErrorAtProperty prop e) = "(ErrorAtProperty " <> show prop <> " " <> show e <> ")"
  show (JSONError s) = "(JSONError " <> show s <> ")"
  show (TypeMismatch exps act) = "(TypeMismatch " <> show exps <> " " <> show act <> ")"

-- | A type for accumulating multiple `ForeignError`s.
type MultipleErrors = NonEmptyList ForeignError

renderForeignError :: ForeignError -> String
renderForeignError (ForeignError msg) = msg
renderForeignError (ErrorAtIndex i e) = "Error at array index " <> show i <> ": " <> show e
renderForeignError (ErrorAtProperty prop e) = "Error at property " <> show prop <> ": " <> show e
renderForeignError (JSONError s) = "JSON error: " <> s
renderForeignError (TypeMismatch exp act) = "Type mismatch: expected " <> exp <> ", found " <> act

-- | An error monad, used in this library to encode possible failures when
-- | dealing with foreign data.
-- |
-- | The `Alt` instance for `Except` allows us to accumulate errors,
-- | unlike `Either`, which preserves only the last error.
type F = Except MultipleErrors

-- | Coerce any value to the a `Foreign` value.
foreign import toForeign :: forall a. a -> Foreign

-- | Unsafely coerce a `Foreign` value.
foreign import unsafeFromForeign :: forall a. Foreign -> a

-- | Read the Javascript _type_ of a value
foreign import typeOf :: Foreign -> String

-- | Read the Javascript _tag_ of a value.
-- |
-- | This function wraps the `Object.toString` method.
foreign import tagOf :: Foreign -> String

-- | Unsafely coerce a `Foreign` value when the value has a particular `tagOf`
-- | value.
unsafeReadTagged :: forall a. String -> Foreign -> F a
unsafeReadTagged tag value
  | tagOf value == tag = pure (unsafeFromForeign value)
  | otherwise = fail $ TypeMismatch tag (tagOf value)

-- | Test whether a foreign value is null
foreign import isNull :: Foreign -> Boolean

-- | Test whether a foreign value is undefined
foreign import isUndefined :: Foreign -> Boolean

-- | Test whether a foreign value is an array
foreign import isArray :: Foreign -> Boolean

-- | Attempt to coerce a foreign value to a `String`.
readString :: Foreign -> F String
readString = unsafeReadTagged "String"

-- | Attempt to coerce a foreign value to a `Char`.
readChar :: Foreign -> F Char
readChar value = mapExcept (either (const error) fromString) (readString value)
  where
  fromString = maybe error pure <<< toChar
  error = Left $ NEL.singleton $ TypeMismatch "Char" (tagOf value)

-- | Attempt to coerce a foreign value to a `Boolean`.
readBoolean :: Foreign -> F Boolean
readBoolean = unsafeReadTagged "Boolean"

-- | Attempt to coerce a foreign value to a `Number`.
readNumber :: Foreign -> F Number
readNumber = unsafeReadTagged "Number"

-- | Attempt to coerce a foreign value to an `Int`.
readInt :: Foreign -> F Int
readInt value = mapExcept (either (const error) fromNumber) (readNumber value)
  where
  fromNumber = maybe error pure <<< Int.fromNumber
  error = Left $ NEL.singleton $ TypeMismatch "Int" (tagOf value)

-- | Attempt to coerce a foreign value to an array.
readArray :: Foreign -> F (Array Foreign)
readArray value
  | isArray value = pure $ unsafeFromForeign value
  | otherwise = fail $ TypeMismatch "array" (tagOf value)

readNull :: Foreign -> F (Maybe Foreign)
readNull value
  | isNull value = pure Nothing
  | otherwise = pure (Just value)

readUndefined :: Foreign -> F (Maybe Foreign)
readUndefined value
  | isUndefined value = pure Nothing
  | otherwise = pure (Just value)

readNullOrUndefined :: Foreign -> F (Maybe Foreign)
readNullOrUndefined value
  | isNull value || isUndefined value = pure Nothing
  | otherwise = pure (Just value)

-- | Throws a failure error in `F`.
fail :: forall a. ForeignError -> F a
fail = throwError <<< NEL.singleton


docs: Add documentation comments

docs: Add documentation comments

module Minimist
    ( Arg(..)
    , MinimistOptions
    , interpretAsStrings
    , interpretAsBooleans
    , aliases
    , defaults
    , stopEarly
    , splitOnDoubleDash
    , unknown
    , parseArgs
    ) where

import Prelude
import Control.Monad.Except (runExcept)
import Data.Either (Either(..), either, fromRight)
import Data.Foreign (Foreign, isArray, toForeign)
import Data.Foreign.Class (class IsForeign, read, readEitherL)
import Data.Functor.Contravariant ((>#<))
import Data.Options (Option, Options, opt, options)
import Data.StrMap (StrMap)
import Partial.Unsafe (unsafePartial)

-- | Phantom data type of options for the minimist parser
data MinimistOptions

-- | Array of strings to always be interpreted as strings
interpretAsStrings :: Option MinimistOptions (Array String)
interpretAsStrings = opt "strings"

-- | Array of strings to always be interpreted as booleans
-- | or a boolean value indicating that all options starting
-- | with `--` that don't contain an equals sign should be
-- | interpreted as booleans
interpretAsBooleans :: Option MinimistOptions (Either Boolean (Array String))
interpretAsBooleans = opt "boolean" >#< either toForeign toForeign

-- | Mapping of strings to a list of aliases for that option
aliases :: Option MinimistOptions (StrMap (Array String))
aliases = opt "alias"

-- | Mapping of strings to default argument values
defaults :: Option MinimistOptions (StrMap Arg)
defaults = opt "default" >#< (<$>) toForeignArg

-- | When `true`, argument parsing will stop at the first non-flag
stopEarly :: Option MinimistOptions Boolean
stopEarly = opt "stopEarly"

-- | When `true`, all options appearing after `--` will be placed
-- | into `--` instead of `_` in the result mapping
splitOnDoubleDash :: Option MinimistOptions Boolean
splitOnDoubleDash = opt "--"

-- | Function to be called with every argument not found in the
-- | configuration object. If the function retruns false, then the
-- | argument is not added to argv.
unknown :: Option MinimistOptions (String -> Boolean)
unknown = opt "unknown"

foreign import parseArgsForeign :: Array String -> Foreign -> StrMap Foreign

-- | Data type representing the value of an argument in `argv`
data Arg = ArgString String
         | ArgMulti (Array String)
         | ArgFlag Boolean

toForeignArg :: Arg -> Foreign
toForeignArg (ArgString s) = toForeign s
toForeignArg (ArgMulti a) = toForeign a
toForeignArg (ArgFlag b) = toForeign b

derive instance eqArg :: Eq Arg

instance showArg :: Show Arg where
    show (ArgString str) = str
    show (ArgMulti multi) = show multi
    show (ArgFlag flag) = show flag

instance argIsForeign :: IsForeign Arg where
    read value
        | isArray value = ArgMulti <$> read value
        | otherwise = readEitherL value <#> either ArgString ArgFlag

-- | Parse arguments with a set of minimist options into an `argv` representation,
-- | mapping argument names to `Arg` values.
parseArgs :: Array String -> Options MinimistOptions -> StrMap Arg
parseArgs args opts = (<$>) foreignToArg (parseArgsForeign args $ options opts) where
    foreignToArg :: Foreign -> Arg
    foreignToArg value = unsafePartial fromRight (runExcept $ read value)

module Minimist where

import Prelude
import Control.Monad.Except (runExcept)
import Data.Either (Either(..), fromRight)
import Data.Foreign (Foreign, isArray, toForeign)
import Data.Foreign.Class (class IsForeign, read, readEitherL)
import Data.Functor.Contravariant ((>#<))
import Data.Options (Option, Options, opt, options)
import Data.StrMap (StrMap)
import Partial.Unsafe (unsafePartial)

data MinimistOptions

interpretAsStrings :: Option MinimistOptions (Array String)
interpretAsStrings = opt "strings"

interpretAsBooleans :: Option MinimistOptions (Either Boolean (Array String))
interpretAsBooleans = opt "boolean" >#< \e ->
    case e of
      Left b -> toForeign b
      Right strs -> toForeign strs

aliases :: Option MinimistOptions (StrMap (Array String))
aliases = opt "alias"

defaults :: Option MinimistOptions (StrMap Arg)
defaults = opt "default" >#< (<$>) toForeignArg

stopEarly :: Option MinimistOptions Boolean
stopEarly = opt "stopEarly"

splitOnDoubleDash :: Option MinimistOptions Boolean
splitOnDoubleDash = opt "--"

unknown :: Option MinimistOptions (String -> Boolean)
unknown = opt "unknown"

foreign import parseArgsForeign :: Array String -> Foreign -> StrMap Foreign

data Arg = ArgString String
         | ArgMulti (Array String)
         | ArgFlag Boolean

toForeignArg :: Arg -> Foreign
toForeignArg (ArgString s) = toForeign s
toForeignArg (ArgMulti a) = toForeign a
toForeignArg (ArgFlag b) = toForeign b

derive instance eqArg :: Eq Arg

instance showArg :: Show Arg where
    show (ArgString str) = str
    show (ArgMulti multi) = show multi
    show (ArgFlag flag) = show flag

instance argIsForeign :: IsForeign Arg where
    read value
        | isArray value = ArgMulti <$> read value
        | otherwise = readEitherL value <#> \e ->
            case e of
              Left str -> ArgString str
              Right b -> ArgFlag b

parseArgs :: Array String -> Options MinimistOptions -> StrMap Arg
parseArgs args opts = (<$>) foreignToArg (parseArgsForeign args $ options opts) where
    foreignToArg :: Foreign -> Arg
    foreignToArg value = unsafePartial fromRight (runExcept $ read value)


Added documentation to available functions in package

module Mustache where

import Control.Monad.Eff (Eff())
import Data.StrMap (StrMap())
import Prelude (Show, Unit())

type Template = String

type Tag = String

type View = StrMap String

type Partials = StrMap String

type Token = Array TokenElement

foreign import data TokenElement :: *

foreign import showTokenElementImpl :: TokenElement -> String

instance showTokenElement :: Show TokenElement where
  show = showTokenElementImpl

-- | Effect that represents side effects within mustache.js.
-- |
-- | This is used to indicate caching that takes place within mustache.js.
foreign import data MustacheEffect :: !

-- | Name of the mustache.js dependency.
foreign import name :: String

-- | Version string as specified in mustache.js.
foreign import version :: String

-- | Default mustache.js tags (default: array with "{{" and "}}").
foreign import tags :: Array Tag

-- | Precompile a template and store parsed token in mustache.js's cache.
foreign import parse :: forall e. Template -> Array Tag -> Eff (mustache :: MustacheEffect | e) (Array Token)

-- | Render the template with the given view and partial templates.
foreign import render :: forall e. Template -> View -> Partials -> Eff (mustache :: MustacheEffect | e) String

-- | Escape various characters as HTML entities in the given string.
foreign import escape :: String -> String

-- | Clear the internal cache used by mustache.js.
foreign import clearCache :: forall e. Eff (mustache :: MustacheEffect | e) Unit

module Mustache where

import Control.Monad.Eff (Eff())
import Data.StrMap (StrMap())
import Prelude (Show, Unit())

type Template = String

type Tag = String

type View = StrMap String

type Partials = StrMap String

type Token = Array TokenElement

foreign import data TokenElement :: *

foreign import showTokenElementImpl :: TokenElement -> String

instance showTokenElement :: Show TokenElement where
  show = showTokenElementImpl

foreign import data MustacheEffect :: !

foreign import name :: String

foreign import version :: String

foreign import tags :: Array Tag

foreign import parse :: forall e. Template -> Array Tag -> Eff (mustache :: MustacheEffect | e) (Array Token)

foreign import render :: forall e. Template -> View -> Partials -> Eff (mustache :: MustacheEffect | e) String

foreign import escape :: String -> String

foreign import clearCache :: forall e. Eff (mustache :: MustacheEffect | e) Unit


Getter composition test case

Getter composition test case

module Main where

getX = (.x)

point = { x: 1, y: 0 }

main = do
  Debug.Trace.print $ getX point
  Debug.Trace.trace $ (." 123 string Prop Name ") { " 123 string Prop Name ": "OK" }
  Debug.Trace.trace $ ((.x) >>> (.y)) { x: { y: "Nested" } }
  Debug.Trace.trace $ (.value) { value: "Done!" }

module Main where

getX = (.x)

point = { x: 1, y: 0 }

main = do
  Debug.Trace.print $ getX point
  Debug.Trace.trace $ (." 123 string Prop Name ") { " 123 string Prop Name ": "OK" }
  Debug.Trace.trace $ (.value) { value: "Done!" }


better types for the messages

better types for the messages

module Models.Message where

import Models.User

type BaseMessage m = { from :: User, to :: User | m }

type TextMessage = BaseMessage (text :: String)

type CodeMessage = BaseMessage ()

type FormulaMessage = BaseMessage ()

type FileUpload = BaseMessage ()

data Message
	= TextMessage TextMessage
	| CodeMessage CodeMessage
	| FormulaMessage FormulaMessage
	| FileUpload FileUpload

module Models.Message where

type TextMessage =
	{
	}

type CodeMessage =
	{
	}

type FormulaMessage =
	{
	}

type FileUpload =
	{
	}

data Message
	= TextMessage TextMessage
	| CodeMessage CodeMessage
	| FormulaMessage FormulaMessage
	| FileUpload FileUpload


Fix prelude path location for executables

module Language.PureScript.Prelude where

import Node.Path

foreign import procFile
  "var procFile = require('fs').realpathSync(process.argv[1]);" :: String

preludeBaseDir :: String
preludeBaseDir = join (dirname procFile) "../prelude/"

preludeFiles :: [String]
preludeFiles =
  [ preludeBaseDir ++ "Prelude.purs"
  , preludeBaseDir ++ "Prelude/Unsafe.purs"
  , preludeBaseDir ++ "Control/Monad/Eff.purs"
  , preludeBaseDir ++ "Control/Monad/Eff/Unsafe.purs"
  , preludeBaseDir ++ "Control/Monad/ST.purs"
  , preludeBaseDir ++ "Data/Eq.purs"
  , preludeBaseDir ++ "Data/Function.purs"
  , preludeBaseDir ++ "Debug/Trace.purs"
  ]

module Language.PureScript.Prelude where

import Node.Path

foreign import procFile "var procFile = process.argv[1];" :: String

preludeBaseDir :: String
preludeBaseDir = join (dirname procFile) "../prelude/"

preludeFiles :: [String]
preludeFiles =
  [ preludeBaseDir ++ "Prelude.purs"
  , preludeBaseDir ++ "Prelude/Unsafe.purs"
  , preludeBaseDir ++ "Control/Monad/Eff.purs"
  , preludeBaseDir ++ "Control/Monad/Eff/Unsafe.purs"
  , preludeBaseDir ++ "Control/Monad/ST.purs"
  , preludeBaseDir ++ "Data/Eq.purs"
  , preludeBaseDir ++ "Data/Function.purs"
  , preludeBaseDir ++ "Debug/Trace.purs"
  ]