Added an 8-bit version for the main memory's implementation

module MainMem where

import Prelude
import Math
import Data.Sequence as S
import Data.Maybe
import Data.Int.Bits
import Data.Array as A

import Types

-- 8 Bit version

cleanMainMem :: MainMem
cleanMainMem = MainMem $ S.fromFoldable $ A.replicate 65536 0

--NOTE replace all 'fromMaybe's with an error mechanism that will make it easy
--to trace Nothing cases

rd8 :: I16 -> MainMem -> I8
rd8 addr (MainMem mem) =
  fromMaybe 0 $ S.index addr mem

--NOTE make sure the significant byte part sits at a higher address
rd16 :: I16 -> MainMem -> I16
rd16 addr (MainMem mem) = (h `shl` 8) + l
 where
  l = fromMaybe 0 $ S.index addr mem
  h = fromMaybe 0 $ S.index (addr + 1) mem

wr8 :: I8 -> I16 -> MainMem -> MainMem
wr8 i8 addr (MainMem mem) = MainMem $ S.replace i8 addr mem

wr16 :: I16 -> I16 -> MainMem -> MainMem
wr16 i16 addr (MainMem mem) = MainMem $
      S.replace h (addr + 1)
  <<< S.replace l addr
   $  mem
 where
  h = 255 .&. (i16 `zshr` 8)
  l = 255 .&. i16

--16 Bit version

--NOTE consider splitting the mems to a generic number of chunks N
--that you can easily change, and then profile the performance for different N
--Or consider using array ST, if in need of better performance

--memory address
{--0 1 2 3 4 ...--}
{--0 0 1 1 2 ...--}
--seq index

{--the quotient is the index--}
{--the remainder is the offset inside the chunk--}
--Chunk size in bytes
{--chkSz :: Int--}
{--chkSz = 2--}

{--cleanMainMem :: MainMem--}
{--cleanMainMem = MainMem $ S.fromFoldable $ A.replicate size 0--}
 {--where--}
  {--size = 65536 / chkSz--}

{--rd8 :: I16 -> MainMem -> I8--}
{--rd8 addr (MainMem mem) = lsByteOf $--}
  {--(if isShiftNeeded then shiftByte else id) i16--}
 {--where--}
  {--isShiftNeeded = addr `mod` 2 == 0--}
  {--i16 = fromMaybe 0 $ S.index (addr / chkSz) mem--}
  {--shiftByte x = x `zshr` 8--}
  {--lsByteOf x = x .&. 255--}

{----NOTE replace all 'fromMaybe's with an error mechanism that will make it easy--}
{----to trace Nothing cases--}
{--rd16 :: I16 -> MainMem -> I16--}
{--rd16 addr (MainMem mem) = fromMaybe 0 $ S.index (addr / chkSz) mem--}

{--wr8 :: I8 -> I16 -> MainMem -> MainMem--}
{--wr8 i8 addr (MainMem mem) = MainMem $ S.adjust adjByte (addr / chkSz) mem--}
 {--where--}
  {--adjByte = (_ .|. i8') <<<--}
    {--(_ .&. if isShiftNeeded then 255 else 65535 - 255)--}
  {--i8' = (if isShiftNeeded then shiftByte else id) i8--}
  {--isShiftNeeded = addr `mod` 2 == 0--}
  {--shiftByte x = x `shl` 8--}

{--wr16 :: I16 -> I16 -> MainMem -> MainMem--}
{--wr16 i16 addr (MainMem mem) = MainMem $ S.replace i16 (addr / chkSz) mem--}

module MainMem where

import Prelude
import Math
import Data.Sequence as S
import Data.Maybe
import Data.Int.Bits
import qualified Data.Array as A

import Types

--NOTE consider splitting the mems to a generic number of chunks N
--that you can easily change, and then profile the performance for different N
--Or consider using array ST, if in need of better performance

--memory address
{--0 1 2 3 4 ...--}
{--0 0 1 1 2 ...--}
--seq index

{--the quotient is the index--}
{--the remainder is the offset inside the chunk--}
--Chunk size in bytes
chkSz :: Int
chkSz = 2

cleanMainMem :: MainMem
cleanMainMem = MainMem $ S.fromFoldable $ A.replicate size 0
 where
  size = 65536 / chkSz

rd8 :: I16 -> MainMem -> I8
rd8 addr (MainMem mem) = lsByteOf $
  (if isShiftNeeded then shiftByte else id) i16
 where
  isShiftNeeded = addr `mod` 2 == 0
  i16 = fromMaybe 0 $ S.index (addr / chkSz) mem
  shiftByte x = x `zshr` 8
  lsByteOf x = x .&. 255

--NOTE replace all 'fromMaybe's with an error mechanism that will make it easy
--to trace Nothing cases
rd16 :: I16 -> MainMem -> I16
rd16 addr (MainMem mem) = fromMaybe 0 $ S.index (addr / chkSz) mem

wr8 :: I8 -> I16 -> MainMem -> MainMem
wr8 i8 addr (MainMem mem) = MainMem $ S.adjust adjByte (addr / chkSz) mem
 where
  adjByte = (_ .|. i8') <<<
    (_ .&. if isShiftNeeded then 255 else 65535 - 255)
  i8' = (if isShiftNeeded then shiftByte else id) i8
  isShiftNeeded = addr `mod` 2 == 0
  shiftByte x = x `shl` 8

wr16 :: I16 -> I16 -> MainMem -> MainMem
wr16 i16 addr (MainMem mem) = MainMem $ S.replace i16 (addr / chkSz) mem


more tests and no need for fromJust in tests

module Main where

import Test.QuickCheck
import qualified Data.Array as A
import Data.Array.NonEmpty
import Data.Array.NonEmpty.Unsafe
import Data.Maybe

instance arbNonEmpty :: (Arbitrary a) => Arbitrary (NonEmpty a) where
  arbitrary = NonEmpty <$> arbitrary <*> arbitrary

qc :: String -> (NonEmpty Number -> Boolean) -> QC Unit
qc name f = do
    quickCheck (\x -> (f x) <?> name ++ " failed")
    return unit

qc_ll :: String -> (NonEmpty Number -> NonEmpty Number -> Boolean) -> QC Unit
qc_ll name f = do
    quickCheck (\x y -> (f x y) <?> name ++ " failed")
    return unit

qc_nl :: String -> (Number -> NonEmpty Number -> Boolean) -> QC Unit
qc_nl name f = do
    quickCheck (\x y -> (f x y) <?> name ++ " failed")
    return unit

main = do
    qc "Self equality" \x -> x == x
    qc "Inequality" \x -> x /= push 0 x
    qc "Length" \x -> length x == A.length (toArray x)
    qc "Pop - Length" \x -> A.length (pop x) == A.length (toArray x) - 1
    qc "Pop - Head" \(NonEmpty a as) -> let popped = pop (NonEmpty a as) in A.length popped == 0 || A.head popped == Just a
    qc "Take" \xs -> take (length xs) xs == toArray xs
    qc "Take 1" \xs -> A.head (take 1 xs) == Just (head xs)
    qc "Drop" \xs -> A.length (drop (length xs) xs) == 0
    qc "Drop 1" \xs -> drop 1 xs == tail xs
    qc "Reverse" \xs -> reverse (reverse xs) == xs
    qc "Reverse - Last" \xs -> last (reverse xs) == head xs
    qc_ll "Append - Length" \xs ys -> length (xs `append` ys) == length xs + length ys
    qc_nl "Cons - Length" \x xs -> length (x <| xs) == length xs + 1
    qc_nl "Cons - Head" \x xs -> head (x <| xs) == x
    qc_nl "Cons - Tail" \x xs -> tail (x <| xs) == toArray xs
    qc "Last" \(NonEmpty a as) -> let x = (NonEmpty a as) in (A.length as == 0 && last x == a) || (Just (last x) == A.last as)
    qc "nubBy" \xs -> xs == nubBy (==) (xs `append` xs)
    qc "functor - identity" \xs -> (\x -> x) <$> xs == xs
    qc "functor - composition" \xs -> ((+) 1) <$> ((+) 2) <$> xs == ((+) 3) <$> xs
    qc "fromArray" \(NonEmpty a as) -> fromArray (a:as) == (NonEmpty a as)

module Main where

import Test.QuickCheck
import qualified Data.Array as A
import Data.Array.NonEmpty
import Debug.Trace
import Data.Maybe.Unsafe

foreign import undefined :: forall a. a

instance arbNonEmpty :: (Arbitrary a) => Arbitrary (NonEmpty a) where
  arbitrary = NonEmpty <$> arbitrary <*> arbitrary

qc :: String -> (NonEmpty Number -> Boolean) -> QC Unit
qc name f = do
    quickCheck (\x -> (f x) <?> name ++ " failed")
    return unit

qc_ll :: String -> (NonEmpty Number -> NonEmpty Number -> Boolean) -> QC Unit
qc_ll name f = do
    quickCheck (\x y -> (f x y) <?> name ++ " failed")
    return unit

qc_nl :: String -> (Number -> NonEmpty Number -> Boolean) -> QC Unit
qc_nl name f = do
    quickCheck (\x y -> (f x y) <?> name ++ " failed")
    return unit

main = do
    qc "Self equality" \x -> x == x
    qc "Inequality" \x -> x /= push 0 x
    qc "Length" \x -> length x == A.length (toArray x)
    qc "Pop - Length" \x -> A.length (pop x) == A.length (toArray x) - 1
    qc "Pop - Head" \(NonEmpty a as) -> let popped = pop (NonEmpty a as) in A.length popped == 0 || (fromJust $ A.head popped) == a
    qc "Take" \xs -> take (length xs) xs == toArray xs
    qc "Drop" \xs -> A.length (drop (length xs) xs) == 0
    qc "Drop 1" \xs -> drop 1 xs == tail xs
    qc "Reverse" \xs -> reverse (reverse xs) == xs
    qc_ll "Append - Length" \xs ys -> length (xs `append` ys) == length xs + length ys
    qc_nl "Cons - Length" \x xs -> length (x <| xs) == length xs + 1
    qc_nl "Cons - Head" \x xs -> head (x <| xs) == x
    qc_nl "Cons - Tail" \x xs -> tail (x <| xs) == toArray xs
    qc "Last" \(NonEmpty a as) -> let x = (NonEmpty a as) in (A.length as == 0 && last x == a) || (last x == fromJust (A.last as))
    qc "nub" \xs -> xs == nub (xs `append` xs)
    qc "nubBy" \xs -> xs == nubBy (==) (xs `append` xs)
    qc "functor - identity" \xs -> (\x -> x) <$> xs == xs
    qc "functor - composition" \xs -> ((+) 1) <$> ((+) 2) <$> xs == ((+) 3) <$> xs


Remove Semigroup constraint on monadRecErrorT

module Control.Monad.Except.Trans where

import Prelude

import Control.Alt (Alt)
import Control.Alternative (Alternative)
import Control.Monad.Rec.Class (MonadRec, tailRecM)
import Control.Monad.Eff.Class (MonadEff, liftEff)
import Control.Monad.Trans
import Control.MonadPlus (MonadPlus)
import Control.Plus (Plus)
import Data.Either (Either(..), either)
import Data.Monoid (Monoid, mempty)

-- | A monad transformer which adds exceptions to other monads, in the same way
-- | as `Except`. As before, `e` is the type of exceptions, and `a` is the type
-- | of successful results. The new type parameter `m` is the inner monad that
-- | computations run in.
newtype ExceptT e m a = ExceptT (m (Either e a))

-- | The inverse of `ExceptT`. Run a computation in the `ExceptT` monad.
runExceptT :: forall e m a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT x) = x

-- | Transform any exceptions thrown by an `ExceptT` computation using the given function.
withExceptT :: forall e e' m a. (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT f = ExceptT <<< (<$>) (mapLeft f) <<< runExceptT
  where
  mapLeft _ (Right x) = Right x
  mapLeft f (Left x) = Left (f x)

-- | Transform the unwrapped computation using the given function.
mapExceptT :: forall e e' m n a b. (m (Either e a) -> n (Either e' b)) -> ExceptT e m a -> ExceptT e' n b
mapExceptT f m = ExceptT (f (runExceptT m))

instance functorExceptT :: (Functor m) => Functor (ExceptT e m) where
  map f = mapExceptT ((<$>) ((<$>) f))

instance applyExceptT :: (Apply m) => Apply (ExceptT e m) where
  apply (ExceptT f) (ExceptT x) =
    let f' = (<*>) <$> f
        x' = f' <*> x
    in ExceptT x'

instance applicativeExceptT :: (Applicative m) => Applicative (ExceptT e m) where
  pure = ExceptT <<< pure <<< Right

instance bindExceptT :: (Monad m) => Bind (ExceptT e m) where
  bind m k = ExceptT (runExceptT m >>=
                          either (return <<< Left) (runExceptT <<< k))

instance monadExceptT :: (Monad m) => Monad (ExceptT e m)

instance monadRecErrorT :: (MonadRec m) => MonadRec (ExceptT e m) where
  tailRecM f = ExceptT <<< tailRecM \a -> do
    m <- runExceptT (f a)
    return case m of
      Left e -> Right (Left e)
      Right (Left a1) -> Left a1
      Right (Right b) -> Right (Right b)

instance altExceptT :: (Semigroup e, Monad m) => Alt (ExceptT e m) where
  alt m n = ExceptT $ do
    rm <- runExceptT m
    case rm of
      Right x -> pure (Right x)
      Left err -> do
        rn <- runExceptT n
        case rn of
          Right x -> pure (Right x)
          Left err' -> pure (Left (err <> err'))

