Rename some internal methods for clarity (Frozen => Immutable)

-- | Immutable buffers and associated operations.
module Node.Buffer
  ( class MutableBuffer
  , create
  , freeze
  , unsafeFreeze
  , thaw
  , unsafeThaw
  , fromArray
  , fromString
  , fromArrayBuffer
  , toArrayBuffer
  , read
  , readString
  , toString
  , write
  , writeString
  , toArray
  , getAtOffset
  , setAtOffset
  , slice
  , size
  , concat
  , concat'
  , copy
  , fill
  , Buffer
  , STBuffer
  , runST
  , module TypesExports
  ) where

import Prelude

import Control.Monad.ST (ST, kind Region)
import Control.Monad.ST as ST
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Maybe (Maybe)
import Effect (Effect)
import Node.Buffer.Immutable (ImmutableBuffer)
import Node.Buffer.Immutable as Immutable
import Node.Buffer.Types (BufferValueType, Octet, Offset)
import Node.Buffer.Types (BufferValueType(..), Octet, Offset) as TypesExports
import Node.Encoding (Encoding, encodingToNode)
import Unsafe.Coerce (unsafeCoerce)

-- | A type class for mutable buffers `buf` where operations on those buffers are
-- | represented by a particular monadic effect type `m`.
class Monad m <= MutableBuffer buf m | m -> buf, buf -> m where

  -- | Creates a new buffer of the specified size.
  create :: Int -> m buf

  -- | Creates an immutable copy of a mutable buffer.
  freeze :: buf -> m ImmutableBuffer

  -- | O(1). Convert a mutable buffer to an immutable buffer, without copying. The
  -- | mutable buffer must not be mutated afterwards.
  unsafeFreeze :: buf -> m ImmutableBuffer

  -- | Creates a mutable copy of an immutable buffer.
  thaw :: ImmutableBuffer -> m buf

  -- | O(1) Convert an immutable buffer to a mutable buffer, without copying. The
  -- | input buffer must not be used afterward.
  unsafeThaw :: ImmutableBuffer -> m buf

  -- | Creates a new buffer from an array of octets, sized to match the array.
  fromArray :: Array Octet -> m buf

  -- | Creates a new buffer from a string with the specified encoding, sized to
  -- | match the string.
  fromString :: String -> Encoding -> m buf

  -- | Creates a buffer view from a JS ArrayByffer without copying data.
  fromArrayBuffer :: ArrayBuffer -> m buf

  -- | Copies the data in the buffer to a new JS ArrayBuffer
  toArrayBuffer :: buf -> m ArrayBuffer

  -- | Reads a numeric value from a buffer at the specified offset.
  read :: BufferValueType -> Offset -> buf -> m Int

  -- | Reads a section of a buffer as a string with the specified encoding.
  readString :: Encoding -> Offset -> Offset -> buf -> m String

  -- | Reads the buffer as a string with the specified encoding.
  toString :: Encoding -> buf -> m String

  -- | Writes a numeric value to a buffer at the specified offset.
  write :: BufferValueType -> Int -> Offset -> buf -> m Unit

  -- | Writes octets from a string to a buffer at the specified offset. Multi-byte
  -- | characters will not be written to the buffer if there is not enough capacity
  -- | to write them fully. The number of bytes written is returned.
  writeString :: Encoding -> Offset -> Int -> String -> buf -> m Int

  -- | Creates an array of octets from a buffer's contents.
  toArray :: buf -> m (Array Octet)

  -- | Reads an octet from a buffer at the specified offset.
  getAtOffset :: Offset -> buf -> m (Maybe Octet)

  -- | Writes an octet in the buffer at the specified offset.
  setAtOffset :: Octet -> Offset -> buf -> m Unit

  -- | Creates a new buffer slice that acts like a window on the original buffer.
  -- | Writing to the slice buffer updates the original buffer and vice-versa.
  slice :: Offset -> Offset -> buf -> buf

  -- | Returns the size of a buffer.
  size :: buf -> m Int

  -- | Concatenates a list of buffers.
  concat :: Array buf -> m buf

  -- | Concatenates a list of buffers, combining them into a new buffer of the
  -- | specified length.
  concat' :: Array buf -> Int -> m buf

  -- | Copies a section of a source buffer into a target buffer at the specified
  -- | offset, and returns the number of octets copied.
  copy :: Offset -> Offset -> buf -> Offset -> buf -> m Int

  -- | Fills a range in a buffer with the specified octet.
  fill :: Octet -> Offset -> Offset -> buf -> m Unit

-- | A reference to a mutable buffer for use with `Effect`
foreign import data Buffer :: Type

-- | A reference to a mutable buffer for use with `ST`
-- |
-- | The type parameter represents the memory region which the buffer belongs to.
foreign import data STBuffer :: Region -> Type

-- | Runs an effect creating an `STBuffer` then freezes the buffer and returns
-- | it, without unneccessary copying.
runST :: (forall h. ST h (STBuffer h)) -> ImmutableBuffer
runST st = ST.run (st >>= unsafeFreeze)

instance mutableBufferEffect :: MutableBuffer Buffer Effect where
  create = createImpl
  freeze = copyAllImpl
  unsafeFreeze = unsafeFreezeImpl
  thaw = copyAllImpl
  unsafeThaw = unsafeThawImpl
  fromArray = fromArrayImpl
  fromString = fromStringImpl
  fromArrayBuffer = fromArrayBufferImpl
  toArrayBuffer = toArrayBufferImpl
  read = readImpl
  readString = readStringImpl
  toString = toStringImpl
  write = writeImpl
  writeString = writeStringImpl
  toArray = toArrayImpl
  getAtOffset = getAtOffsetImpl
  setAtOffset = setAtOffsetImpl
  slice = sliceImpl
  size = sizeImpl
  concat = concatImpl
  concat' = concatImpl'
  copy = copyImpl
  fill = fillImpl

instance mutableBufferST :: MutableBuffer (STBuffer h) (ST h) where
  create = createImpl
  freeze = copyAllImpl
  unsafeFreeze = unsafeFreezeImpl
  thaw = copyAllImpl
  unsafeThaw = unsafeThawImpl
  fromArray = fromArrayImpl
  fromString = fromStringImpl
  fromArrayBuffer = fromArrayBufferImpl
  toArrayBuffer = toArrayBufferImpl
  read = readImpl
  readString = readStringImpl
  toString = toStringImpl
  write = writeImpl
  writeString = writeStringImpl
  toArray = toArrayImpl
  getAtOffset = getAtOffsetImpl
  setAtOffset = setAtOffsetImpl
  slice = sliceImpl
  size = sizeImpl
  concat = concatImpl
  concat' = concatImpl'
  copy = copyImpl
  fill = fillImpl

unsafeFreezeImpl :: forall buf m. Monad m => buf -> m ImmutableBuffer
unsafeFreezeImpl = pure <<< unsafeCoerce

unsafeThawImpl :: forall buf m. Monad m => ImmutableBuffer -> m buf
unsafeThawImpl = pure <<< unsafeCoerce

usingFromImmutable :: forall buf m a. Monad m => (ImmutableBuffer -> a) -> buf -> m a
usingFromImmutable f buf = f <$> unsafeFreezeImpl buf

usingToImmutable :: forall buf m a. Monad m => (a -> ImmutableBuffer) -> a -> m buf
usingToImmutable f x = unsafeThawImpl $ f x

createImpl :: forall buf m. Monad m => Int -> m buf
createImpl = usingToImmutable Immutable.create

foreign import copyAllImpl :: forall a buf m. a -> m buf

fromArrayImpl :: forall buf m. Monad m => Array Octet -> m buf
fromArrayImpl = usingToImmutable Immutable.fromArray

fromStringImpl :: forall buf m. Monad m => String -> Encoding -> m buf
fromStringImpl s = usingToImmutable $ Immutable.fromString s