instance plusExceptT :: (Monoid e, Monad m) => Plus (ExceptT e m) where
  empty = throwE mempty

instance alternativeExceptT :: (Monoid e, Monad m) => Alternative (ExceptT e m)

instance monadPlusExceptT :: (Monoid e, Monad m) => MonadPlus (ExceptT e m)

instance monadTransExceptT :: MonadTrans (ExceptT e) where
  lift m = ExceptT $ do
    a <- m
    return $ Right a

instance monadEffExceptT :: (Monad m, MonadEff eff m) => MonadEff eff (ExceptT e m) where
  liftEff = lift <<< liftEff

-- | Throw an exception in an `ExceptT` computation.
throwE :: forall e m a. (Applicative m) => e -> ExceptT e m a
throwE = ExceptT <<< pure <<< Left

-- | Catch an exception in an `ExceptT` computation.
catchE :: forall e e' m a. (Monad m) => ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE m handler = ExceptT (runExceptT m >>= either (runExceptT <<< handler) (pure <<< Right))

module Control.Monad.Except.Trans where

import Prelude

import Control.Alt (Alt)
import Control.Alternative (Alternative)
import Control.Monad.Rec.Class (MonadRec, tailRecM)
import Control.Monad.Eff.Class (MonadEff, liftEff)
import Control.Monad.Trans
import Control.MonadPlus (MonadPlus)
import Control.Plus (Plus)
import Data.Either (Either(..), either)
import Data.Monoid (Monoid, mempty)

-- | A monad transformer which adds exceptions to other monads, in the same way
-- | as `Except`. As before, `e` is the type of exceptions, and `a` is the type
-- | of successful results. The new type parameter `m` is the inner monad that
-- | computations run in.
newtype ExceptT e m a = ExceptT (m (Either e a))

-- | The inverse of `ExceptT`. Run a computation in the `ExceptT` monad.
runExceptT :: forall e m a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT x) = x

-- | Transform any exceptions thrown by an `ExceptT` computation using the given function.
withExceptT :: forall e e' m a. (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT f = ExceptT <<< (<$>) (mapLeft f) <<< runExceptT
  where
  mapLeft _ (Right x) = Right x
  mapLeft f (Left x) = Left (f x)

-- | Transform the unwrapped computation using the given function.
mapExceptT :: forall e e' m n a b. (m (Either e a) -> n (Either e' b)) -> ExceptT e m a -> ExceptT e' n b
mapExceptT f m = ExceptT (f (runExceptT m))

instance functorExceptT :: (Functor m) => Functor (ExceptT e m) where
  map f = mapExceptT ((<$>) ((<$>) f))

instance applyExceptT :: (Apply m) => Apply (ExceptT e m) where
  apply (ExceptT f) (ExceptT x) =
    let f' = (<*>) <$> f
        x' = f' <*> x
    in ExceptT x'

instance applicativeExceptT :: (Applicative m) => Applicative (ExceptT e m) where
  pure = ExceptT <<< pure <<< Right

instance bindExceptT :: (Monad m) => Bind (ExceptT e m) where
  bind m k = ExceptT (runExceptT m >>=
                          either (return <<< Left) (runExceptT <<< k))

instance monadExceptT :: (Monad m) => Monad (ExceptT e m)

instance monadRecErrorT :: (Semigroup e, MonadRec m) => MonadRec (ExceptT e m) where
  tailRecM f = ExceptT <<< tailRecM \a -> do
    m <- runExceptT (f a)
    return case m of
      Left e -> Right (Left e)
      Right (Left a1) -> Left a1
      Right (Right b) -> Right (Right b)

instance altExceptT :: (Semigroup e, Monad m) => Alt (ExceptT e m) where
  alt m n = ExceptT $ do
    rm <- runExceptT m
    case rm of
      Right x -> pure (Right x)
      Left err -> do
        rn <- runExceptT n
        case rn of
          Right x -> pure (Right x)
          Left err' -> pure (Left (err <> err'))

instance plusExceptT :: (Monoid e, Monad m) => Plus (ExceptT e m) where
  empty = throwE mempty

instance alternativeExceptT :: (Monoid e, Monad m) => Alternative (ExceptT e m)

instance monadPlusExceptT :: (Monoid e, Monad m) => MonadPlus (ExceptT e m)

instance monadTransExceptT :: MonadTrans (ExceptT e) where
  lift m = ExceptT $ do
    a <- m
    return $ Right a

instance monadEffExceptT :: (Monad m, MonadEff eff m) => MonadEff eff (ExceptT e m) where
  liftEff = lift <<< liftEff

-- | Throw an exception in an `ExceptT` computation.
throwE :: forall e m a. (Applicative m) => e -> ExceptT e m a
throwE = ExceptT <<< pure <<< Left

-- | Catch an exception in an `ExceptT` computation.
catchE :: forall e e' m a. (Monad m) => ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE m handler = ExceptT (runExceptT m >>= either (runExceptT <<< handler) (pure <<< Right))


Fix constraints for listens/censor

Fix constraints for listens/censor

module Control.Monad.Writer.Class where

import Prelude
import Control.Monad.Writer.Trans
import Data.Monoid

class MonadWriter w m where
  writer :: forall a. WriterData a w -> m a
  listen :: forall a. m a -> m (WriterData a w)
  pass :: forall a. m { value :: a, output :: w -> w } -> m a

tell :: forall w m a. (Monoid w, Monad m, MonadWriter w m) => w -> m {}
tell w = writer { value: {}, output: w }

listens :: forall w m a b. (Monoid w, Monad m, MonadWriter w m) => (w -> b) -> m a -> m (WriterData a b)
listens f m = do
  { value = a, output = w } <- listen m
  return { value: a, output: f w }

censor :: forall w m a. (Monoid w, Monad m, MonadWriter w m) => (w -> w) -> m a -> m a
censor f m = pass $ do
  a <- m
  return { value: a, output: f }

instance monadWriterWriterT :: (Monoid w, Monad m) => MonadWriter w (WriterT w m) where
  writer = WriterT <<< return
  listen m = WriterT $ do
    { value = a, output = w } <- runWriterT m
    return { value: { value: a, output: w }, output: w }
  pass m = WriterT $ do
    { value = { value = a, output = f }, output = w } <- runWriterT m
    return { value: a, output: f w }

module Control.Monad.Writer.Class where

import Prelude
import Control.Monad.Writer.Trans
import Data.Monoid

class MonadWriter w m where
  writer :: forall a. WriterData a w -> m a
  listen :: forall a. m a -> m (WriterData a w)
  pass :: forall a. m { value :: a, output :: w -> w } -> m a

tell :: forall w m a. (Monoid w, Monad m, MonadWriter w m) => w -> m {}
tell w = writer { value: {}, output: w }

-- TODO: figure out how to make `listens` and `censor` work

{-listens :: forall w m a b. (MonadWriter w m) => (w -> b) -> m a -> m (WriterData a b)
listens f m = do
  { value = a, output = w } <- listen m
  return { value: a, output: f w }

censor :: forall w m a. (MonadWriter w m) => (w -> w) -> m a -> m a
censor f m = pass $ do
  a <- m
  return { value: a, output: f }-}

instance monadWriterWriterT :: (Monoid w, Monad m) => MonadWriter w (WriterT w m) where
  writer = WriterT <<< return
  listen m = WriterT $ do
    { value = a, output = w } <- runWriterT m
    return { value: { value: a, output: w }, output: w }
  pass m = WriterT $ do
    { value = { value = a, output = f }, output = w } <- runWriterT m
    return { value: a, output: f w }


Switch quit callback to Aff

Switch quit callback to Aff

module IdePurescript.PscIdeServer
  ( startServer
  , startServer'
  , stopServer
  , ServerStartResult(..)
  , ServerEff
  , Port
  , QuitCallback
  , ErrorLevel(..)
  , Notify(..)
  ) where