fromArrayBufferImpl :: forall buf m. Monad m => ArrayBuffer -> m buf
fromArrayBufferImpl = usingToImmutable Immutable.fromArrayBuffer

toArrayBufferImpl :: forall buf m. Monad m => buf -> m ArrayBuffer
toArrayBufferImpl = usingFromImmutable Immutable.toArrayBuffer

readImpl :: forall buf m. Monad m => BufferValueType -> Offset -> buf -> m Int
readImpl t o = usingFromImmutable $ Immutable.read t o

readStringImpl :: forall buf m. Monad m => Encoding -> Offset -> Offset -> buf -> m String
readStringImpl m o o' = usingFromImmutable $ Immutable.readString m o o'

toStringImpl :: forall buf m. Monad m => Encoding -> buf -> m String
toStringImpl m = usingFromImmutable $ Immutable.toString m

writeImpl :: forall buf m. Monad m => BufferValueType -> Int -> Offset -> buf -> m Unit
writeImpl = writeInternal <<< show

foreign import writeInternal :: forall buf m. String -> Int -> Offset -> buf -> m Unit

writeStringImpl :: forall buf m. Monad m => Encoding -> Offset -> Int -> String -> buf -> m Int
writeStringImpl = writeStringInternal <<< encodingToNode

foreign import writeStringInternal ::
  forall buf m. String -> Offset -> Int -> String -> buf -> m Int

toArrayImpl :: forall buf m. Monad m => buf -> m (Array Octet)
toArrayImpl = usingFromImmutable Immutable.toArray

getAtOffsetImpl :: forall buf m. Monad m => Offset -> buf -> m (Maybe Octet)
getAtOffsetImpl o = usingFromImmutable $ Immutable.getAtOffset o

foreign import setAtOffsetImpl :: forall buf m. Octet -> Offset -> buf -> m Unit

sliceImpl :: forall buf. Offset -> Offset -> buf -> buf
sliceImpl = unsafeCoerce Immutable.slice

sizeImpl :: forall buf m. Monad m => buf -> m Int
sizeImpl = usingFromImmutable Immutable.size

concatImpl :: forall buf m. Array buf -> m buf
concatImpl arrs = unsafeCoerce \_ -> Immutable.concat (unsafeCoerce arrs)

concatImpl' :: forall buf m. Monad m => Array buf -> Int -> m buf
concatImpl' arrs n = unsafeCoerce \_ -> Immutable.concat' (unsafeCoerce arrs) n

foreign import copyImpl :: forall buf m. Offset -> Offset -> buf -> Offset -> buf -> m Int

foreign import fillImpl :: forall buf m. Octet -> Offset -> Offset -> buf -> m Unit

-- | Immutable buffers and associated operations.
module Node.Buffer
  ( class MutableBuffer
  , create
  , freeze
  , unsafeFreeze
  , thaw
  , unsafeThaw
  , fromArray
  , fromString
  , fromArrayBuffer
  , toArrayBuffer
  , read
  , readString
  , toString
  , write
  , writeString
  , toArray
  , getAtOffset
  , setAtOffset
  , slice
  , size
  , concat
  , concat'
  , copy
  , fill
  , Buffer
  , STBuffer
  , runST
  , module TypesExports
  ) where

import Prelude

import Control.Monad.ST (ST, kind Region)
import Control.Monad.ST as ST
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Maybe (Maybe)
import Effect (Effect)
import Node.Buffer.Immutable (ImmutableBuffer)
import Node.Buffer.Immutable as Immutable
import Node.Buffer.Types (BufferValueType, Octet, Offset)
import Node.Buffer.Types (BufferValueType(..), Octet, Offset) as TypesExports
import Node.Encoding (Encoding, encodingToNode)
import Unsafe.Coerce (unsafeCoerce)

-- | A type class for mutable buffers `buf` where operations on those buffers are
-- | represented by a particular monadic effect type `m`.
class Monad m <= MutableBuffer buf m | m -> buf, buf -> m where

  -- | Creates a new buffer of the specified size.
  create :: Int -> m buf

  -- | Creates an immutable copy of a mutable buffer.
  freeze :: buf -> m ImmutableBuffer

  -- | O(1). Convert a mutable buffer to an immutable buffer, without copying. The
  -- | mutable buffer must not be mutated afterwards.
  unsafeFreeze :: buf -> m ImmutableBuffer

  -- | Creates a mutable copy of an immutable buffer.
  thaw :: ImmutableBuffer -> m buf

  -- | O(1) Convert an immutable buffer to a mutable buffer, without copying. The
  -- | input buffer must not be used afterward.
  unsafeThaw :: ImmutableBuffer -> m buf

  -- | Creates a new buffer from an array of octets, sized to match the array.
  fromArray :: Array Octet -> m buf

  -- | Creates a new buffer from a string with the specified encoding, sized to
  -- | match the string.
  fromString :: String -> Encoding -> m buf

  -- | Creates a buffer view from a JS ArrayByffer without copying data.
  fromArrayBuffer :: ArrayBuffer -> m buf

  -- | Copies the data in the buffer to a new JS ArrayBuffer
  toArrayBuffer :: buf -> m ArrayBuffer

  -- | Reads a numeric value from a buffer at the specified offset.
  read :: BufferValueType -> Offset -> buf -> m Int

  -- | Reads a section of a buffer as a string with the specified encoding.
  readString :: Encoding -> Offset -> Offset -> buf -> m String

  -- | Reads the buffer as a string with the specified encoding.
  toString :: Encoding -> buf -> m String

  -- | Writes a numeric value to a buffer at the specified offset.
  write :: BufferValueType -> Int -> Offset -> buf -> m Unit

  -- | Writes octets from a string to a buffer at the specified offset. Multi-byte
  -- | characters will not be written to the buffer if there is not enough capacity
  -- | to write them fully. The number of bytes written is returned.
  writeString :: Encoding -> Offset -> Int -> String -> buf -> m Int

  -- | Creates an array of octets from a buffer's contents.
  toArray :: buf -> m (Array Octet)

  -- | Reads an octet from a buffer at the specified offset.
  getAtOffset :: Offset -> buf -> m (Maybe Octet)

  -- | Writes an octet in the buffer at the specified offset.
  setAtOffset :: Octet -> Offset -> buf -> m Unit

  -- | Creates a new buffer slice that acts like a window on the original buffer.
  -- | Writing to the slice buffer updates the original buffer and vice-versa.
  slice :: Offset -> Offset -> buf -> buf

  -- | Returns the size of a buffer.
  size :: buf -> m Int

  -- | Concatenates a list of buffers.
  concat :: Array buf -> m buf

  -- | Concatenates a list of buffers, combining them into a new buffer of the
  -- | specified length.
  concat' :: Array buf -> Int -> m buf

  -- | Copies a section of a source buffer into a target buffer at the specified
  -- | offset, and returns the number of octets copied.
  copy :: Offset -> Offset -> buf -> Offset -> buf -> m Int

  -- | Fills a range in a buffer with the specified octet.
  fill :: Octet -> Offset -> Offset -> buf -> m Unit

-- | A reference to a mutable buffer for use with `Effect`
foreign import data Buffer :: Type

-- | A reference to a mutable buffer for use with `ST`
-- |
-- | The type parameter represents the memory region which the buffer belongs to.
foreign import data STBuffer :: Region -> Type

-- | Runs an effect creating an `STBuffer` then freezes the buffer and returns
-- | it, without unneccessary copying.
runST :: (forall h. ST h (STBuffer h)) -> ImmutableBuffer
runST st = ST.run (st >>= unsafeFreeze)