import Prelude
import PscIde.Server as S
import Control.Monad.Aff (Aff, attempt, liftEff')
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Data.Array (length, head)
import Data.Either (either)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.String (Pattern(Pattern), split, toLower, trim)
import Data.Traversable (traverse, traverse_)
import Global (readInt)
import IdePurescript.Exec (getPathVar, findBins)
import IdePurescript.PscIde (cwd) as PscIde
import Node.Buffer (BUFFER)
import Node.ChildProcess (CHILD_PROCESS, ChildProcess, stderr, stdout)
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.Path (normalize)
import Node.Platform (Platform(..))
import Node.Process (PROCESS, platform)
import Node.Stream (onDataString)
import PscIde (NET)
import PscIde.Server (Executable(Executable), getSavedPort, defaultServerArgs, savePort, pickFreshPort)

type Port = Int

data ServerStartResult =
    CorrectPath Port
  | WrongPath Port String
  | Started Port ChildProcess
  | Closed
  | StartError String

type ServerEff eff = (cp :: CHILD_PROCESS, process :: PROCESS, console :: CONSOLE, net :: NET, avar :: AVAR, fs :: FS, exception :: EXCEPTION, random :: RANDOM, buffer :: BUFFER | eff)

type QuitCallback eff = (Aff (net :: NET, cp :: CHILD_PROCESS, fs :: FS | eff) Unit)

data ErrorLevel = Success | Info | Warning | Error
type Notify eff = ErrorLevel -> String -> Eff eff Unit

data Version = Version Int Int Int

parseVersion :: String -> Maybe Version
parseVersion s =
  case traverse fromNumber $ readInt 10 <$> split (Pattern ".") s of
    Just [a, b, c] -> Just $ Version a b c
    _ -> Nothing

instance eqVersion :: Eq Version where
  eq (Version a b c) (Version a' b' c') = a == a' && b == b' && c == c'

instance ordVersion :: Ord Version where
  compare (Version a b c) (Version a' b' c') = compare [a,b,c] [a',b',c']

instance showVersion :: Show Version where
  show (Version a b c) = show a <> "." <> show b <> "." <> show c

-- | Start a psc-ide server instance, or find one already running on the expected port, checking if it has the right path.
-- | Will notify as to what is happening, choose to supply globs appropriately
startServer' :: forall eff eff'.
  String
  -> String
  -> Boolean
  -> Boolean
  -> Array String
  -> Notify (ServerEff eff)
  -> Notify (ServerEff eff)
  -> Aff (ServerEff eff) { quit :: QuitCallback eff', port :: Maybe Int }
startServer' path server addNpmBin usePurs glob cb logCb = do
  pathVar <- liftEff $ getPathVar addNpmBin path
  serverBins <- findBins pathVar server
  case head serverBins of
    Nothing -> do
      liftEff $ cb Info $ "Couldn't find psc-ide-server, check PATH. Looked for: "
        <> server <> " in PATH: " <> either id id pathVar
      pure { quit: pure unit, port: Nothing }
    Just (Executable bin version) -> do
      liftEff $ logCb Info "Resolved psc-ide-server paths (1st is used):"
      traverse_ (\(Executable x vv) -> do
        liftEff $ logCb Info $ x <> ": " <> fromMaybe "ERROR" vv) serverBins
      liftEff $ when (length serverBins > 1) $ cb Warning $ "Found multiple psc-ide-server executables; using " <> bin
      let glob' = if join (parseVersion <$> trim <$> version) >= Just (Version 0 9 2) then glob else []
      res <- startServer logCb bin path glob' usePurs
      let noRes = { quit: pure unit, port: Nothing }
      liftEff $ case res of
        CorrectPath usedPort -> { quit: pure unit, port: Just usedPort } <$ cb Info ("Found existing psc-ide-server with correct path on port " <> show usedPort)
        WrongPath usedPort wrongPath -> do
          cb Error $ "Found existing psc-ide-server on port '" <> show usedPort <> "' with wrong path: '" <> wrongPath
            <> "'. Correct, kill or configure a different port, and restart."
          pure noRes
        Started usedPort cp -> do
          cb Success $ "Started psc-ide-server (port " <> show usedPort <> ")"
          wireOutput cp logCb
          pure
            { quit: stopServer usedPort path cp
            , port: Just usedPort
            }
        Closed -> noRes <$ cb Info "psc-ide-server exited with success code"
        StartError err -> noRes <$ (cb Error $ "Could not start psc-ide-server process. Check the configured port number is valid.\n" <> err)
  where
    wireOutput :: ChildProcess -> Notify (ServerEff eff) -> Eff (ServerEff eff) Unit
    wireOutput cp log = do
      onDataString (stderr cp) UTF8 (log Warning)
      onDataString (stdout cp) UTF8 (log Info)

-- | Start a psc-ide server instance, or find one already running on the expected port, checking if it has the right path.
startServer :: forall eff. Notify (ServerEff eff) -> String -> String -> Array String -> Boolean -> Aff (ServerEff eff) ServerStartResult
startServer logCb exe rootPath glob usePurs = do
  port <- liftEff $ getSavedPort rootPath
  case port of
    Just p -> do
      workingDir <- attempt $ PscIde.cwd p
      liftEff $ logCb Info $ "Found existing port from file: " <> show p <> (either (const "") (", cwd: " <> _) workingDir)
      either (const launchServer) (gotPath p) workingDir
    Nothing -> launchServer

  where
  launchServer = do
    newPort <- liftEff pickFreshPort
    liftEff $ do
      logCb Info $ "Starting psc-ide-server on port " <> show newPort <> " with cwd " <> rootPath
      savePort newPort rootPath
    r newPort <$> S.startServer (defaultServerArgs { exe = exe, combinedExe = usePurs, cwd = Just rootPath, port = Just newPort, source = glob })
    where
      r newPort (S.Started cp) = Started newPort cp
      r _ (S.Closed) = Closed
      r _ (S.StartError s) = StartError s

  gotPath port workingDir =
    liftEff $ if normalizePath workingDir == normalizePath rootPath then
        do
          logCb Info $ "Found psc-ide-server on port " <> show port <> " with correct path: " <> workingDir
          pure $ CorrectPath port
      else
        do
          logCb Info $ "Found psc-ide-server on port " <> show port <> " with wrong path: " <> normalizePath workingDir <> " instead of " <> normalizePath rootPath
          pure $ WrongPath port workingDir

  normalizePath = (if platform == Win32 then toLower else id) <<< normalize

-- | Stop a psc-ide server. Currently implemented by asking it nicely, but potentially by killing it if that doesn't work...
stopServer :: forall eff. Int -> String -> ChildProcess -> Aff (cp :: CHILD_PROCESS, net :: NET, fs :: FS | eff) Unit
stopServer port rootPath cp = do
  oldPort <- liftEff $ S.getSavedPort rootPath
  _ <- liftEff' $ when (oldPort == Just port) $ S.deleteSavedPort rootPath
  S.stopServer port

module IdePurescript.PscIdeServer
  ( startServer
  , startServer'
  , stopServer
  , ServerStartResult(..)
  , ServerEff
  , Port
  , QuitCallback
  , ErrorLevel(..)
  , Notify(..)
  ) where

import Prelude
import PscIde.Server as S
import Control.Monad.Aff (runAff, Aff, attempt)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Data.Array (length, head)
import Data.Either (either)
import Data.Int (fromNumber)
import Data.Maybe (Maybe(Just, Nothing), fromMaybe)
import Data.String (Pattern(Pattern), split, toLower, trim)
import Data.Traversable (traverse, traverse_)
import Global (readInt)
import IdePurescript.Exec (getPathVar, findBins)
import IdePurescript.PscIde (cwd) as PscIde
import Node.Buffer (BUFFER)
import Node.ChildProcess (CHILD_PROCESS, ChildProcess, stderr, stdout)
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.Path (normalize)
import Node.Platform (Platform(..))
import Node.Process (PROCESS, platform)
import Node.Stream (onDataString)
import PscIde (NET)
import PscIde.Server (Executable(Executable), getSavedPort, defaultServerArgs, savePort, pickFreshPort)

type Port = Int

data ServerStartResult =
    CorrectPath Port
  | WrongPath Port String
  | Started Port ChildProcess
  | Closed
  | StartError String

type ServerEff eff = (cp :: CHILD_PROCESS, process :: PROCESS, console :: CONSOLE, net :: NET, avar :: AVAR, fs :: FS, exception :: EXCEPTION, random :: RANDOM, buffer :: BUFFER | eff)

type QuitCallback eff = (Eff (exception :: EXCEPTION, net :: NET, cp :: CHILD_PROCESS, fs :: FS | eff) Unit)

data ErrorLevel = Success | Info | Warning | Error
type Notify eff = ErrorLevel -> String -> Eff eff Unit

data Version = Version Int Int Int

parseVersion :: String -> Maybe Version
parseVersion s =
  case traverse fromNumber $ readInt 10 <$> split (Pattern ".") s of
    Just [a, b, c] -> Just $ Version a b c
    _ -> Nothing

instance eqVersion :: Eq Version where
  eq (Version a b c) (Version a' b' c') = a == a' && b == b' && c == c'

instance ordVersion :: Ord Version where
  compare (Version a b c) (Version a' b' c') = compare [a,b,c] [a',b',c']

instance showVersion :: Show Version where
  show (Version a b c) = show a <> "." <> show b <> "." <> show c

-- | Start a psc-ide server instance, or find one already running on the expected port, checking if it has the right path.
-- | Will notify as to what is happening, choose to supply globs appropriately
startServer' :: forall eff eff'.
  String
  -> String
  -> Boolean
  -> Boolean
  -> Array String
  -> Notify (ServerEff eff)
  -> Notify (ServerEff eff)
  -> Aff (ServerEff eff) { quit :: QuitCallback eff', port :: Maybe Int }
startServer' path server addNpmBin usePurs glob cb logCb = do
  pathVar <- liftEff $ getPathVar addNpmBin path
  serverBins <- findBins pathVar server
  case head serverBins of
    Nothing -> do
      liftEff $ cb Info $ "Couldn't find psc-ide-server, check PATH. Looked for: "
        <> server <> " in PATH: " <> either id id pathVar
      pure { quit: pure unit, port: Nothing }
    Just (Executable bin version) -> do
      liftEff $ logCb Info "Resolved psc-ide-server paths (1st is used):"
      traverse_ (\(Executable x vv) -> do
        liftEff $ logCb Info $ x <> ": " <> fromMaybe "ERROR" vv) serverBins
      liftEff $ when (length serverBins > 1) $ cb Warning $ "Found multiple psc-ide-server executables; using " <> bin
      let glob' = if join (parseVersion <$> trim <$> version) >= Just (Version 0 9 2) then glob else []
      res <- startServer logCb bin path glob' usePurs
      let noRes = { quit: pure unit, port: Nothing }
      liftEff $ case res of
        CorrectPath usedPort -> { quit: pure unit, port: Just usedPort } <$ cb Info ("Found existing psc-ide-server with correct path on port " <> show usedPort)
        WrongPath usedPort wrongPath -> do
          cb Error $ "Found existing psc-ide-server on port '" <> show usedPort <> "' with wrong path: '" <> wrongPath
            <> "'. Correct, kill or configure a different port, and restart."
          pure noRes
        Started usedPort cp -> do
          cb Success $ "Started psc-ide-server (port " <> show usedPort <> ")"
          wireOutput cp logCb
          pure
            { quit: void $ runAff (\_ -> pure unit) (\_ -> pure unit) $ stopServer usedPort path cp
            , port: Just usedPort
            }
        Closed -> noRes <$ cb Info "psc-ide-server exited with success code"
        StartError err -> noRes <$ (cb Error $ "Could not start psc-ide-server process. Check the configured port number is valid.\n" <> err)
  where
    wireOutput :: ChildProcess -> Notify (ServerEff eff) -> Eff (ServerEff eff) Unit
    wireOutput cp log = do
      onDataString (stderr cp) UTF8 (log Warning)
      onDataString (stdout cp) UTF8 (log Info)

-- | Start a psc-ide server instance, or find one already running on the expected port, checking if it has the right path.
startServer :: forall eff. Notify (ServerEff eff) -> String -> String -> Array String -> Boolean -> Aff (ServerEff eff) ServerStartResult
startServer logCb exe rootPath glob usePurs = do
  port <- liftEff $ getSavedPort rootPath
  case port of
    Just p -> do
      workingDir <- attempt $ PscIde.cwd p
      liftEff $ logCb Info $ "Found existing port from file: " <> show p <> (either (const "") (", cwd: " <> _) workingDir)
      either (const launchServer) (gotPath p) workingDir
    Nothing -> launchServer

  where
  launchServer = do
    newPort <- liftEff pickFreshPort
    liftEff $ do
      logCb Info $ "Starting psc-ide-server on port " <> show newPort <> " with cwd " <> rootPath
      savePort newPort rootPath
    r newPort <$> S.startServer (defaultServerArgs { exe = exe, combinedExe = usePurs, cwd = Just rootPath, port = Just newPort, source = glob })
    where
      r newPort (S.Started cp) = Started newPort cp
      r _ (S.Closed) = Closed
      r _ (S.StartError s) = StartError s

  gotPath port workingDir =
    liftEff $ if normalizePath workingDir == normalizePath rootPath then
        do
          logCb Info $ "Found psc-ide-server on port " <> show port <> " with correct path: " <> workingDir
          pure $ CorrectPath port
      else
        do
          logCb Info $ "Found psc-ide-server on port " <> show port <> " with wrong path: " <> normalizePath workingDir <> " instead of " <> normalizePath rootPath
          pure $ WrongPath port workingDir

  normalizePath = (if platform == Win32 then toLower else id) <<< normalize

-- | Stop a psc-ide server. Currently implemented by asking it nicely, but potentially by killing it if that doesn't work...
stopServer :: forall eff. Int -> String -> ChildProcess -> Aff (cp :: CHILD_PROCESS, net :: NET, fs :: FS, exception :: EXCEPTION | eff) Unit
stopServer port rootPath cp = do
  oldPort <- liftEff $ S.getSavedPort rootPath
  liftEff $ when (oldPort == Just port) $ S.deleteSavedPort rootPath
  S.stopServer port


[fe] simple loading indicator on Search page

module Search.App where

import Core.Prelude

import Component.Header as Header
import Component.Footer as Footer
import Core.Api as Api
import Core.Model (Talk)
import Data.Maybe (Maybe(..))
import Effect.Aff.Class (class MonadAff)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

type PageData =
  { q :: String
  }

data Query a = Init a

type State =
  { q :: String
  , talks :: Array Talk
  , loading :: Boolean
  }

type HTML = H.ComponentHTML Query

initialState :: PageData -> State
initialState pageData =
  { q: pageData.q
  , talks: []
  , loading: false
  }

renderTalk :: Talk -> HTML
renderTalk talk =
  HH.li
  [ class_ "flex flex-col lg:flex-row mb-6"]
  [ HH.a
    [ class_ "mr-4 flex-no-shrink Image"
    , HP.href $ "/talks/" <> talk.slug
    ]
    [ HH.img
      [ class_ "w-full h-full"
      , HP.src talk.image
      ]
    ]
  , HH.div_
    [ HH.h3
      [ class_ "mb-1 lg:mb-3" ]
      [ HH.a
        [ class_ "Link"
        , HP.href $ "/talks/" <> talk.slug
        ]
        [ HH.text talk.name ]
      ]
    , HH.p
      [ class_ "leading-normal text-grey500"]
      [ HH.text talk.description]
    ]
  ]

render :: State -> HTML
render state =
  HH.div_
  [ Header.render
  , HH.div
    [ class_ "container py-6 px-4 xl:px-0"] $ join
    [ pure $ HH.ul_ $
      state.talks <#> renderTalk
    , guard state.loading $>
      HH.div
      [ class_ "text-center"]
      [ HH.text "loading..."]
    ]
  , Footer.render
  ]

app :: forall m. MonadAff m => PageData -> H.Component HH.HTML Query Unit Void m
app pageData = H.lifecycleComponent
  { initialState: const $ initialState pageData
  , render
  , eval
  , receiver: const Nothing
  , initializer: Just $ H.action Init
  , finalizer: Nothing
  }
  where
  eval :: Query ~> H.ComponentDSL State Query Void m
  eval (Init n) = n <$ do
    H.modify_ $ _ { loading = true }
    H.fork $ H.liftAff (Api.searchTalks pageData.q) >>= traverse_ \talks ->
      H.modify_ $ _
        { talks = talks
        , loading = false
        }

module Search.App where

import Core.Prelude

import Component.Header as Header
import Component.Footer as Footer
import Core.Api as Api
import Core.Model (Talk)
import Data.Maybe (Maybe(..))
import Effect.Aff.Class (class MonadAff)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

type PageData =
  { q :: String
  }

data Query a = Init a

type State =
  { q :: String
  , talks :: Array Talk
  }

type HTML = H.ComponentHTML Query

initialState :: PageData -> State
initialState pageData =
  { q: pageData.q
  , talks: []
  }

renderTalk :: Talk -> HTML
renderTalk talk =
  HH.li
  [ class_ "flex flex-col lg:flex-row mb-6"]
  [ HH.a
    [ class_ "mr-4 flex-no-shrink Image"
    , HP.href $ "/talks/" <> talk.slug
    ]
    [ HH.img
      [ class_ "w-full h-full"
      , HP.src talk.image
      ]
    ]
  , HH.div_
    [ HH.h3
      [ class_ "mb-1 lg:mb-3" ]
      [ HH.a
        [ class_ "Link"
        , HP.href $ "/talks/" <> talk.slug
        ]
        [ HH.text talk.name ]
      ]
    , HH.p
      [ class_ "leading-normal text-grey500"]
      [ HH.text talk.description]
    ]
  ]

render :: State -> HTML
render state =
  HH.div_
  [ Header.render
  , HH.div
    [ class_ "container py-6 px-4 xl:px-0"]
    [ HH.ul_ $
      state.talks <#> renderTalk
    ]
  , Footer.render
  ]

app :: forall m. MonadAff m => PageData -> H.Component HH.HTML Query Unit Void m
app pageData = H.lifecycleComponent
  { initialState: const $ initialState pageData
  , render
  , eval
  , receiver: const Nothing
  , initializer: Just $ H.action Init
  , finalizer: Nothing
  }
  where
  eval :: Query ~> H.ComponentDSL State Query Void m
  eval (Init n) = n <$ do
    H.fork $ H.liftAff (Api.searchTalks pageData.q) >>= traverse_ \talks ->
      H.modify_ $ _ { talks = talks }


[CSM-189] Disable spending password feature

module Daedalus.ClientApi where

import Prelude
import Daedalus.BackendApi as B
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (getProfileLocale, mkCAddress, mkCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit, mkCWalletRedeem, mkCWalletInitIgnoreChecksum, mkBackupPhrase, mkCInitialized, mkCPassPhrase)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson)
import Data.String.Base64 as B64
import Data.Base58 as B58
import Data.String (length, stripSuffix, Pattern (..))
import Data.Maybe (isJust, maybe)
import Data.Function.Eff (EffFn1, mkEffFn1, EffFn2, mkEffFn2, EffFn4, mkEffFn4, EffFn3, mkEffFn3, EffFn6, mkEffFn6, EffFn7, mkEffFn7, mkEffFn5, EffFn5)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto

getLocale :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getLocale = fromAff $ map encodeJson (getProfileLocale <$> B.getProfile)

updateLocale :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
updateLocale = mkEffFn1 \locale -> fromAff <<< map encodeJson <<< B.updateProfile $ mkCProfile locale

getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getWallets = fromAff $ map encodeJson B.getWallets

getWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
getWallet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWallet <<< mkCAddress

getHistory :: forall eff. EffFn3 (ajax :: AJAX | eff) String Int Int (Promise Json)
getHistory = mkEffFn3 \addr skip limit -> fromAff <<< map encodeJson $
    B.getHistory
        (mkCAddress addr)
        skip
        limit

searchHistory :: forall eff. EffFn4 (ajax :: AJAX | eff) String String Int Int (Promise Json)
searchHistory = mkEffFn4 \addr search skip limit -> fromAff <<< map encodeJson $
    B.searchHistory
        (mkCAddress addr)
        search
        skip
        limit

send :: forall eff. EffFn3 (ajax :: AJAX | eff) String String Int (Promise Json)
send = mkEffFn3 \addrFrom addrTo amount -> fromAff <<< map encodeJson $
    B.send
        (mkCPassPhrase "")
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCoin amount)

sendExtended :: forall eff. EffFn6 (ajax :: AJAX | eff) String String Int String String String (Promise Json)
sendExtended = mkEffFn6 \addrFrom addrTo amount curr title desc -> fromAff <<< map encodeJson $
    B.sendExtended
        (mkCPassPhrase "")
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCoin amount)
        (mkCCurrency curr)
        title
        desc

generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
generateMnemonic = Crypto.generateMnemonic

-- | bip39.validateMnemonic and has at least 12 words
isValidMnemonic :: forall eff. EffFn1 (crypto :: Crypto.CRYPTO | eff) String Boolean
isValidMnemonic = mkEffFn1 $ pure <<< either (const false) (const true) <<< mkBackupPhrase

newWallet :: forall eff . EffFn4 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String String
  (Promise Json)
newWallet = mkEffFn4 \wType wCurrency wName mnemonic -> fromAff <<< map encodeJson <<<
    either throwError (B.newWallet $ mkCPassPhrase "") $ mkCWalletInit wType wCurrency wName mnemonic

-- NOTE: https://issues.serokell.io/issue/DAE-33#comment=96-1798
-- Daedalus.ClientApi.newWallet(
--     'CWTPersonal'
--   , 'ADA'
--   , 'wallet name'
--   , function(mnemonics) {
--     // if this function finishes we will send request for wallet
--     // creation to the backend. That means user validated and
--     // stored mnemonics.
--     // if an exception is thrown new wallet request will be aborted
--     // and promise should return thrown error
--     if(userSavedMnemonics) {
--       // do nothing
--     } else {
--       throw new Error("Wallet canceled")
--     }
--   }
--   )()
--   .then(function(value) {
--     console.log('SUCCESS', value);
--   }, function(reason) {
--     console.log('ERROR', reason);
--   })
-- newWalletDeprecated :: forall eff . Fn4 String String String (EffFn1 (err :: EXCEPTION | eff) String Unit)
--   (Eff(ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) (Promise Json))
-- newWalletDeprecated = mkFn4 \wType wCurrency wName wConfirmMnemonic -> fromAff $ map encodeJson $ do
--
--     mnemonic <- liftEff Crypto.generateMnemonic
--     -- FIXME: @jens how did we satisfy this with notify? I am having trouble again
--     isConfirmed <- liftEff' $ unsafeInterleaveEff $ runEffFn1 wConfirmMnemonic mnemonic
--     either throwError B.newWallet $ do
--         isConfirmed
--         mkCWalletInit wType wCurrency wName mnemonic

updateWallet :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Int (Promise Json)
updateWallet = mkEffFn6 \addr wType wCurrency wName wAssurance wUnit -> fromAff <<< map encodeJson <<<
    B.updateWallet
        (mkCAddress addr)
        $ mkCWalletMeta wType wCurrency wName wAssurance wUnit

updateTransaction :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Number (Promise Unit)
updateTransaction = mkEffFn6 \addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
    B.updateTransaction
        (mkCAddress addr)
        (mkCTxId ctxId)
        $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate

deleteWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Unit)
deleteWallet = mkEffFn1 $ fromAff <<< B.deleteWallet <<< mkCAddress

isValidAddress :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Boolean)
isValidAddress = mkEffFn2 \currency -> fromAff <<< B.isValidAddress (mkCCurrency currency)