instance mutableBufferEffect :: MutableBuffer Buffer Effect where
  create = createImpl
  freeze = copyAllImpl
  unsafeFreeze = unsafeFreezeImpl
  thaw = copyAllImpl
  unsafeThaw = unsafeThawImpl
  fromArray = fromArrayImpl
  fromString = fromStringImpl
  fromArrayBuffer = fromArrayBufferImpl
  toArrayBuffer = toArrayBufferImpl
  read = readImpl
  readString = readStringImpl
  toString = toStringImpl
  write = writeImpl
  writeString = writeStringImpl
  toArray = toArrayImpl
  getAtOffset = getAtOffsetImpl
  setAtOffset = setAtOffsetImpl
  slice = sliceImpl
  size = sizeImpl
  concat = concatImpl
  concat' = concatImpl'
  copy = copyImpl
  fill = fillImpl

instance mutableBufferST :: MutableBuffer (STBuffer h) (ST h) where
  create = createImpl
  freeze = copyAllImpl
  unsafeFreeze = unsafeFreezeImpl
  thaw = copyAllImpl
  unsafeThaw = unsafeThawImpl
  fromArray = fromArrayImpl
  fromString = fromStringImpl
  fromArrayBuffer = fromArrayBufferImpl
  toArrayBuffer = toArrayBufferImpl
  read = readImpl
  readString = readStringImpl
  toString = toStringImpl
  write = writeImpl
  writeString = writeStringImpl
  toArray = toArrayImpl
  getAtOffset = getAtOffsetImpl
  setAtOffset = setAtOffsetImpl
  slice = sliceImpl
  size = sizeImpl
  concat = concatImpl
  concat' = concatImpl'
  copy = copyImpl
  fill = fillImpl

unsafeFreezeImpl :: forall buf m. Monad m => buf -> m ImmutableBuffer
unsafeFreezeImpl = pure <<< unsafeCoerce

unsafeThawImpl :: forall buf m. Monad m => ImmutableBuffer -> m buf
unsafeThawImpl = pure <<< unsafeCoerce

usingFromFrozen :: forall buf m a. Monad m => (ImmutableBuffer -> a) -> buf -> m a
usingFromFrozen f buf = f <$> unsafeFreezeImpl buf

usingToFrozen :: forall buf m a. Monad m => (a -> ImmutableBuffer) -> a -> m buf
usingToFrozen f x = unsafeThawImpl $ f x

createImpl :: forall buf m. Monad m => Int -> m buf
createImpl = usingToFrozen Immutable.create

foreign import copyAllImpl :: forall a buf m. a -> m buf

fromArrayImpl :: forall buf m. Monad m => Array Octet -> m buf
fromArrayImpl = usingToFrozen Immutable.fromArray

fromStringImpl :: forall buf m. Monad m => String -> Encoding -> m buf
fromStringImpl s = usingToFrozen $ Immutable.fromString s

fromArrayBufferImpl :: forall buf m. Monad m => ArrayBuffer -> m buf
fromArrayBufferImpl = usingToFrozen Immutable.fromArrayBuffer

toArrayBufferImpl :: forall buf m. Monad m => buf -> m ArrayBuffer
toArrayBufferImpl = usingFromFrozen Immutable.toArrayBuffer

readImpl :: forall buf m. Monad m => BufferValueType -> Offset -> buf -> m Int
readImpl t o = usingFromFrozen $ Immutable.read t o

readStringImpl :: forall buf m. Monad m => Encoding -> Offset -> Offset -> buf -> m String
readStringImpl m o o' = usingFromFrozen $ Immutable.readString m o o'

toStringImpl :: forall buf m. Monad m => Encoding -> buf -> m String
toStringImpl m = usingFromFrozen $ Immutable.toString m

writeImpl :: forall buf m. Monad m => BufferValueType -> Int -> Offset -> buf -> m Unit
writeImpl = writeInternal <<< show

foreign import writeInternal :: forall buf m. String -> Int -> Offset -> buf -> m Unit

writeStringImpl :: forall buf m. Monad m => Encoding -> Offset -> Int -> String -> buf -> m Int
writeStringImpl = writeStringInternal <<< encodingToNode

foreign import writeStringInternal ::
  forall buf m. String -> Offset -> Int -> String -> buf -> m Int

toArrayImpl :: forall buf m. Monad m => buf -> m (Array Octet)
toArrayImpl = usingFromFrozen Immutable.toArray

getAtOffsetImpl :: forall buf m. Monad m => Offset -> buf -> m (Maybe Octet)
getAtOffsetImpl o = usingFromFrozen $ Immutable.getAtOffset o

foreign import setAtOffsetImpl :: forall buf m. Octet -> Offset -> buf -> m Unit

sliceImpl :: forall buf. Offset -> Offset -> buf -> buf
sliceImpl = unsafeCoerce Immutable.slice

sizeImpl :: forall buf m. Monad m => buf -> m Int
sizeImpl = usingFromFrozen Immutable.size

concatImpl :: forall buf m. Array buf -> m buf
concatImpl arrs = unsafeCoerce \_ -> Immutable.concat (unsafeCoerce arrs)

concatImpl' :: forall buf m. Monad m => Array buf -> Int -> m buf
concatImpl' arrs n = unsafeCoerce \_ -> Immutable.concat' (unsafeCoerce arrs) n

foreign import copyImpl :: forall buf m. Offset -> Offset -> buf -> Offset -> buf -> m Int

foreign import fillImpl :: forall buf m. Octet -> Offset -> Offset -> buf -> m Unit


renamed local process to proc

renamed local process to proc

module Signal.Time
  ( Time(..)
  , every
  , millisecond
  , now
  , second
  ) where

import Control.Monad.Eff (Eff(..))
import Control.Timer (Timer(..))
import Data.Function
import Signal (constant, Signal(..))

type Time = Number

millisecond :: Time
millisecond = 1

second :: Time
second = 1000

foreign import everyP """
  function everyP(constant, now, t) {
    var out = constant(now());
    setInterval(function() {
      out.set(now());
    }, t);
    return out;
  }""" :: forall c e. Fn3 (c -> Signal c) (Eff (timer :: Timer | e) Time) Time (Signal Time)

every :: Time -> Signal Time
every = runFn3 everyP constant now

-- |Returns the number of milliseconds since an arbitrary, but constant, time in the past.
foreign import now """
  function now() {
    var perf = typeof performance !== 'undefined' ? performance : null,
        proc = typeof process !== 'undefined' ? process : null;
    return (
      perf && (perf.now || perf.webkitNow || perf.msNow || perf.oNow || perf.mozNow) ||
      (proc && proc.hrtime && function() {
        var t = proc.hrtime();
        return (t[0] * 1e9 + t[1]) / 1e6;
      }) ||
      Date.now
    ).call(perf);
  }""" :: forall e. Eff (timer :: Timer | e) Time

module Signal.Time
  ( Time(..)
  , every
  , millisecond
  , now
  , second
  ) where

import Control.Monad.Eff (Eff(..))
import Control.Timer (Timer(..))
import Data.Function
import Signal (constant, Signal(..))

type Time = Number

millisecond :: Time
millisecond = 1

second :: Time
second = 1000

foreign import everyP """
  function everyP(constant, now, t) {
    var out = constant(now());
    setInterval(function() {
      out.set(now());
    }, t);
    return out;
  }""" :: forall c e. Fn3 (c -> Signal c) (Eff (timer :: Timer | e) Time) Time (Signal Time)

every :: Time -> Signal Time
every = runFn3 everyP constant now

-- |Returns the number of milliseconds since an arbitrary, but constant, time in the past.
foreign import now """
  function now() {
    var perf = typeof performance !== 'undefined' ? performance : null,
        process = typeof process !== 'undefined' ? process : null;
    return (
      perf && (perf.now || perf.webkitNow || perf.msNow || perf.oNow || perf.mozNow) ||
      (process && process.hrtime && function() {
        var t = process.hrtime();
        return (t[0] * 1e9 + t[1]) / 1e6;
      }) ||
      Date.now
    ).call(perf);
  }""" :: forall e. Eff (timer :: Timer | e) Time


Fix _copyEff not to directly reference _copy

Fixes #19

--
-- Native Javascript maps which require the keys to be strings.
-- To maximize performance, Javascript objects are not wrapped,
-- and some native code is used even when it's not necessary.
--

module Data.StrMap
  ( StrMap(),
    empty,
    isEmpty,
    size,
    singleton,
    insert,
    lookup,
    toList,
    fromList,
    delete,
    member,
    alter,
    update,
    keys,
    values,
    union,
    unions,
    map,
    isSubmap,
    fold,
    foldMap,
    foldM,
    foldMaybe,
    all,

    thawST,
    freezeST,
    runST
  ) where

import qualified Prelude as P

import Control.Monad.Eff (Eff(), runPure)
import Data.Foldable (Foldable, foldl, foldr, for_)
import Data.Function
import Data.Maybe
import Data.Monoid
import Data.Monoid.All
import Data.Tuple
import Data.Traversable (Traversable, traverse)
import qualified Control.Monad.ST as ST
import qualified Data.Array as A
import qualified Data.StrMap.ST as SM

foreign import data StrMap :: * -> *

foreign import _copy
  """
  function _copy(m) {
    var r = {};
    for (var k in m) {
      r[k] = m[k];
    }
    return r;
  }
  """ :: forall a. StrMap a -> StrMap a

foreign import _copyEff
  """
  function _copyEff(m) {
    return function() {
      var r = {};
      for (var k in m) {
        r[k] = m[k];
      }
      return r;
    };
  }
  """ :: forall a b h r. a -> Eff (st :: ST.ST h | r) b

thawST :: forall a h r. StrMap a -> Eff (st :: ST.ST h | r) (SM.STStrMap h a)
thawST = _copyEff

freezeST :: forall a h r. SM.STStrMap h a -> Eff (st :: ST.ST h | r) (StrMap a)
freezeST = _copyEff

foreign import runST
  """
  function runST(f) {
    return f;
  }
  """ :: forall a r. (forall h. Eff (st :: ST.ST h | r) (SM.STStrMap h a)) -> Eff r (StrMap a)

pureST :: forall a b. (forall h e. Eff (st :: ST.ST h | e) (SM.STStrMap h a)) -> StrMap a
pureST f = runPure (runST f)

mutate :: forall a b. (forall h e. SM.STStrMap h a -> Eff (st :: ST.ST h | e) b) -> StrMap a -> StrMap a
mutate f m = pureST (do
  s <- thawST m
  f s
  P.return s)

foreign import _fmapStrMap
  """
  function _fmapStrMap(m0, f) {
    var m = {};
    for (var k in m0) {
      m[k] = f(m0[k]);
    }
    return m;
  }
  """ :: forall a b. Fn2 (StrMap a) (a -> b) (StrMap b)

instance functorStrMap :: P.Functor StrMap where
  (<$>) f m = runFn2 _fmapStrMap m f

foreign import _foldM
  """
  function _foldM(bind) {
    return function(f) {
      return function(mz) {
        return function(m) {
          var k;
          function g(z) {
            return f(z)(k)(m[k]);
          }
          for (k in m) {
            mz = bind(mz)(g);
          }
          return mz;
        };
      };
    };
  }
  """ :: forall a m z. (m -> (z -> m) -> m) -> (z -> String -> a -> m) -> m -> StrMap a -> m