notify :: forall eff. EffFn2 (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) (NotifyCb eff) (ErrorCb eff) Unit
notify = mkEffFn2 \messageCb errorCb -> do
    -- TODO (akegalj) grab global (mutable) state of  here
    -- instead of creating newRef
    conn <- newRef WSNotConnected
    openConn $ mkWSState conn messageCb errorCb

blockchainSlotDuration :: forall eff. Eff (ajax :: AJAX | eff) (Promise Int)
blockchainSlotDuration = fromAff B.blockchainSlotDuration

restoreWallet :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
restoreWallet = mkEffFn4 \wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase "") <<< mkCWalletInit wType wCurrency wName

restoreWalletIgnoreChecksum :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
restoreWalletIgnoreChecksum = mkEffFn4 \wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase "") <<< mkCWalletInitIgnoreChecksum wType wCurrency wName

nextUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
nextUpdate = fromAff $ map encodeJson B.nextUpdate

applyUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
applyUpdate = fromAff B.applyUpdate

systemVersion :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
systemVersion = fromAff $ map encodeJson B.systemVersion

redeemADA :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String (Promise Json)
redeemADA = mkEffFn2 \seed -> fromAff <<< map encodeJson <<< B.redeemADA <<< mkCWalletRedeem seed

reportInit :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) Int Int (Promise Unit)
reportInit = mkEffFn2 \total -> fromAff <<< B.reportInit <<< mkCInitialized total