fold :: forall a z. (z -> String -> a -> z) -> z -> StrMap a -> z
fold = _foldM (P.(#))

foldMap :: forall a m. (Monoid m) => (String -> a -> m) -> StrMap a -> m
foldMap f = fold (\acc k v -> acc P.<> f k v) mempty

foldM :: forall a m z. (P.Monad m) => (z -> String -> a -> m z) -> z -> StrMap a -> m z
foldM f z = _foldM P.(>>=) f (P.pure z)

instance foldableStrMap :: Foldable StrMap where
  foldl f = fold (\z _ -> f z)
  foldr f z m = foldr f z (values m)
  foldMap f = foldMap (P.const f)

instance traversableStrMap :: Traversable StrMap where
  traverse f ms = foldr (\x acc -> union P.<$> x P.<*> acc) (P.pure empty) ((P.(<$>) (uncurry singleton)) P.<$> (traverse f P.<$> toList ms))
  sequence = traverse P.id

-- Unfortunately the above are not short-circuitable (consider using purescript-machines)
-- so we need special cases:

foreign import _foldSCStrMap
  """
  function _foldSCStrMap(m, z, f, fromMaybe) {
    for (var k in m) {
      var maybeR = f(z)(k)(m[k]);
      var r = fromMaybe(null)(maybeR);
      if (r === null) return z;
      else z = r;
    }
    return z;
  }
  """ :: forall a z. Fn4 (StrMap a) z (z -> String -> a -> Maybe z) (forall a. a -> Maybe a -> a) z

foldMaybe :: forall a z. (z -> String -> a -> Maybe z) -> z -> StrMap a -> z
foldMaybe f z m = runFn4 _foldSCStrMap m z f fromMaybe

foreign import all
  """
  function all(f) {
    return function(m) {
      for (var k in m) {
        if (!f(k)(m[k])) return false;
      }
      return true;
    };
  }
  """ :: forall a. (String -> a -> Boolean) -> StrMap a -> Boolean

instance eqStrMap :: (P.Eq a) => P.Eq (StrMap a) where
  (==) m1 m2 = (isSubmap m1 m2) P.&& (isSubmap m2 m1)
  (/=) m1 m2 = P.not (m1 P.== m2)

instance showStrMap :: (P.Show a) => P.Show (StrMap a) where
  show m = "fromList " P.++ P.show (toList m)

foreign import empty "var empty = {};" :: forall a. StrMap a

isSubmap :: forall a. (P.Eq a) => StrMap a -> StrMap a -> Boolean
isSubmap m1 m2 = all f m1 where
  f k v = runFn4 _lookup false (P.(==) v) k m2

isEmpty :: forall a. StrMap a -> Boolean
isEmpty = all (\_ _ -> false)

foreign import size
  """
  function size(m) {
    var s = 0;
    for (var k in m) {
      ++s;
    }
    return s;
  }
  """ :: forall a. StrMap a -> Number

singleton :: forall a. String -> a -> StrMap a
singleton k v = pureST (do
  s <- SM.new
  SM.poke s k v
  P.return s)

foreign import _lookup
  """
  function _lookup(no, yes, k, m) {
    return k in m ? yes(m[k]) : no;
  }
  """ :: forall a z. Fn4 z (a -> z) String (StrMap a) z

lookup :: forall a. String -> StrMap a -> Maybe a
lookup = runFn4 _lookup Nothing Just

member :: forall a. String -> StrMap a -> Boolean
member = runFn4 _lookup false (P.const true)

insert :: forall a. String -> a -> StrMap a -> StrMap a
insert k v = mutate (\s -> SM.poke s k v)

foreign import _unsafeDeleteStrMap
  """
  function _unsafeDeleteStrMap(m, k) {
     delete m[k];
     return m;
  }
  """ :: forall a. Fn2 (StrMap a) String (StrMap a)

delete :: forall a. String -> StrMap a -> StrMap a
delete k = mutate (\s -> SM.delete s k)

alter :: forall a. (Maybe a -> Maybe a) -> String -> StrMap a -> StrMap a
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

update :: forall a. (a -> Maybe a) -> String -> StrMap a -> StrMap a
update f k m = alter (maybe Nothing f) k m

fromList :: forall a. [Tuple String a] -> StrMap a
fromList l = pureST (do
  s <- SM.new
  for_ l (\(Tuple k v) -> SM.poke s k v)
  P.return s)

foreign import _collect
  """
  function _collect(f) {
    return function(m) {
      var r = [];
      for (var k in m) {
        r.push(f(k)(m[k]));
      }
      return r;
    };
  }
  """ :: forall a b . (String -> a -> b) -> StrMap a -> [b]

toList :: forall a. StrMap a -> [Tuple String a]
toList = _collect Tuple

foreign import keys
  """
  var keys = Object.keys || _collect(function(k) {
    return function() { return k; };
  });
  """ :: forall a. StrMap a -> [String]

values :: forall a. StrMap a -> [a]
values = _collect (\_ v -> v)

-- left-biased
union :: forall a. StrMap a -> StrMap a -> StrMap a
union m = mutate (\s -> foldM SM.poke s m)

unions :: forall a. [StrMap a] -> StrMap a
unions = foldl union empty

map :: forall a b. (a -> b) -> StrMap a -> StrMap b
map = P.(<$>)

instance semigroupStrMap :: (P.Semigroup a) => P.Semigroup (StrMap a) where
  (<>) m1 m2 = mutate (\s -> foldM (\s k v2 -> SM.poke s k (runFn4 _lookup v2 (\v1 -> v1 P.<> v2) k m2)) s m1) m2

--
-- Native Javascript maps which require the keys to be strings.
-- To maximize performance, Javascript objects are not wrapped,
-- and some native code is used even when it's not necessary.
--

module Data.StrMap
  ( StrMap(),
    empty,
    isEmpty,
    size,
    singleton,
    insert,
    lookup,
    toList,
    fromList,
    delete,
    member,
    alter,
    update,
    keys,
    values,
    union,
    unions,
    map,
    isSubmap,
    fold,
    foldMap,
    foldM,
    foldMaybe,
    all,

    thawST,
    freezeST,
    runST
  ) where

import qualified Prelude as P

import Control.Monad.Eff (Eff(), runPure)
import Data.Foldable (Foldable, foldl, foldr, for_)
import Data.Function
import Data.Maybe
import Data.Monoid
import Data.Monoid.All
import Data.Tuple
import Data.Traversable (Traversable, traverse)
import qualified Control.Monad.ST as ST
import qualified Data.Array as A
import qualified Data.StrMap.ST as SM

foreign import data StrMap :: * -> *

foreign import _copy
  """
  function _copy(m) {
    var r = {};
    for (var k in m) {
      r[k] = m[k];
    }
    return r;
  }
  """ :: forall a. StrMap a -> StrMap a

foreign import _copyEff
  """
  function _copyEff(m) {
    return function() {
      return _copy(m);
    };
  }
  """ :: forall a b h r. a -> Eff (st :: ST.ST h | r) b

thawST :: forall a h r. StrMap a -> Eff (st :: ST.ST h | r) (SM.STStrMap h a)
thawST = _copyEff

freezeST :: forall a h r. SM.STStrMap h a -> Eff (st :: ST.ST h | r) (StrMap a)
freezeST = _copyEff

foreign import runST
  """
  function runST(f) {
    return f;
  }
  """ :: forall a r. (forall h. Eff (st :: ST.ST h | r) (SM.STStrMap h a)) -> Eff r (StrMap a)

pureST :: forall a b. (forall h e. Eff (st :: ST.ST h | e) (SM.STStrMap h a)) -> StrMap a
pureST f = runPure (runST f)

mutate :: forall a b. (forall h e. SM.STStrMap h a -> Eff (st :: ST.ST h | e) b) -> StrMap a -> StrMap a
mutate f m = pureST (do
  s <- thawST m
  f s
  P.return s)

foreign import _fmapStrMap
  """
  function _fmapStrMap(m0, f) {
    var m = {};
    for (var k in m0) {
      m[k] = f(m0[k]);
    }
    return m;
  }
  """ :: forall a b. Fn2 (StrMap a) (a -> b) (StrMap b)

instance functorStrMap :: P.Functor StrMap where
  (<$>) f m = runFn2 _fmapStrMap m f

foreign import _foldM
  """
  function _foldM(bind) {
    return function(f) {
      return function(mz) {
        return function(m) {
          var k;
          function g(z) {
            return f(z)(k)(m[k]);
          }
          for (k in m) {
            mz = bind(mz)(g);
          }
          return mz;
        };
      };
    };
  }
  """ :: forall a m z. (m -> (z -> m) -> m) -> (z -> String -> a -> m) -> m -> StrMap a -> m

fold :: forall a z. (z -> String -> a -> z) -> z -> StrMap a -> z
fold = _foldM (P.(#))

foldMap :: forall a m. (Monoid m) => (String -> a -> m) -> StrMap a -> m
foldMap f = fold (\acc k v -> acc P.<> f k v) mempty

foldM :: forall a m z. (P.Monad m) => (z -> String -> a -> m z) -> z -> StrMap a -> m z
foldM f z = _foldM P.(>>=) f (P.pure z)

instance foldableStrMap :: Foldable StrMap where
  foldl f = fold (\z _ -> f z)
  foldr f z m = foldr f z (values m)
  foldMap f = foldMap (P.const f)

instance traversableStrMap :: Traversable StrMap where
  traverse f ms = foldr (\x acc -> union P.<$> x P.<*> acc) (P.pure empty) ((P.(<$>) (uncurry singleton)) P.<$> (traverse f P.<$> toList ms))
  sequence = traverse P.id

-- Unfortunately the above are not short-circuitable (consider using purescript-machines)
-- so we need special cases:

foreign import _foldSCStrMap
  """
  function _foldSCStrMap(m, z, f, fromMaybe) {
    for (var k in m) {
      var maybeR = f(z)(k)(m[k]);
      var r = fromMaybe(null)(maybeR);
      if (r === null) return z;
      else z = r;
    }
    return z;
  }
  """ :: forall a z. Fn4 (StrMap a) z (z -> String -> a -> Maybe z) (forall a. a -> Maybe a -> a) z

foldMaybe :: forall a z. (z -> String -> a -> Maybe z) -> z -> StrMap a -> z
foldMaybe f z m = runFn4 _foldSCStrMap m z f fromMaybe

foreign import all
  """
  function all(f) {
    return function(m) {
      for (var k in m) {
        if (!f(k)(m[k])) return false;
      }
      return true;
    };
  }
  """ :: forall a. (String -> a -> Boolean) -> StrMap a -> Boolean

instance eqStrMap :: (P.Eq a) => P.Eq (StrMap a) where
  (==) m1 m2 = (isSubmap m1 m2) P.&& (isSubmap m2 m1)
  (/=) m1 m2 = P.not (m1 P.== m2)

instance showStrMap :: (P.Show a) => P.Show (StrMap a) where
  show m = "fromList " P.++ P.show (toList m)

foreign import empty "var empty = {};" :: forall a. StrMap a

isSubmap :: forall a. (P.Eq a) => StrMap a -> StrMap a -> Boolean
isSubmap m1 m2 = all f m1 where
  f k v = runFn4 _lookup false (P.(==) v) k m2

isEmpty :: forall a. StrMap a -> Boolean
isEmpty = all (\_ _ -> false)

foreign import size
  """
  function size(m) {
    var s = 0;
    for (var k in m) {
      ++s;
    }
    return s;
  }
  """ :: forall a. StrMap a -> Number

singleton :: forall a. String -> a -> StrMap a
singleton k v = pureST (do
  s <- SM.new
  SM.poke s k v
  P.return s)

foreign import _lookup
  """
  function _lookup(no, yes, k, m) {
    return k in m ? yes(m[k]) : no;
  }
  """ :: forall a z. Fn4 z (a -> z) String (StrMap a) z

lookup :: forall a. String -> StrMap a -> Maybe a
lookup = runFn4 _lookup Nothing Just

member :: forall a. String -> StrMap a -> Boolean
member = runFn4 _lookup false (P.const true)

insert :: forall a. String -> a -> StrMap a -> StrMap a
insert k v = mutate (\s -> SM.poke s k v)

foreign import _unsafeDeleteStrMap
  """
  function _unsafeDeleteStrMap(m, k) {
     delete m[k];
     return m;
  }
  """ :: forall a. Fn2 (StrMap a) String (StrMap a)

delete :: forall a. String -> StrMap a -> StrMap a
delete k = mutate (\s -> SM.delete s k)

alter :: forall a. (Maybe a -> Maybe a) -> String -> StrMap a -> StrMap a
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

update :: forall a. (a -> Maybe a) -> String -> StrMap a -> StrMap a
update f k m = alter (maybe Nothing f) k m

fromList :: forall a. [Tuple String a] -> StrMap a
fromList l = pureST (do
  s <- SM.new
  for_ l (\(Tuple k v) -> SM.poke s k v)
  P.return s)

foreign import _collect
  """
  function _collect(f) {
    return function(m) {
      var r = [];
      for (var k in m) {
        r.push(f(k)(m[k]));
      }
      return r;
    };
  }
  """ :: forall a b . (String -> a -> b) -> StrMap a -> [b]

toList :: forall a. StrMap a -> [Tuple String a]
toList = _collect Tuple

foreign import keys
  """
  var keys = Object.keys || _collect(function(k) {
    return function() { return k; };
  });
  """ :: forall a. StrMap a -> [String]

values :: forall a. StrMap a -> [a]
values = _collect (\_ v -> v)

-- left-biased
union :: forall a. StrMap a -> StrMap a -> StrMap a
union m = mutate (\s -> foldM SM.poke s m)

unions :: forall a. [StrMap a] -> StrMap a
unions = foldl union empty

map :: forall a b. (a -> b) -> StrMap a -> StrMap b
map = P.(<$>)

instance semigroupStrMap :: (P.Semigroup a) => P.Semigroup (StrMap a) where
  (<>) m1 m2 = mutate (\s -> foldM (\s k v2 -> SM.poke s k (runFn4 _lookup v2 (\v1 -> v1 P.<> v2) k m2)) s m1) m2


Fix #33

Fix #33

module Interactive where

import Data.Tuple
import Data.Maybe
import Data.Either
import Data.Array (map)
import Data.Foldable (foldl)
import Data.Traversable (for)
import Data.String (joinWith, indexOf, drop)

import qualified Data.Map as M

import Debug.Trace

import Control.Apply
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Control.Monad.Eff.Process
import Control.Monad.Eff.FS
import Control.Monad.Application
import Control.Monad.Error.Class

import Node.Args
import Node.ReadLine

import Language.PureScript
import Language.PureScript.Names
import Language.PureScript.Options
import Language.PureScript.Prelude
import Language.PureScript.Environment
import Language.PureScript.Pretty.Types (prettyPrintType)
import Language.PureScript.CodeGen.JS (RequirePathType(..))
import qualified Language.PureScript.Declarations as D

import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Language.PureScript.Parser.Lexer as P
import qualified Language.PureScript.Parser.Common as P
import qualified Language.PureScript.Parser.Declarations as P

-- |
-- Valid Meta-commands for PSCI
--
data Command
  -- |
  -- A purescript expression
  --
  = Eval D.Value
  -- |
  -- Show the help command
  --
  | Help
  -- |
  -- Import a module from a loaded file
  --
  | Import ModuleName
  -- |
  -- Load a file for use with importing
  --
  | LoadFile String
  -- |
  -- Exit PSCI
  --
  | Quit
  -- |
  -- Reset the state of the REPL
  --
  | Reset
  -- |
  -- Binds a value to a name
  --
  | Let (D.Value -> D.Value)
  -- |
  -- Find the type of an expression
  --
  | TypeOf D.Value

parse :: forall a. P.Parser P.TokenStream a -> String -> Either String a
parse p s = P.lex s >>= P.runTokenParser (p <* P.eof)

parseLet :: P.Parser P.TokenStream Command
parseLet = Let <$> (D.Let <$> (P.reserved "let" *> P.braces (P.many1 P.parseDeclaration)))

parseCommand :: String -> Either String Command
parseCommand ":?" = Right Help
parseCommand ":q" = Right Quit
parseCommand ":r" = Right Reset
parseCommand cmd | indexOf ":i " cmd == 0 = Import <$> parse P.moduleName (drop 3 cmd)
parseCommand cmd | indexOf ":m " cmd == 0 = Right $ LoadFile (drop 3 cmd)
parseCommand cmd | indexOf ":t " cmd == 0 = TypeOf <$> parse (P.parseValue unit) (drop 3 cmd)
parseCommand cmd | indexOf ":" cmd == 0 = Left "Unknown command. Type :? for help."
parseCommand cmd = parse (parseLet <|> (Eval <$> P.parseValue unit)) cmd

-- |
-- The PSCI state.
-- Holds a list of imported modules, loaded files, and partial let bindings.
-- The let bindings are partial,
-- because it makes more sense to apply the binding to the final evaluated expression.
--
type PSCIState = { loadedModules       :: [String]
                 , importedModuleNames :: [ModuleName]
                 , letBindings         :: [D.Value -> D.Value]
                 }

emptyPSCIState :: [String] -> PSCIState
emptyPSCIState files = { loadedModules       : files
                       , importedModuleNames : [ModuleName [ProperName "Prelude"]]
                       , letBindings         : []
                       }

defaultImports :: [ModuleName]
defaultImports = [ModuleName [ProperName "Prelude"]]

-- |
-- The help menu.
--
help :: String
help =
  "  :?            Show this help menu\n\
  \  :i <module>   Import <module> for use in PSCi\n\
  \  :m <file>     Load <file> for importing\n\
  \  :q            Quit PSCi\n\
  \  :r            Reset\n\
  \  :t <expr>     Show the type of <expr>"

moduleFromText :: String -> Either String D.Module
moduleFromText text = do
  tokens <- P.lex text
  P.runTokenParser P.parseModule tokens

-- |
-- Load a module from a file
--
loadModule :: forall eff. String -> Eff (fs :: FS | eff) (Either String D.Module)
loadModule filename = readFile filename moduleFromText (Left <<< getStackTrace)

loadModules :: [String] -> Application [Tuple String D.Module]
loadModules input =
  for input (\inputFile -> do
    text <- readFileApplication inputFile
    case moduleFromText text of
      Left err -> throwError err
      Right m -> return (Tuple inputFile m))

-- |
-- Makes a temporary module for the purposes of executing an expression
--
createTemporaryModule :: Boolean -> PSCIState -> D.Value -> D.Module
createTemporaryModule exec st value =
  let
    moduleName :: ModuleName
    moduleName = ModuleName [ProperName "Main"]

    replModule :: ModuleName
    replModule = ModuleName [ProperName "REPL"]

    evalPrint :: D.Value
    evalPrint = D.Var (Qualified (Just replModule) (Ident "evalPrint"))

    itValue :: D.Value
    itValue = foldl (\x f -> f x) value st.letBindings

    mainValue :: D.Value
    mainValue = D.App evalPrint (D.Var (Qualified Nothing (Ident "it")))

    importDecl :: ModuleName -> D.Declaration
    importDecl m = D.ImportDeclaration m Nothing Nothing

    itDecl :: D.Declaration
    itDecl = D.ValueDeclaration (Ident "it") Value [] Nothing itValue

    mainDecl :: D.Declaration
    mainDecl = D.ValueDeclaration (Ident "main") Value [] Nothing mainValue

    decls :: [D.Declaration]
    decls = if exec then [itDecl, mainDecl] else [itDecl]

    moduleBody :: [D.Declaration]
    moduleBody = map importDecl (replModule : st.importedModuleNames) ++ decls
  in
    D.Module moduleName moduleBody Nothing

-- |
-- Require statements use absolute paths to modules cached in the current directory
--
requireMode :: RequirePathType
requireMode = RequireAbsolute modulePath

modulePath :: String -> String
modulePath mn = modulesDir ++ "/" ++ mn ++ "/index.js"

foreign import homeDirectory
  "var homeDirectory = process.env['HOME'] || process.env['HOMEPATH'] || process.env['USERPROFILE'];" :: String

-- |
-- Directory which holds compiled modules
--
modulesDir :: String
modulesDir = homeDirectory ++ "/.purescript/psci/cache"

-- |
-- The REPL support module
--
replModule :: String
replModule = homeDirectory ++ "/.purescript/psci/modules/REPL.purs"

-- |
-- Compilation options
--
options :: Options
options = mkOptions false true false true Nothing true Nothing [] [] false

-- |
-- Takes a value and prints its type
--
handleTypeOf :: forall eff. PSCIState -> D.Value -> Eff (fs :: FS, trace :: Trace, process :: Process | eff) Unit
handleTypeOf st value = do
  let m = createTemporaryModule false st value
  e <- runApplication' do
    ms <- loadModules st.loadedModules
    make requireMode modulesDir options (ms ++ [Tuple "Main.purs" m])
  case e of
    Left err -> trace err
    Right (Environment env') ->
      case M.lookup (Tuple (ModuleName [ProperName "Main"]) (Ident "it")) env'.names of
        Just (Tuple ty _) -> trace $ prettyPrintType ty
        Nothing -> trace "Could not find type"

-- |
-- An effect for the 'eval' function
--
foreign import data Eval :: !

-- |
-- Evaluate some Javascript
--
foreign import evaluate
  "function evaluate(js) {\
  \  return function() {\
  \    eval(js);\
  \  };\
  \}" :: forall eff. String -> Eff (eval :: Eval | eff) Unit

-- |
-- Takes a value declaration and evaluates it with the current state.
--
handleEval :: forall eff. PSCIState -> D.Value -> Eff (fs :: FS, trace :: Trace, process :: Process, eval :: Eval | eff) Unit
handleEval st value = do
  let m = createTemporaryModule true st value
  e <- runApplication' do
    ms <- loadModules st.loadedModules
    make requireMode modulesDir options (ms ++ [Tuple "Main.purs" m])
  case e of
    Left err -> trace err
    Right _ -> evaluate $
      "(function() {\
      \  for (var k in require.cache) delete require.cache[k];\
      \  require(" ++ show (modulePath "Main") ++ ").main();\
      \})()"

prologueMessage :: String
prologueMessage =
  " ____                 ____            _       _   \n\
  \|  _ \\ _   _ _ __ ___/ ___|  ___ _ __(_)_ __ | |_ \n\
  \| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|\n\
  \|  __/| |_| | | |  __/___) | (__| |  | | |_) | |_ \n\
  \|_|    \\__,_|_|  \\___|____/ \\___|_|  |_| .__/ \\__|\n\
  \                                       |_|        \n\
  \\n\
  \:? shows help\n\
  \\n\
  \Expressions are terminated using Ctrl+D"

completion :: forall eff. RefVal PSCIState -> Completer (ref :: Ref | eff)
completion state s = return $ Tuple [] s

handleCommand :: [String] -> RefVal PSCIState -> Command -> Eff (fs :: FS, trace :: Trace, process :: Process, console :: Console, ref :: Ref, eval :: Eval) Unit
handleCommand _ _ Help = trace help
handleCommand _ _ Quit = trace "See ya!" *> exit 0
handleCommand _ state (TypeOf v) = do
  st <- readRef state
  handleTypeOf st v
handleCommand _ state (Eval v) = do
  st <- readRef state
  handleEval st v
handleCommand _ state (LoadFile filename) = do
  modifyRef state (\st -> st { loadedModules = st.loadedModules ++ [filename] })
  -- TODO: parse the module and store it
handleCommand _ state (Import mn) =
  modifyRef state (\st -> st { importedModuleNames = st.importedModuleNames ++ [mn] })
handleCommand initialFiles state Reset = writeRef state (emptyPSCIState initialFiles)
handleCommand _ state (Let f) =
  modifyRef state (\st -> st { letBindings = st.letBindings ++ [f] })

lineHandler :: [String] -> RefVal PSCIState -> String -> Eff (fs :: FS, trace :: Trace, process :: Process, console :: Console, ref :: Ref, eval :: Eval) Unit
lineHandler initialFiles state input =
  case parseCommand input of
    Left msg -> trace msg
    Right cmd -> handleCommand initialFiles state cmd

loop :: [String] -> Eff (fs :: FS, trace :: Trace, process :: Process, console :: Console, ref :: Ref, eval :: Eval) Unit
loop inputFiles = do
  let allModules = preludeFiles ++ [replModule] ++ inputFiles
  state <- newRef (emptyPSCIState allModules)
  interface <- createInterface process.stdin process.stdout (completion state)
  setPrompt "> " 2 interface
  prompt interface
  setLineHandler (\s -> lineHandler allModules state s <* prompt interface) interface
  return unit

inputFiles :: Args [String]
inputFiles = many argOnly

term :: Args (Eff (fs :: FS, trace :: Trace, process :: Process, console :: Console, ref :: Ref, eval :: Eval) Unit)
term = loop <$> inputFiles

main = do
  trace prologueMessage
  result <- readArgs' term
  case result of
    Left err -> print err
    _ -> return unit

module Interactive where

import Data.Tuple
import Data.Maybe
import Data.Either
import Data.Array (map)
import Data.Foldable (foldl)
import Data.Traversable (for)
import Data.String (joinWith, indexOf, drop)

import qualified Data.Map as M

import Debug.Trace

import Control.Apply
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Control.Monad.Eff.Process
import Control.Monad.Eff.FS
import Control.Monad.Application
import Control.Monad.Error.Class

import Node.Args
import Node.ReadLine

import Language.PureScript
import Language.PureScript.Names
import Language.PureScript.Options
import Language.PureScript.Prelude
import Language.PureScript.Environment
import Language.PureScript.Pretty.Types (prettyPrintType)
import Language.PureScript.CodeGen.JS (RequirePathType(..))
import qualified Language.PureScript.Declarations as D

import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Language.PureScript.Parser.Lexer as P
import qualified Language.PureScript.Parser.Common as P
import qualified Language.PureScript.Parser.Declarations as P

-- |
-- Valid Meta-commands for PSCI
--
data Command
  -- |
  -- A purescript expression
  --
  = Eval D.Value
  -- |
  -- Show the help command
  --
  | Help
  -- |
  -- Import a module from a loaded file
  --
  | Import ModuleName
  -- |
  -- Load a file for use with importing
  --
  | LoadFile String
  -- |
  -- Exit PSCI
  --
  | Quit
  -- |
  -- Reset the state of the REPL
  --
  | Reset
  -- |
  -- Binds a value to a name
  --
  | Let (D.Value -> D.Value)
  -- |
  -- Find the type of an expression
  --
  | TypeOf D.Value

parse :: forall a. P.Parser P.TokenStream a -> String -> Either String a
parse p s = P.lex s >>= P.runTokenParser (p <* P.eof)

parseLet :: P.Parser P.TokenStream Command
parseLet = Let <$> (D.Let <$> (P.reserved "let" *> P.braces (P.many1 P.parseDeclaration)))

parseCommand :: String -> Either String Command
parseCommand ":?" = Right Help
parseCommand ":q" = Right Quit
parseCommand ":r" = Right Reset
parseCommand cmd | indexOf ":i " cmd == 0 = Import <$> parse P.moduleName (drop 3 cmd)
parseCommand cmd | indexOf ":m " cmd == 0 = Right $ LoadFile (drop 3 cmd)
parseCommand cmd | indexOf ":t " cmd == 0 = TypeOf <$> parse (P.parseValue unit) (drop 3 cmd)
parseCommand cmd | indexOf ":" cmd == 0 = Left "Unknown command. Type :? for help."
parseCommand cmd = parse (parseLet <|> (Eval <$> P.parseValue unit)) cmd

-- |
-- The PSCI state.
-- Holds a list of imported modules, loaded files, and partial let bindings.
-- The let bindings are partial,
-- because it makes more sense to apply the binding to the final evaluated expression.
--
type PSCIState = { loadedModules       :: [String]
                 , importedModuleNames :: [ModuleName]
                 , letBindings         :: [D.Value -> D.Value]
                 }

emptyPSCIState :: [String] -> PSCIState
emptyPSCIState files = { loadedModules       : files
                       , importedModuleNames : [ModuleName [ProperName "Prelude"]]
                       , letBindings         : []
                       }

defaultImports :: [ModuleName]
defaultImports = [ModuleName [ProperName "Prelude"]]

-- |
-- The help menu.
--
help :: String
help =
  "  :?            Show this help menu\n\
  \  :i <module>   Import <module> for use in PSCi\n\
  \  :m <file>     Load <file> for importing\n\
  \  :q            Quit PSCi\n\
  \  :r            Reset\n\
  \  :t <expr>     Show the type of <expr>"

moduleFromText :: String -> Either String D.Module
moduleFromText text = do
  tokens <- P.lex text
  P.runTokenParser P.parseModule tokens

-- |
-- Load a module from a file
--
loadModule :: forall eff. String -> Eff (fs :: FS | eff) (Either String D.Module)
loadModule filename = readFile filename moduleFromText (Left <<< getStackTrace)

loadModules :: [String] -> Application [Tuple String D.Module]
loadModules input =
  for input (\inputFile -> do
    text <- readFileApplication inputFile
    case moduleFromText text of
      Left err -> throwError err
      Right m -> return (Tuple inputFile m))

-- |
-- Makes a temporary module for the purposes of executing an expression
--
createTemporaryModule :: Boolean -> PSCIState -> D.Value -> D.Module
createTemporaryModule exec st value =
  let
    moduleName :: ModuleName
    moduleName = ModuleName [ProperName "Main"]

    replModule :: ModuleName
    replModule = ModuleName [ProperName "REPL"]

    evalPrint :: D.Value
    evalPrint = D.Var (Qualified (Just replModule) (Ident "evalPrint"))

    itValue :: D.Value
    itValue = foldl (\x f -> f x) value st.letBindings

    mainValue :: D.Value
    mainValue = D.App evalPrint (D.Var (Qualified Nothing (Ident "it")))

    importDecl :: ModuleName -> D.Declaration
    importDecl m = D.ImportDeclaration m Nothing Nothing

    itDecl :: D.Declaration
    itDecl = D.ValueDeclaration (Ident "it") Value [] Nothing itValue

    mainDecl :: D.Declaration
    mainDecl = D.ValueDeclaration (Ident "main") Value [] Nothing mainValue

    decls :: [D.Declaration]
    decls = if exec then [itDecl, mainDecl] else [itDecl]

    moduleBody :: [D.Declaration]
    moduleBody = map importDecl (replModule : st.importedModuleNames) ++ decls
  in
    D.Module moduleName moduleBody Nothing

-- |
-- Require statements use absolute paths to modules cached in the current directory
--
requireMode :: RequirePathType
requireMode = RequireAbsolute modulePath

modulePath :: String -> String
modulePath mn = modulesDir ++ "/" ++ mn ++ "/index.js"

foreign import homeDirectory
  "var homeDirectory = process.env['HOME'] || process.env['HOMEPATH'] || process.env['USERPROFILE'];" :: String

-- |
-- Directory which holds compiled modules
--
modulesDir :: String
modulesDir = homeDirectory ++ "/.purescript/psci/cache"

-- |
-- The REPL support module
--
replModule :: String
replModule = homeDirectory ++ "/.purescript/psci/modules/REPL.purs"

-- |
-- Compilation options
--
options :: Options
options = mkOptions false true false true Nothing true Nothing [] [] false

-- |
-- Takes a value and prints its type
--
handleTypeOf :: forall eff. PSCIState -> D.Value -> Eff (fs :: FS, trace :: Trace, process :: Process | eff) Unit
handleTypeOf st value = do
  let m = createTemporaryModule false st value
  e <- runApplication' do
    ms <- loadModules st.loadedModules
    make requireMode modulesDir options (ms ++ [Tuple "Main.purs" m])
  case e of
    Left err -> trace err
    Right (Environment env') ->
      case M.lookup (Tuple (ModuleName [ProperName "Main"]) (Ident "it")) env'.names of
        Just (Tuple ty _) -> trace $ prettyPrintType ty
        Nothing -> trace "Could not find type"

-- |
-- An effect for the 'eval' function
--
foreign import data Eval :: !

-- |
-- Evaluate some Javascript
--
foreign import evaluate
  "function evaluate(js) {\
  \  return function() {\
  \    eval(js);\
  \  };\
  \}" :: forall eff. String -> Eff (eval :: Eval | eff) Unit

-- |
-- Takes a value declaration and evaluates it with the current state.
--
handleEval :: forall eff. PSCIState -> D.Value -> Eff (fs :: FS, trace :: Trace, process :: Process, eval :: Eval | eff) Unit
handleEval st value = do
  let m = createTemporaryModule true st value
  e <- runApplication' do
    ms <- loadModules st.loadedModules
    make requireMode modulesDir options (ms ++ [Tuple "Main.purs" m])
  case e of
    Left err -> trace err
    Right _ -> evaluate $ "(function() { require(" ++ show (modulePath "Main") ++ ").main(); })()"

prologueMessage :: String
prologueMessage =
  " ____                 ____            _       _   \n\
  \|  _ \\ _   _ _ __ ___/ ___|  ___ _ __(_)_ __ | |_ \n\
  \| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|\n\
  \|  __/| |_| | | |  __/___) | (__| |  | | |_) | |_ \n\
  \|_|    \\__,_|_|  \\___|____/ \\___|_|  |_| .__/ \\__|\n\
  \                                       |_|        \n\
  \\n\
  \:? shows help\n\
  \\n\
  \Expressions are terminated using Ctrl+D"

completion :: forall eff. RefVal PSCIState -> Completer (ref :: Ref | eff)
completion state s = return $ Tuple [] s

handleCommand :: [String] -> RefVal PSCIState -> Command -> Eff (fs :: FS, trace :: Trace, process :: Process, console :: Console, ref :: Ref, eval :: Eval) Unit
handleCommand _ _ Help = trace help
handleCommand _ _ Quit = trace "See ya!" *> exit 0
handleCommand _ state (TypeOf v) = do
  st <- readRef state
  handleTypeOf st v
handleCommand _ state (Eval v) = do
  st <- readRef state
  handleEval st v
handleCommand _ state (LoadFile filename) = do
  modifyRef state (\st -> st { loadedModules = st.loadedModules ++ [filename] })
  -- TODO: parse the module and store it
handleCommand _ state (Import mn) =
  modifyRef state (\st -> st { importedModuleNames = st.importedModuleNames ++ [mn] })
handleCommand initialFiles state Reset = writeRef state (emptyPSCIState initialFiles)
handleCommand _ state (Let f) =
  modifyRef state (\st -> st { letBindings = st.letBindings ++ [f] })

lineHandler :: [String] -> RefVal PSCIState -> String -> Eff (fs :: FS, trace :: Trace, process :: Process, console :: Console, ref :: Ref, eval :: Eval) Unit
lineHandler initialFiles state input =
  case parseCommand input of
    Left msg -> trace msg
    Right cmd -> handleCommand initialFiles state cmd

loop :: [String] -> Eff (fs :: FS, trace :: Trace, process :: Process, console :: Console, ref :: Ref, eval :: Eval) Unit
loop inputFiles = do
  let allModules = preludeFiles ++ [replModule] ++ inputFiles
  state <- newRef (emptyPSCIState allModules)
  interface <- createInterface process.stdin process.stdout (completion state)
  setPrompt "> " 2 interface
  prompt interface
  setLineHandler (\s -> lineHandler allModules state s <* prompt interface) interface
  return unit

inputFiles :: Args [String]
inputFiles = many argOnly

term :: Args (Eff (fs :: FS, trace :: Trace, process :: Process, console :: Console, ref :: Ref, eval :: Eval) Unit)
term = loop <$> inputFiles

main = do
  trace prologueMessage
  result <- readArgs' term
  case result of
    Left err -> print err
    _ -> return unit