importKey :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
importKey = mkEffFn1 $ fromAff <<< map encodeJson <<< B.importKey

syncProgress :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
syncProgress = fromAff $ map encodeJson B.syncProgress

testReset :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
testReset = fromAff B.testReset

-- Valid redeem code is base64 encoded 32byte data
-- NOTE: this method handles both base64 and base64url base on rfc4648: see more https://github.com/menelaos/purescript-b64/blob/59e2e9189358a4c8e3eef8662ca281906844e783/src/Data/String/Base64.purs#L182
isValidRedeemCode :: String -> Boolean
isValidRedeemCode code = either (const false) (const $ endsWithEqual && 44 == length code) $ B64.decode code
  where
    -- Because it is 32byte base64 encoded
    endsWithEqual = isJust $ stripSuffix (Pattern "=") code

-- Valid postvend code is base58 encoded 32byte data
isValidPostVendRedeemCode :: String -> Boolean
isValidPostVendRedeemCode code = maybe false (const $ 44 == length code) $ B58.decode code

module Daedalus.ClientApi where

import Prelude
import Daedalus.BackendApi as B
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (getProfileLocale, mkCAddress, mkCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit, mkCWalletRedeem, mkCWalletInitIgnoreChecksum, mkBackupPhrase, mkCInitialized, mkCPassPhrase)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson)
import Data.String.Base64 as B64
import Data.Base58 as B58
import Data.String (length, stripSuffix, Pattern (..))
import Data.Maybe (isJust, maybe)
import Data.Function.Eff (EffFn1, mkEffFn1, EffFn2, mkEffFn2, EffFn4, mkEffFn4, EffFn3, mkEffFn3, EffFn6, mkEffFn6, EffFn7, mkEffFn7, mkEffFn5, EffFn5)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto

getLocale :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getLocale = fromAff $ map encodeJson (getProfileLocale <$> B.getProfile)

updateLocale :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
updateLocale = mkEffFn1 \locale -> fromAff <<< map encodeJson <<< B.updateProfile $ mkCProfile locale

getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getWallets = fromAff $ map encodeJson B.getWallets

getWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
getWallet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWallet <<< mkCAddress

getHistory :: forall eff. EffFn3 (ajax :: AJAX | eff) String Int Int (Promise Json)
getHistory = mkEffFn3 \addr skip limit -> fromAff <<< map encodeJson $
    B.getHistory
        (mkCAddress addr)
        skip
        limit

searchHistory :: forall eff. EffFn4 (ajax :: AJAX | eff) String String Int Int (Promise Json)
searchHistory = mkEffFn4 \addr search skip limit -> fromAff <<< map encodeJson $
    B.searchHistory
        (mkCAddress addr)
        search
        skip
        limit

send :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String Int (Promise Json)
send = mkEffFn4 \pass addrFrom addrTo amount -> fromAff <<< map encodeJson $
    B.send
        (mkCPassPhrase pass)
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCoin amount)

sendExtended :: forall eff. EffFn7 (ajax :: AJAX | eff) String String String Int String String String (Promise Json)
sendExtended = mkEffFn7 \pass addrFrom addrTo amount curr title desc -> fromAff <<< map encodeJson $
    B.sendExtended
        (mkCPassPhrase pass)
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCoin amount)
        (mkCCurrency curr)
        title
        desc

generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
generateMnemonic = Crypto.generateMnemonic

-- | bip39.validateMnemonic and has at least 12 words
isValidMnemonic :: forall eff. EffFn1 (crypto :: Crypto.CRYPTO | eff) String Boolean
isValidMnemonic = mkEffFn1 $ pure <<< either (const false) (const true) <<< mkBackupPhrase

newWallet :: forall eff . EffFn5 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String String String
  (Promise Json)
newWallet = mkEffFn5 \pass wType wCurrency wName mnemonic -> fromAff <<< map encodeJson <<<
    either throwError (B.newWallet $ mkCPassPhrase pass) $ mkCWalletInit wType wCurrency wName mnemonic

-- NOTE: https://issues.serokell.io/issue/DAE-33#comment=96-1798
-- Daedalus.ClientApi.newWallet(
--     'CWTPersonal'
--   , 'ADA'
--   , 'wallet name'
--   , function(mnemonics) {
--     // if this function finishes we will send request for wallet
--     // creation to the backend. That means user validated and
--     // stored mnemonics.
--     // if an exception is thrown new wallet request will be aborted
--     // and promise should return thrown error
--     if(userSavedMnemonics) {
--       // do nothing
--     } else {
--       throw new Error("Wallet canceled")
--     }
--   }
--   )()
--   .then(function(value) {
--     console.log('SUCCESS', value);
--   }, function(reason) {
--     console.log('ERROR', reason);
--   })
-- newWalletDeprecated :: forall eff . Fn4 String String String (EffFn1 (err :: EXCEPTION | eff) String Unit)
--   (Eff(ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) (Promise Json))
-- newWalletDeprecated = mkFn4 \wType wCurrency wName wConfirmMnemonic -> fromAff $ map encodeJson $ do
--
--     mnemonic <- liftEff Crypto.generateMnemonic
--     -- FIXME: @jens how did we satisfy this with notify? I am having trouble again
--     isConfirmed <- liftEff' $ unsafeInterleaveEff $ runEffFn1 wConfirmMnemonic mnemonic
--     either throwError B.newWallet $ do
--         isConfirmed
--         mkCWalletInit wType wCurrency wName mnemonic

updateWallet :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Int (Promise Json)
updateWallet = mkEffFn6 \addr wType wCurrency wName wAssurance wUnit -> fromAff <<< map encodeJson <<<
    B.updateWallet
        (mkCAddress addr)
        $ mkCWalletMeta wType wCurrency wName wAssurance wUnit

updateTransaction :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Number (Promise Unit)
updateTransaction = mkEffFn6 \addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
    B.updateTransaction
        (mkCAddress addr)
        (mkCTxId ctxId)
        $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate

deleteWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Unit)
deleteWallet = mkEffFn1 $ fromAff <<< B.deleteWallet <<< mkCAddress

isValidAddress :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Boolean)
isValidAddress = mkEffFn2 \currency -> fromAff <<< B.isValidAddress (mkCCurrency currency)

notify :: forall eff. EffFn2 (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) (NotifyCb eff) (ErrorCb eff) Unit
notify = mkEffFn2 \messageCb errorCb -> do
    -- TODO (akegalj) grab global (mutable) state of  here
    -- instead of creating newRef
    conn <- newRef WSNotConnected
    openConn $ mkWSState conn messageCb errorCb

blockchainSlotDuration :: forall eff. Eff (ajax :: AJAX | eff) (Promise Int)
blockchainSlotDuration = fromAff B.blockchainSlotDuration

restoreWallet :: forall eff. EffFn5 (ajax :: AJAX | eff) String String String String String (Promise Json)
restoreWallet = mkEffFn5 \pass wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase pass) <<< mkCWalletInit wType wCurrency wName

restoreWalletIgnoreChecksum :: forall eff. EffFn5 (ajax :: AJAX | eff) String String String String String (Promise Json)
restoreWalletIgnoreChecksum = mkEffFn5 \pass wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase pass) <<< mkCWalletInitIgnoreChecksum wType wCurrency wName

nextUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
nextUpdate = fromAff $ map encodeJson B.nextUpdate

applyUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
applyUpdate = fromAff B.applyUpdate

systemVersion :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
systemVersion = fromAff $ map encodeJson B.systemVersion

redeemADA :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String (Promise Json)
redeemADA = mkEffFn2 \seed -> fromAff <<< map encodeJson <<< B.redeemADA <<< mkCWalletRedeem seed

reportInit :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) Int Int (Promise Unit)
reportInit = mkEffFn2 \total -> fromAff <<< B.reportInit <<< mkCInitialized total

importKey :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
importKey = mkEffFn1 $ fromAff <<< map encodeJson <<< B.importKey

syncProgress :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
syncProgress = fromAff $ map encodeJson B.syncProgress

testReset :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
testReset = fromAff B.testReset

-- Valid redeem code is base64 encoded 32byte data
-- NOTE: this method handles both base64 and base64url base on rfc4648: see more https://github.com/menelaos/purescript-b64/blob/59e2e9189358a4c8e3eef8662ca281906844e783/src/Data/String/Base64.purs#L182
isValidRedeemCode :: String -> Boolean
isValidRedeemCode code = either (const false) (const $ endsWithEqual && 44 == length code) $ B64.decode code
  where
    -- Because it is 32byte base64 encoded
    endsWithEqual = isJust $ stripSuffix (Pattern "=") code

-- Valid postvend code is base58 encoded 32byte data
isValidPostVendRedeemCode :: String -> Boolean
isValidPostVendRedeemCode code = maybe false (const $ 44 == length code) $ B58.decode code


Add missing mapWriter

Add missing mapWriter

module Control.Monad.Writer where

import Prelude
import Control.Monad.Identity
import Control.Monad.Writer.Trans
import Data.Monoid
import Data.Tuple

type Writer w a = WriterT w Identity a

runWriter :: forall w a. Writer w a -> Tuple a w
runWriter = runIdentity <<< runWriterT

mapWriter :: forall w1 w2 a b. (Tuple a w1 -> Tuple b w2) -> Writer w1 a -> Writer w2 b
mapWriter f = mapWriterT (Identity <<< f <<< runIdentity)


make type Pure use an empty row instead of rank-2 types

module Control.Monad.Eff
  ( Eff()
  , Pure()
  , runPure
  , untilE, whileE, forE, foreachE
  ) where

import Prelude

-- | The `Eff` type constructor is used to represent _native_ effects.
-- |
-- | See [Handling Native Effects with the Eff Monad](http://www.purescript.org/learn/eff/) for more details.
-- |
-- | The first type parameter is a row of effects which represents the contexts in which a computation can be run, and the second type parameter is the return type.
foreign import data Eff :: # ! -> * -> *

foreign import returnE :: forall e a. a -> Eff e a

foreign import bindE :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

-- | The `Pure` type synonym represents _pure_ computations, i.e. ones in which all effects have been handled.
-- |
-- | The `runPure` function can be used to run pure computations and obtain their result.
type Pure a = Eff () a

-- | Run a pure computation and return its result.
foreign import runPure :: forall a. Pure a -> a

instance functorEff :: Functor (Eff e) where
  map = liftA1

instance applyEff :: Apply (Eff e) where
  apply = ap

instance applicativeEff :: Applicative (Eff e) where
  pure = returnE

instance bindEff :: Bind (Eff e) where
  bind = bindE

instance monadEff :: Monad (Eff e)

-- | Loop until a condition becomes `true`.
-- |
-- | `untilE b` is an effectful computation which repeatedly runs the effectful computation `b`,
-- | until its return value is `true`.
foreign import untilE :: forall e. Eff e Boolean -> Eff e Unit

-- | Loop while a condition is `true`.
-- |
-- | `whileE b m` is effectful computation which runs the effectful computation `b`. If its result is
-- | `true`, it runs the effectful computation `m` and loops. If not, the computation ends.
foreign import whileE :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit

-- | Loop over a consecutive collection of numbers.
-- |
-- | `forE lo hi f` runs the computation returned by the function `f` for each of the inputs
-- | between `lo` (inclusive) and `hi` (exclusive).
foreign import forE :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit

-- | Loop over an array of values.
-- |
-- | `foreach xs f` runs the computation returned by the function `f` for each of the inputs `xs`.
foreign import foreachE :: forall e a. Array a -> (a -> Eff e Unit) -> Eff e Unit

module Control.Monad.Eff
  ( Eff()
  , Pure()
  , runPure
  , untilE, whileE, forE, foreachE
  ) where

import Prelude

-- | The `Eff` type constructor is used to represent _native_ effects.
-- |
-- | See [Handling Native Effects with the Eff Monad](http://www.purescript.org/learn/eff/) for more details.
-- |
-- | The first type parameter is a row of effects which represents the contexts in which a computation can be run, and the second type parameter is the return type.
foreign import data Eff :: # ! -> * -> *

foreign import returnE :: forall e a. a -> Eff e a

foreign import bindE :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

-- | The `Pure` type synonym represents _pure_ computations, i.e. ones in which all effects have been handled.
-- |
-- | The `runPure` function can be used to run pure computations and obtain their result.
type Pure a = forall e. Eff e a

-- | Run a pure computation and return its result.
-- |
-- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach
-- | is to use parentheses instead.
foreign import runPure :: forall a. Pure a -> a

instance functorEff :: Functor (Eff e) where
  map = liftA1

instance applyEff :: Apply (Eff e) where
  apply = ap

instance applicativeEff :: Applicative (Eff e) where
  pure = returnE

instance bindEff :: Bind (Eff e) where
  bind = bindE

instance monadEff :: Monad (Eff e)

-- | Loop until a condition becomes `true`.
-- |
-- | `untilE b` is an effectful computation which repeatedly runs the effectful computation `b`,
-- | until its return value is `true`.
foreign import untilE :: forall e. Eff e Boolean -> Eff e Unit

-- | Loop while a condition is `true`.
-- |
-- | `whileE b m` is effectful computation which runs the effectful computation `b`. If its result is
-- | `true`, it runs the effectful computation `m` and loops. If not, the computation ends.
foreign import whileE :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit

-- | Loop over a consecutive collection of numbers.
-- |
-- | `forE lo hi f` runs the computation returned by the function `f` for each of the inputs
-- | between `lo` (inclusive) and `hi` (exclusive).
foreign import forE :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit

-- | Loop over an array of values.
-- |
-- | `foreach xs f` runs the computation returned by the function `f` for each of the inputs `xs`.
foreign import foreachE :: forall e a. Array a -> (a -> Eff e Unit) -> Eff e Unit


no sequence

no sequence

module Life where

-- based on http://blog.emillon.org/posts/2012-10-18-comonadic-life.html

import Prelude
import Data.List.Zipper
import Test.QuickCheck.Gen
import Data.List as List
import Data.List.Zipper as Zipper
import Control.Apply (lift2)
import Control.Comonad (class Comonad, extract)
import Control.Extend (class Extend, extend)
import Data.Array (filter, length)
import Data.Bounded (class Bounded, bottom)
import Data.Foldable (class Foldable)
import Data.List (List(..), reverse)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.String (joinWith, fromCharArray)
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(Tuple))
import Data.Unfoldable (class Unfoldable, unfoldr, replicate)
import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary, class Coarbitrary, coarbitrary)

data Z a = Z (Zipper (Zipper a))

instance functorZ :: Functor Z where
    -- map :: forall a b. (a -> b) -> Z a -> Z b
    map f (Z z) = Z (map (map f) z)

instance extendZ :: Extend Z where
    -- extend :: forall b a. (Z a -> b) -> Z a -> Z b
    extend f = map f <<< duplicate
        where duplicate z = Z (map horizontal (vertical z))
              horizontal = genericMove zLeft zRight
              vertical = genericMove zUp zDown
              genericMove :: forall a. (Z a -> Maybe (Z a)) -> (Z a -> Maybe (Z a)) -> Z a -> Zipper (Z a)
              genericMove a b z = Zipper (reverse (maybeIterate a z)) z (maybeIterate b z)

instance comonadZ :: Comonad Z where
    -- extract :: forall a. Z a -> a
    extract (Z z) = extract (extract z)

derive instance eqZ :: (Eq a) => Eq (Z a)

-- this instance is invalid and exists only to support boundedZ
instance ordZ :: (Ord a) => Ord (Z a) where
  compare y z = compare y' z'
    where y' :: Array (Array a)
          y' = toUnfoldable y
          z' :: Array (Array a)
          z' = toUnfoldable z

instance boundedZ :: (Bounded a) => Bounded (Z a) where
  bottom = Z (Zipper Nil (Zipper Nil bottom Nil) Nil)
  top =  Z (Zipper Nil (Zipper Nil top Nil) Nil)

instance showZ :: (Show a) => Show (Z a) where
    show (Z z) = show z

instance arbitraryZ :: (Arbitrary a, Bounded a) => Arbitrary (Z a) where
  arbitrary = do
    n <- chooseInt 0 3
    xs <- vectorOf n (vectorOf n (elements bottom [bottom, top]))
    pure (fromMaybe emptyZ (fromFoldable xs))

instance coarbitraryZ :: (Coarbitrary a) => Coarbitrary (Z a) where
  coarbitrary xs = coarbitrary xs'
    where xs' :: Array (Array a)
          xs' = toUnfoldable xs

-- | Moves cursor toward beginning, or wraps back around to end.
upOrWrap :: forall a. Zipper a -> Zipper a
upOrWrap z = case up z of
  Just z' -> z'
  Nothing -> end z

-- | Moves cursor toward end, or wraps back around to beginning.
downOrWrap :: forall a. Zipper a -> Zipper a
downOrWrap z = case down z of
  Just z' -> z'
  Nothing -> beginning z

-- | Move up (backward in the top-level Zipper).
zUp :: forall a. Z a -> Maybe (Z a)
zUp (Z z) = Z <$> up z

-- | Move down (forward in the top-level Zipper).
zDown :: forall a. Z a -> Maybe (Z a)
zDown (Z z) = Z <$> down z

-- | Move left (backward in all nested Zippers).
zLeft :: forall a. Z a -> Maybe (Z a)
zLeft (Z z) = Z <$> traverse up z

-- | Move left (backward in all nested Zippers).
zRight :: forall a. Z a -> Maybe (Z a)
zRight (Z z) = Z <$> traverse down z

maybeIterate :: forall a f. (Unfoldable f) => (a -> Maybe a) -> a -> f a
maybeIterate f = unfoldr (map dup <<< f)
  where dup a = Tuple a a

neighbors :: forall a. Array (Z a -> Maybe (Z a))
neighbors = horiz <> vert <> lift2 (>=>) horiz vert
  where horiz = [zLeft, zRight]
        vert = [zUp, zDown]

emptyZ :: forall a. (Bounded a) => Z a
emptyZ = Z (Zipper Nil (Zipper Nil bottom Nil) Nil)

-- | Boundaries are considered dead.
aliveNeighbors :: Z Boolean -> Int
aliveNeighbors z = length <<< filter id $ map fetch neighbors
  where fetch dir = case dir z of
          Just z' -> extract z'
          Nothing -> false

rule :: Z Boolean -> Boolean
rule z =
  case aliveNeighbors z of
    2 -> extract z
    3 -> true
    _ -> false

evolve :: Z Boolean -> Z Boolean
evolve = extend rule

glider :: Z Boolean
glider = fromMaybe emptyZ rs
  where rs = fromFoldable ( replicate 3 fl <>
                            [ fs <> [f, t, f] <> fs
                            , fs <> [f, f, t] <> fs
                            , fs <> [t, t, t] <> fs
                            ] <> replicate 3 fl)
        t = true
        f = false
        fs = replicate 6 f
        fl = replicate 15 f

disp :: Z Boolean -> String
disp (Z z) = joinWith "\n" (map (fromCharArray <<< map f) z')
  where z' :: Array (Array Boolean)
        z' = toUnfoldable (Z z)
        f :: Boolean -> Char
        f x = if x then '#' else ' '

toUnfoldable :: forall a f. (Unfoldable f) => Z a -> f (f a)
toUnfoldable (Z z) = Zipper.toUnfoldable (map Zipper.toUnfoldable z)

fromList :: forall a. List (List a) -> Maybe (Z a)
fromList x = Z <$> (traverse Zipper.fromFoldable x >>= Zipper.fromFoldable)

fromFoldable :: forall a f. (Foldable f) => f (f a) -> Maybe (Z a)
fromFoldable x = fromList (map List.fromFoldable (List.fromFoldable x))

module Life where

-- based on http://blog.emillon.org/posts/2012-10-18-comonadic-life.html

import Prelude
import Data.List.Zipper
import Test.QuickCheck.Gen
import Data.List as List
import Data.List.Zipper as Zipper
import Control.Apply (lift2)
import Control.Comonad (class Comonad, extract)
import Control.Extend (class Extend, extend)
import Data.Array (filter, length)
import Data.Bounded (class Bounded, bottom)
import Data.Foldable (class Foldable)
import Data.List (List(..), reverse)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.String (joinWith, fromCharArray)
import Data.Traversable (class Traversable, traverse, sequence)
import Data.Tuple (Tuple(Tuple))
import Data.Unfoldable (class Unfoldable, unfoldr, replicate)
import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary, class Coarbitrary, coarbitrary)

data Z a = Z (Zipper (Zipper a))

instance functorZ :: Functor Z where
    -- map :: forall a b. (a -> b) -> Z a -> Z b
    map f (Z z) = Z (map (map f) z)

instance extendZ :: Extend Z where
    -- extend :: forall b a. (Z a -> b) -> Z a -> Z b
    extend f = map f <<< duplicate
        where duplicate z = Z (map horizontal (vertical z))
              horizontal = genericMove zLeft zRight
              vertical = genericMove zUp zDown
              genericMove :: forall a. (Z a -> Maybe (Z a)) -> (Z a -> Maybe (Z a)) -> Z a -> Zipper (Z a)
              genericMove a b z = Zipper (reverse (maybeIterate a z)) z (maybeIterate b z)

instance comonadZ :: Comonad Z where
    -- extract :: forall a. Z a -> a
    extract (Z z) = extract (extract z)

derive instance eqZ :: (Eq a) => Eq (Z a)

-- this instance is invalid and exists only to support boundedZ
instance ordZ :: (Ord a) => Ord (Z a) where
  compare y z = compare y' z'
    where y' :: Array (Array a)
          y' = toUnfoldable y
          z' :: Array (Array a)
          z' = toUnfoldable z

instance boundedZ :: (Bounded a) => Bounded (Z a) where
  bottom = Z (Zipper Nil (Zipper Nil bottom Nil) Nil)
  top =  Z (Zipper Nil (Zipper Nil top Nil) Nil)

instance showZ :: (Show a) => Show (Z a) where
    show (Z z) = show z

instance arbitraryZ :: (Arbitrary a, Bounded a) => Arbitrary (Z a) where
  arbitrary = do
    n <- chooseInt 0 3
    xs <- vectorOf n (vectorOf n (elements bottom [bottom, top]))
    pure (fromMaybe emptyZ (fromFoldable xs))

instance coarbitraryZ :: (Coarbitrary a) => Coarbitrary (Z a) where
  coarbitrary xs = coarbitrary xs'
    where xs' :: Array (Array a)
          xs' = toUnfoldable xs

-- | Moves cursor toward beginning, or wraps back around to end.
upOrWrap :: forall a. Zipper a -> Zipper a
upOrWrap z = case up z of
  Just z' -> z'
  Nothing -> end z

-- | Moves cursor toward end, or wraps back around to beginning.
downOrWrap :: forall a. Zipper a -> Zipper a
downOrWrap z = case down z of
  Just z' -> z'
  Nothing -> beginning z

-- | Move up (backward in the top-level Zipper).
zUp :: forall a. Z a -> Maybe (Z a)
zUp (Z z) = Z <$> up z

-- | Move down (forward in the top-level Zipper).
zDown :: forall a. Z a -> Maybe (Z a)
zDown (Z z) = Z <$> down z

-- | Move left (backward in all nested Zippers).
zLeft :: forall a. Z a -> Maybe (Z a)
zLeft (Z z) = Z <$> sequence xs
  where xs = map up z

-- | Move left (backward in all nested Zippers).
zRight :: forall a. Z a -> Maybe (Z a)
zRight (Z z) = Z <$> sequence xs
  where xs = map down z

maybeIterate :: forall a f. (Unfoldable f) => (a -> Maybe a) -> a -> f a
maybeIterate f = unfoldr (map dup <<< f)
  where dup a = Tuple a a

neighbors :: forall a. Array (Z a -> Maybe (Z a))
neighbors = horiz <> vert <> lift2 (>=>) horiz vert
  where horiz = [zLeft, zRight]
        vert = [zUp, zDown]

emptyZ :: forall a. (Bounded a) => Z a
emptyZ = Z (Zipper Nil (Zipper Nil bottom Nil) Nil)

-- | Boundaries are considered dead.
aliveNeighbors :: Z Boolean -> Int
aliveNeighbors z = length <<< filter id $ map fetch neighbors
  where fetch dir = case dir z of
          Just z' -> extract z'
          Nothing -> false

rule :: Z Boolean -> Boolean
rule z =
  case aliveNeighbors z of
    2 -> extract z
    3 -> true
    _ -> false

evolve :: Z Boolean -> Z Boolean
evolve = extend rule

glider :: Z Boolean
glider = fromMaybe emptyZ rs
  where rs = fromFoldable ( replicate 3 fl <>
                            [ fs <> [f, t, f] <> fs
                            , fs <> [f, f, t] <> fs
                            , fs <> [t, t, t] <> fs
                            ] <> replicate 3 fl)
        t = true
        f = false
        fs = replicate 6 f
        fl = replicate 15 f

disp :: Z Boolean -> String
disp (Z z) = joinWith "\n" (map (fromCharArray <<< map f) z')
  where z' :: Array (Array Boolean)
        z' = toUnfoldable (Z z)
        f :: Boolean -> Char
        f x = if x then '#' else ' '

toUnfoldable :: forall a f. (Unfoldable f) => Z a -> f (f a)
toUnfoldable (Z z) = Zipper.toUnfoldable (map Zipper.toUnfoldable z)

fromList :: forall a. List (List a) -> Maybe (Z a)
fromList x = Z <$> (traverse Zipper.fromFoldable x >>= Zipper.fromFoldable)

fromFoldable :: forall a f. (Foldable f) => f (f a) -> Maybe (Z a)
fromFoldable x = fromList (map List.fromFoldable (List.fromFoldable x))