Subscribers should always get the current value immediately when subscribing.

module Signal
  ( Signal(..)
  , constant
  , lift
  , applySig
  , merge
  , foldp
  , sampleOn
  , distinct
  , zip
  , runSignal
  , unwrap
  , (<~)
  , (~>)
  , (~)
  ) where

import Control.Monad.Eff
import Data.Function
import Data.Tuple(Tuple(..))

foreign import data Signal :: * -> *

foreign import constant """
  function constant(initial) {
    var subs = [];
    var val = initial;
    var sig = {
      subscribe: function(sub) {
        subs.push(sub);
        sub(val);
      },
      get: function() { return val; },
      set: function(newval) {
        val = newval;
        subs.forEach(function(sub) { sub(newval); });
      }
    };
    return sig;
  }""" :: forall a. a -> Signal a

foreign import liftP """
  function liftP(constant, fun, sig) {
    var out = constant(fun(sig.get()));
    sig.subscribe(function(val) { out.set(fun(val)); });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (a -> b) (Signal a) (Signal b)

lift = runFn3 liftP constant

foreign import applySigP """
  function applySigP(constant, fun, sig) {
    var out = constant(fun.get()(sig.get()));
    var produce = function() { out.set(fun.get()(sig.get())); };
    fun.subscribe(produce);
    sig.subscribe(produce);
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal (a -> b)) (Signal a) (Signal b)

applySig = runFn3 applySigP constant

foreign import mergeP """
  function mergeP(constant, sig1, sig2) {
    var out = constant(sig1.get());
    sig1.subscribe(out.set);
    sig2.subscribe(out.set);
    return out;
  }""" :: forall a c. Fn3 (c -> Signal c) (Signal a) (Signal a) (Signal a)

merge = runFn3 mergeP constant

foreign import foldpP """
  function foldpP(constant, fun, seed, sig) {
    var acc = fun(sig.get())(seed);
    var out = constant(acc);
    sig.subscribe(function(val) {
      acc = fun(val)(acc);
      out.set(acc);
    });
    return out;
  }""" :: forall a b c. Fn4 (c -> Signal c) (a -> b -> b) b (Signal a) (Signal b)

foldp = runFn4 foldpP constant

foreign import sampleOnP """
  function sampleOnP(constant, sig1, sig2) {
    var out = constant(sig2.get());
    sig1.subscribe(function() {
      out.set(sig2.get());
    });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal a) (Signal b) (Signal b)

sampleOn = runFn3 sampleOnP constant

foreign import distinctP """
  function distinctP(constant) {
  return function(eq) {
  return function(sig) {
    var val = sig.get();
    var out = constant(val);
    sig.subscribe(function(newval) {
      if (eq['/='](val, newval)) {
        val = newval;
        out.set(val);
      }
    });
    return out;
  };};}""" :: forall a c. (Eq a) => (c -> Signal c) -> Signal a -> Signal a

distinct :: forall a. (Eq a) => Signal a -> Signal a
distinct = distinctP constant

foreign import zipP """
  function zipP(Tuple, constant, sig1, sig2) {
    var val1 = sig1.get(), val2 = sig2.get();
    var out = constant(Tuple(val1)(val2));
    sig1.subscribe(function(v) {
      val1 = v;
      out.set(Tuple(val1)(val2));
    });
    sig2.subscribe(function(v) {
      val2 = v;
      out.set(Tuple(val1)(val2));
    });
    return out;
  }""" :: forall a b c. Fn4 (a -> b -> Tuple a b) (c -> Signal c) (Signal a) (Signal b) (Signal (Tuple a b))

zip :: forall a b. Signal a -> Signal b -> Signal (Tuple a b)
zip a b = runFn4 zipP Tuple constant a b

foreign import runSignal """
  function runSignal(sig) {
    return function() {
      sig.subscribe(function(val) {
        val();
      });
      return {};
    };
  }""" :: forall e. Signal (Eff e Unit) -> Eff e Unit

foreign import unwrapP """
  function unwrapP(constant, sig) {
    return function() {
      var out = constant(sig.get()());
      sig.subscribe(function(val) { out.set(val()); });
      return out;
    };
  }""" :: forall e a c. Fn2 (c -> Signal c) (Signal (Eff e a)) (Eff e (Signal a))

unwrap :: forall a e. Signal (Eff e a) -> Eff e (Signal a)
unwrap = runFn2 unwrapP constant

instance functorSignal :: Functor Signal where
  (<$>) = lift

instance applySignal :: Apply Signal where
  (<*>) = applySig

instance applicativeSignal :: Applicative Signal where
  pure = constant

instance semigroupSignal :: Semigroup (Signal a) where
  (<>) = merge

infixl 4 <~
(<~) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
(<~) = (<$>)

infixl 4 ~>
(~>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
(~>) = flip (<$>)

infixl 4 ~
(~) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
(~) = (<*>)

module Signal
  ( Signal(..)
  , constant
  , lift
  , applySig
  , merge
  , foldp
  , sampleOn
  , distinct
  , zip
  , runSignal
  , unwrap
  , (<~)
  , (~>)
  , (~)
  ) where

import Control.Monad.Eff
import Data.Function
import Data.Tuple(Tuple(..))

foreign import data Signal :: * -> *

foreign import constant """
  function constant(initial) {
    var subs = [];
    var val = initial;
    var sig = {
      subscribe: function(sub) {
        subs.push(sub);
      },
      get: function() { return val; },
      set: function(newval) {
        val = newval;
        subs.forEach(function(sub) { sub(newval); });
      }
    };
    return sig;
  }""" :: forall a. a -> Signal a

foreign import liftP """
  function liftP(constant, fun, sig) {
    var out = constant(fun(sig.get()));
    sig.subscribe(function(val) { out.set(fun(val)); });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (a -> b) (Signal a) (Signal b)

lift = runFn3 liftP constant

foreign import applySigP """
  function applySigP(constant, fun, sig) {
    var out = constant(fun.get()(sig.get()));
    var produce = function() { out.set(fun.get()(sig.get())); };
    fun.subscribe(produce);
    sig.subscribe(produce);
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal (a -> b)) (Signal a) (Signal b)

applySig = runFn3 applySigP constant

foreign import mergeP """
  function mergeP(constant, sig1, sig2) {
    var out = constant(sig1.get());
    sig1.subscribe(out.set);
    sig2.subscribe(out.set);
    return out;
  }""" :: forall a c. Fn3 (c -> Signal c) (Signal a) (Signal a) (Signal a)

merge = runFn3 mergeP constant

foreign import foldpP """
  function foldpP(constant, fun, seed, sig) {
    var acc = fun(sig.get())(seed);
    var out = constant(acc);
    sig.subscribe(function(val) {
      acc = fun(val)(acc);
      out.set(acc);
    });
    return out;
  }""" :: forall a b c. Fn4 (c -> Signal c) (a -> b -> b) b (Signal a) (Signal b)

foldp = runFn4 foldpP constant

foreign import sampleOnP """
  function sampleOnP(constant, sig1, sig2) {
    var out = constant(sig2.get());
    sig1.subscribe(function() {
      out.set(sig2.get());
    });
    return out;
  }""" :: forall a b c. Fn3 (c -> Signal c) (Signal a) (Signal b) (Signal b)

sampleOn = runFn3 sampleOnP constant

foreign import distinctP """
  function distinctP(constant) {
  return function(eq) {
  return function(sig) {
    var val = sig.get();
    var out = constant(val);
    sig.subscribe(function(newval) {
      if (eq['/='](val, newval)) {
        val = newval;
        out.set(val);
      }
    });
    return out;
  };};}""" :: forall a c. (Eq a) => (c -> Signal c) -> Signal a -> Signal a

distinct :: forall a. (Eq a) => Signal a -> Signal a
distinct = distinctP constant

foreign import zipP """
  function zipP(Tuple, constant, sig1, sig2) {
    var val1 = sig1.get(), val2 = sig2.get();
    var out = constant(Tuple(val1)(val2));
    sig1.subscribe(function(v) {
      val1 = v;
      out.set(Tuple(val1)(val2));
    });
    sig2.subscribe(function(v) {
      val2 = v;
      out.set(Tuple(val1)(val2));
    });
    return out;
  }""" :: forall a b c. Fn4 (a -> b -> Tuple a b) (c -> Signal c) (Signal a) (Signal b) (Signal (Tuple a b))

zip :: forall a b. Signal a -> Signal b -> Signal (Tuple a b)
zip a b = runFn4 zipP Tuple constant a b

foreign import runSignal """
  function runSignal(sig) {
    return function() {
      sig.subscribe(function(val) {
        val();
      });
      return {};
    };
  }""" :: forall e. Signal (Eff e Unit) -> Eff e Unit

foreign import unwrapP """
  function unwrapP(constant, sig) {
    return function() {
      var out = constant(sig.get()());
      sig.subscribe(function(val) { out.set(val()); });
      return out;
    };
  }""" :: forall e a c. Fn2 (c -> Signal c) (Signal (Eff e a)) (Eff e (Signal a))

unwrap :: forall a e. Signal (Eff e a) -> Eff e (Signal a)
unwrap = runFn2 unwrapP constant

instance functorSignal :: Functor Signal where
  (<$>) = lift

instance applySignal :: Apply Signal where
  (<*>) = applySig

instance applicativeSignal :: Applicative Signal where
  pure = constant

instance semigroupSignal :: Semigroup (Signal a) where
  (<>) = merge

infixl 4 <~
(<~) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
(<~) = (<$>)

infixl 4 ~>
(~>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
(~>) = flip (<$>)

infixl 4 ~
(~) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
(~) = (<*>)


Move usage string

Move usage string

module Main where

import Prelude
import Data.Argonaut.Printer (printJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Encode (encodeJson)
import Data.Array as Array
import Data.Array.Unsafe (unsafeIndex)
import Data.Date as Date
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.Traversable (traverse)
import Data.StrMap as StrMap
import Data.StrMap.ST as STMap
import Data.Maybe (Maybe(..), maybe)
import Data.Set as Set
import Data.String as Str
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Control.Monad.Eff.Exception (EXCEPTION, Error, catchException, throw, throwException, message)
import Control.Monad.ST (ST)
import Control.Monad.ST as ST
import Control.Apply ((*>))
import Control.Monad (when)
import Node.Platform (Platform(Win32))
import Node.Process (PROCESS)
import Node.Process as Process
import Node.ChildProcess (CHILD_PROCESS)
import Node.ChildProcess as Child
import Node.Stream as Stream
import Node.Buffer (BUFFER)
import Node.Encoding as Encoding
import Node.FS (FS)
import Node.FS.Sync as File
import Node.FS.Stats as Stats
import Node.Path as Path
import Unsafe.Coerce (unsafeCoerce)
import Psa (PsaOptions, parsePsaResult, parsePsaError, encodePsaError, output)
import Psa.Printer.Default as DefaultPrinter

foreign import version :: String

defaultOptions :: PsaOptions
defaultOptions =
  { ansi: true
  , censorWarnings: false
  , censorLib: false
  , censorSrc: false
  , censorCodes: Set.empty
  , filterCodes: Set.empty
  , verboseStats: false
  , libDirs: []
  , strict: false
  , cwd: ""
  }

type ParseOptions =
  { extra :: Array String
  , opts :: PsaOptions
  , psc :: String
  , showSource :: Boolean
  , stash :: Boolean
  , stashFile :: String
  , jsonErrors :: Boolean
  }

parseOptions
  :: forall eff
   . PsaOptions
  -> Array String
  -> Eff (console :: CONSOLE, process :: PROCESS | eff) ParseOptions
parseOptions opts args =
  defaultLibDir <$>
    Array.foldM parse
      { extra: []
      , psc: "psc"
      , showSource: true
      , stash: false
      , stashFile: ".psa-stash"
      , jsonErrors: false
      , opts
      }
      args
  where
  parse p arg
    | arg == "--version" || arg == "-v" =
      Console.log version *> Process.exit 0

    | arg == "--help" || arg == "-h" =
      Console.log usage *> Process.exit 0

    | arg == "--stash" =
      pure p { stash = true }

    | arg == "--json-errors" =
      pure p { jsonErrors = true }

    | arg == "--no-source" =
      pure p { showSource = false }

    | arg == "--no-colors" || arg == "--monochrome" =
      pure p { opts = p.opts { ansi = false } }

    | arg == "--verbose-stats" =
      pure p { opts = p.opts { verboseStats = true } }

    | arg == "--strict" =
      pure p { opts = p.opts { strict = true } }

    | arg == "--censor-warnings" =
      pure p { opts = p.opts { censorWarnings = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-src" =
      pure p { opts = p.opts { censorSrc = true } }

    | isPrefix "--censor-codes=" arg =
      pure p { opts = p.opts { censorCodes = foldr Set.insert p.opts.censorCodes (Str.split "," (Str.drop 15 arg)) } }

    | isPrefix "--filter-codes=" arg =
      pure p { opts = p.opts { filterCodes = foldr Set.insert p.opts.filterCodes (Str.split "," (Str.drop 15 arg)) } }

    | isPrefix "--is-lib=" arg =
      pure p { opts = p.opts { libDirs = Array.snoc p.opts.libDirs (Str.drop 9 arg) } }

    | isPrefix "--psc=" arg =
      pure p { psc = Str.drop 6 arg }

    | isPrefix "--stash=" arg =
      pure p { stash = true, stashFile = Str.drop 8 arg }

    | otherwise = pure p { extra = Array.snoc p.extra arg }

  isPrefix s str =
    case Str.indexOf s str of
      Just x | x == 0 -> true
      _               -> false

  defaultLibDir x
    | Array.length x.opts.libDirs == 0 =
      x { opts = x.opts { libDirs = [ "bower_components" ] } }
    | otherwise = x

type MainEff h eff =
  ( process :: PROCESS
  , console :: CONSOLE
  , buffer :: BUFFER
  , err :: EXCEPTION
  , fs :: FS
  , cp :: CHILD_PROCESS
  , st :: ST h
  , now :: Date.Now
  | eff
  )

main :: forall h eff. Eff (MainEff h eff) Unit
main = void do
  cwd <- Process.cwd
  argv <- Array.drop 2 <$> Process.argv

  { extra
  , opts
  , psc
  , showSource
  , stash
  , stashFile
  , jsonErrors
  } <- parseOptions (defaultOptions { cwd = cwd }) argv

  let opts' = opts { libDirs = (<> Path.sep) <<< Path.resolve [cwd] <$> opts.libDirs }
      args  = Array.cons "--json-errors" extra

  stashData <-
    if stash
      then readStashFile stashFile
      else emptyStash

  spawn' psc args \buffer -> do
    let stderr = Str.split "\n" buffer
    for_ stderr \err ->
      case jsonParser err >>= decodeJson >>= parsePsaResult of
        Left _ -> Console.error err
        Right out -> do
          files <- STMap.new
          let loadLinesImpl = if showSource then loadLines files else loadNothing
              filenames = insertFilenames (insertFilenames Set.empty out.errors) out.warnings
          merged <- mergeWarnings filenames stashData.date stashData.stash out.warnings
          when stash $ writeStashFile stashFile merged
          out' <- output loadLinesImpl opts' out { warnings = merged }
          if jsonErrors
            then Console.error err -- Just proxy psc's errors for tooling
            else DefaultPrinter.print opts' out'
          if StrMap.isEmpty out'.stats.allErrors
            then Process.exit 0
            else Process.exit 1

  where
  insertFilenames = foldr \x s -> maybe s (flip Set.insert s) x.filename
  stdio = [ Just Child.Pipe, unsafeIndex Child.inherit 1, Just Child.Pipe ]
  loadNothing _ _ = pure Nothing

  spawn' cmd args onExit = do
    child <- Child.spawn cmd args Child.defaultSpawnOptions { stdio = stdio }
    buffer <- ST.newSTRef ""
    Stream.onDataString (Child.stderr child) Encoding.UTF8 \chunk ->
      void $ ST.modifySTRef buffer (<> chunk)
    Child.onExit child \status ->
      case status of
        Child.Normally n -> do
          ST.readSTRef buffer >>= onExit
          Process.exit n
        Child.BySignal s -> do
          Console.error (show s)
          Process.exit 1
    Child.onError child (retryWithCmd cmd args onExit)

  retryWithCmd cmd args onExit err
    | err.code == "ENOENT" = do
     -- On windows, if the executable wasn't found, try adding .cmd
     if Process.platform == Win32
       then
         case Str.stripSuffix ".cmd" cmd of
           Nothing      -> spawn' (cmd <> ".cmd") args onExit
           Just bareCmd -> throw $ "`" <> bareCmd <> "` executable not found. (nor `" <> cmd <> "`)"
       else
         throw $ "`" <> cmd <> "` executable not found."
    | otherwise =
       throwException (Child.toStandardError err)

  -- TODO: Handle exceptions
  loadLines files filename pos = do
    contents <- STMap.peek files filename >>= \cache ->
      case cache of
        Just lines -> pure lines
        Nothing -> do
          lines <- Str.split "\n" <$> File.readTextFile Encoding.UTF8 filename
          STMap.poke files filename lines
          pure lines
    let source = Array.slice (pos.startLine - 1) (pos.endLine) contents
    pure $ Just source

  decodeStash s = jsonParser s >>= decodeJson >>= traverse parsePsaError
  encodeStash s = encodeJson (encodePsaError <$> s)
  emptyStash    = { date: _ , stash: [] } <$> Date.now

  readStashFile stashFile = catchException' (const emptyStash) do
    stat <- File.stat stashFile
    file <- File.readTextFile Encoding.UTF8 stashFile
    case decodeStash file of
      Left _ -> emptyStash
      Right stash -> pure { date: Stats.modifiedTime stat, stash }

  writeStashFile stashFile warnings = do
    let file = printJson (encodeStash warnings)
    File.writeTextFile Encoding.UTF8 stashFile file

  mergeWarnings filenames date old new = do
    fileStat <- STMap.new
    old' <- flip Array.filterM old \x ->
      case x.filename of
        Nothing -> pure false
        Just f ->
          if Set.member f filenames
            then pure false
            else do
              stat <- STMap.peek fileStat f
              case stat of
                Just s -> pure s
                Nothing -> do
                  s <- catchException' (\_ -> pure false) $
                    (date >) <<< Stats.modifiedTime <$> File.stat f
                  STMap.poke fileStat f s
                  pure s
    pure $ old' <> new

usage :: String
usage = """psa - Error/Warning reporting frontend for psc

Usage: psa [--censor-lib] [--censor-src]
           [--censor-codes=CODES] [--filter-codes=CODES]
           [--no-colors] [--no-source]
           [--is-lib=DIR] [--psc=PSC] [--stash]
           PSC_OPTIONS

Available options:
  -v,--version           Show the version number
  -h,--help              Show this help text
  --verbose-stats        Show counts for each warning type
  --censor-warnings      Censor all warnings
  --censor-lib           Censor warnings from library sources
  --censor-src           Censor warnings from project sources
  --censor-codes=CODES   Censor specific error codes
  --filter-codes=CODES   Only show specific error codes
  --no-colors            Disable ANSI colors
  --no-source            Disable original source code printing
  --strict               Promotes src warnings to errors
  --stash                Enable persistent warnings (defaults to .psa-stash)
  --stash=FILE           Enable persistent warnings using a specific stash file
  --is-lib=DIR           Distinguishing library path (defaults to 'bower_components')
  --psc=PSC              Name of psc executable (defaults to 'psc')

  CODES                  Comma-separated list of psc error codes
  PSC_OPTIONS            Any extra options are passed to psc
"""

-- Due to `catchException` label annoyingness
catchException'
  :: forall a eff
   . (Error -> Eff (err :: EXCEPTION | eff) a)
  -> Eff (err :: EXCEPTION | eff) a
  -> Eff (err :: EXCEPTION | eff) a
catchException' eb eff = unsafeCoerce (catchException (unsafeCoerce eb) (unsafeCoerce eff))

module Main where

import Prelude
import Data.Argonaut.Printer (printJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Encode (encodeJson)
import Data.Array as Array
import Data.Array.Unsafe (unsafeIndex)
import Data.Date as Date
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.Traversable (traverse)
import Data.StrMap as StrMap
import Data.StrMap.ST as STMap
import Data.Maybe (Maybe(..), maybe)
import Data.Set as Set
import Data.String as Str
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Control.Monad.Eff.Exception (EXCEPTION, Error, catchException, throw, throwException, message)
import Control.Monad.ST (ST)
import Control.Monad.ST as ST
import Control.Apply ((*>))
import Control.Monad (when)
import Node.Platform (Platform(Win32))
import Node.Process (PROCESS)
import Node.Process as Process
import Node.ChildProcess (CHILD_PROCESS)
import Node.ChildProcess as Child
import Node.Stream as Stream
import Node.Buffer (BUFFER)
import Node.Encoding as Encoding
import Node.FS (FS)
import Node.FS.Sync as File
import Node.FS.Stats as Stats
import Node.Path as Path
import Unsafe.Coerce (unsafeCoerce)
import Psa (PsaOptions, parsePsaResult, parsePsaError, encodePsaError, output)
import Psa.Printer.Default as DefaultPrinter

foreign import version :: String

usage :: String
usage = """psa - Error/Warning reporting frontend for psc

Usage: psa [--censor-lib] [--censor-src]
           [--censor-codes=CODES] [--filter-codes=CODES]
           [--no-colors] [--no-source]
           [--is-lib=DIR] [--psc=PSC] [--stash]
           PSC_OPTIONS

Available options:
  -v,--version           Show the version number
  -h,--help              Show this help text
  --verbose-stats        Show counts for each warning type
  --censor-warnings      Censor all warnings
  --censor-lib           Censor warnings from library sources
  --censor-src           Censor warnings from project sources
  --censor-codes=CODES   Censor specific error codes
  --filter-codes=CODES   Only show specific error codes
  --no-colors            Disable ANSI colors
  --no-source            Disable original source code printing
  --strict               Promotes src warnings to errors
  --stash                Enable persistent warnings (defaults to .psa-stash)
  --stash=FILE           Enable persistent warnings using a specific stash file
  --is-lib=DIR           Distinguishing library path (defaults to 'bower_components')
  --psc=PSC              Name of psc executable (defaults to 'psc')

  CODES                  Comma-separated list of psc error codes
  PSC_OPTIONS            Any extra options are passed to psc
"""

defaultOptions :: PsaOptions
defaultOptions =
  { ansi: true
  , censorWarnings: false
  , censorLib: false
  , censorSrc: false
  , censorCodes: Set.empty
  , filterCodes: Set.empty
  , verboseStats: false
  , libDirs: []
  , strict: false
  , cwd: ""
  }

type ParseOptions =
  { extra :: Array String
  , opts :: PsaOptions
  , psc :: String
  , showSource :: Boolean
  , stash :: Boolean
  , stashFile :: String
  , jsonErrors :: Boolean
  }

parseOptions
  :: forall eff
   . PsaOptions
  -> Array String
  -> Eff (console :: CONSOLE, process :: PROCESS | eff) ParseOptions
parseOptions opts args =
  defaultLibDir <$>
    Array.foldM parse
      { extra: []
      , psc: "psc"
      , showSource: true
      , stash: false
      , stashFile: ".psa-stash"
      , jsonErrors: false
      , opts
      }
      args
  where
  parse p arg
    | arg == "--version" || arg == "-v" =
      Console.log version *> Process.exit 0

    | arg == "--help" || arg == "-h" =
      Console.log usage *> Process.exit 0

    | arg == "--stash" =
      pure p { stash = true }

    | arg == "--json-errors" =
      pure p { jsonErrors = true }

    | arg == "--no-source" =
      pure p { showSource = false }

    | arg == "--no-colors" || arg == "--monochrome" =
      pure p { opts = p.opts { ansi = false } }

    | arg == "--verbose-stats" =
      pure p { opts = p.opts { verboseStats = true } }

    | arg == "--strict" =
      pure p { opts = p.opts { strict = true } }

    | arg == "--censor-warnings" =
      pure p { opts = p.opts { censorWarnings = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-src" =
      pure p { opts = p.opts { censorSrc = true } }

    | isPrefix "--censor-codes=" arg =
      pure p { opts = p.opts { censorCodes = foldr Set.insert p.opts.censorCodes (Str.split "," (Str.drop 15 arg)) } }

    | isPrefix "--filter-codes=" arg =
      pure p { opts = p.opts { filterCodes = foldr Set.insert p.opts.filterCodes (Str.split "," (Str.drop 15 arg)) } }

    | isPrefix "--is-lib=" arg =
      pure p { opts = p.opts { libDirs = Array.snoc p.opts.libDirs (Str.drop 9 arg) } }

    | isPrefix "--psc=" arg =
      pure p { psc = Str.drop 6 arg }

    | isPrefix "--stash=" arg =
      pure p { stash = true, stashFile = Str.drop 8 arg }

    | otherwise = pure p { extra = Array.snoc p.extra arg }

  isPrefix s str =
    case Str.indexOf s str of
      Just x | x == 0 -> true
      _               -> false

  defaultLibDir x
    | Array.length x.opts.libDirs == 0 =
      x { opts = x.opts { libDirs = [ "bower_components" ] } }
    | otherwise = x

type MainEff h eff =
  ( process :: PROCESS
  , console :: CONSOLE
  , buffer :: BUFFER
  , err :: EXCEPTION
  , fs :: FS
  , cp :: CHILD_PROCESS
  , st :: ST h
  , now :: Date.Now
  | eff
  )

main :: forall h eff. Eff (MainEff h eff) Unit
main = void do
  cwd <- Process.cwd
  argv <- Array.drop 2 <$> Process.argv

  { extra
  , opts
  , psc
  , showSource
  , stash
  , stashFile
  , jsonErrors
  } <- parseOptions (defaultOptions { cwd = cwd }) argv

  let opts' = opts { libDirs = (<> Path.sep) <<< Path.resolve [cwd] <$> opts.libDirs }
      args  = Array.cons "--json-errors" extra

  stashData <-
    if stash
      then readStashFile stashFile
      else emptyStash

  spawn' psc args \buffer -> do
    let stderr = Str.split "\n" buffer
    for_ stderr \err ->
      case jsonParser err >>= decodeJson >>= parsePsaResult of
        Left _ -> Console.error err
        Right out -> do
          files <- STMap.new
          let loadLinesImpl = if showSource then loadLines files else loadNothing
              filenames = insertFilenames (insertFilenames Set.empty out.errors) out.warnings
          merged <- mergeWarnings filenames stashData.date stashData.stash out.warnings
          when stash $ writeStashFile stashFile merged
          out' <- output loadLinesImpl opts' out { warnings = merged }
          if jsonErrors
            then Console.error err -- Just proxy psc's errors for tooling
            else DefaultPrinter.print opts' out'
          if StrMap.isEmpty out'.stats.allErrors
            then Process.exit 0
            else Process.exit 1

  where
  insertFilenames = foldr \x s -> maybe s (flip Set.insert s) x.filename
  stdio = [ Just Child.Pipe, unsafeIndex Child.inherit 1, Just Child.Pipe ]
  loadNothing _ _ = pure Nothing

  spawn' cmd args onExit = do
    child <- Child.spawn cmd args Child.defaultSpawnOptions { stdio = stdio }
    buffer <- ST.newSTRef ""
    Stream.onDataString (Child.stderr child) Encoding.UTF8 \chunk ->
      void $ ST.modifySTRef buffer (<> chunk)
    Child.onExit child \status ->
      case status of
        Child.Normally n -> do
          ST.readSTRef buffer >>= onExit
          Process.exit n
        Child.BySignal s -> do
          Console.error (show s)
          Process.exit 1
    Child.onError child (retryWithCmd cmd args onExit)

  retryWithCmd cmd args onExit err
    | err.code == "ENOENT" = do
     -- On windows, if the executable wasn't found, try adding .cmd
     if Process.platform == Win32
       then
         case Str.stripSuffix ".cmd" cmd of
           Nothing      -> spawn' (cmd <> ".cmd") args onExit
           Just bareCmd -> throw $ "`" <> bareCmd <> "` executable not found. (nor `" <> cmd <> "`)"
       else
         throw $ "`" <> cmd <> "` executable not found."
    | otherwise =
       throwException (Child.toStandardError err)

  -- TODO: Handle exceptions
  loadLines files filename pos = do
    contents <- STMap.peek files filename >>= \cache ->
      case cache of
        Just lines -> pure lines
        Nothing -> do
          lines <- Str.split "\n" <$> File.readTextFile Encoding.UTF8 filename
          STMap.poke files filename lines
          pure lines
    let source = Array.slice (pos.startLine - 1) (pos.endLine) contents
    pure $ Just source

  decodeStash s = jsonParser s >>= decodeJson >>= traverse parsePsaError
  encodeStash s = encodeJson (encodePsaError <$> s)
  emptyStash    = { date: _ , stash: [] } <$> Date.now

  readStashFile stashFile = catchException' (const emptyStash) do
    stat <- File.stat stashFile
    file <- File.readTextFile Encoding.UTF8 stashFile
    case decodeStash file of
      Left _ -> emptyStash
      Right stash -> pure { date: Stats.modifiedTime stat, stash }

  writeStashFile stashFile warnings = do
    let file = printJson (encodeStash warnings)
    File.writeTextFile Encoding.UTF8 stashFile file

  mergeWarnings filenames date old new = do
    fileStat <- STMap.new
    old' <- flip Array.filterM old \x ->
      case x.filename of
        Nothing -> pure false
        Just f ->
          if Set.member f filenames
            then pure false
            else do
              stat <- STMap.peek fileStat f
              case stat of
                Just s -> pure s
                Nothing -> do
                  s <- catchException' (\_ -> pure false) $
                    (date >) <<< Stats.modifiedTime <$> File.stat f
                  STMap.poke fileStat f s
                  pure s
    pure $ old' <> new

-- Due to `catchException` label annoyingness
catchException'
  :: forall a eff
   . (Error -> Eff (err :: EXCEPTION | eff) a)
  -> Eff (err :: EXCEPTION | eff) a
  -> Eff (err :: EXCEPTION | eff) a
catchException' eb eff = unsafeCoerce (catchException (unsafeCoerce eb) (unsafeCoerce eff))


Hide deck indicator when published

Hide deck indicator when published

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Deck.Component.Render
  ( renderDeck
  , renderError
  ) where

import SlamData.Prelude

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Events.Handler as HEH
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Render.Common (glyph)
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Deck.BackSide.Component as Back
import SlamData.Workspace.Deck.Common (DeckOptions, DeckHTML)
import SlamData.Workspace.Deck.Component.ChildSlot (cpIndicator, cpBackSide, cpDialog)
import SlamData.Workspace.Deck.Component.CSS as CSS
import SlamData.Workspace.Deck.Component.Cycle (DeckComponent)
import SlamData.Workspace.Deck.Component.Query (Query(..))
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckLevel as DL
import SlamData.Workspace.Deck.Dialog.Component as Dialog
import SlamData.Workspace.Deck.Indicator.Component as Indicator
import SlamData.Workspace.Deck.Slider as Slider

renderError ∷ String → DeckHTML
renderError err =
  HH.div
    [ HP.classes [ B.alert, B.alertDanger ] ]
    [ HH.h1
        [ HP.class_ B.textCenter ]
        [ HH.text err ]
    ]

renderDeck ∷ DeckOptions → DeckComponent → DCS.State → DeckHTML
renderDeck opts deckComponent st =
  HH.div
    ([ HP.classes $ [CSS.deckContainer] ⊕ (guard st.focused $> CSS.focused) ]
     ⊕ deckProperties
     ⊕ Slider.containerProperties st)
    [ HH.div
        [ HP.class_ CSS.deckFrame ]
        $ frameElements opts.accessType st ⊕ [ renderName st.name ]
    , HH.div
        [ HP.class_ CSS.deck
        , HP.key "deck"
        ]
        [ Slider.render opts deckComponent st $ st.displayMode ≡ DCS.Normal
        , renderBackside $ st.displayMode ≡ DCS.Backside
        , renderDialog $ st.displayMode ≡ DCS.Dialog
        ]
    ]

  where

  renderDialog visible =
    HH.div
      [ HP.classes $ [CSS.dialogWrapper] ⊕ (guard (not visible) $> CSS.invisible)
      , ARIA.hidden $ show $ not visible
      ]
      [ dialogSlot ]

  renderBackside visible =
    HH.div
      [ HP.classes $ [CSS.cardSlider] ⊕ (guard (not visible) $> CSS.invisible)
      , ARIA.hidden $ show $ not visible
      ]
      [ backside ]

deckProperties ∷ ∀ r. Array (HP.IProp (HP.InteractiveEvents (HP.GlobalProperties r)) (Query Unit))
deckProperties =
  [ HP.key "deck-container"
  , HE.onMouseUp (HE.input_ UpdateCardSize)
  , HE.onMouseDown \_ → HEH.stopPropagation $> Just (H.action Focus)
  , HP.ref (H.action ∘ SetCardElement)
  ]

renderName ∷ String → DeckHTML
renderName name =
  HH.div
    [ HP.class_ CSS.deckName ]
    [ HH.text name ]

frameElements ∷ AT.AccessType → DCS.State → Array DeckHTML
frameElements accessType st
  | accessType ≡ AT.ReadOnly = mempty
  | st.level ≡ DL.root = rootFrameElements
  | otherwise = childFrameElements

rootFrameElements ∷ Array DeckHTML
rootFrameElements =
  [ zoomOutButton
  , flipButton
  , deckIndicator
  ]

childFrameElements ∷ Array DeckHTML
childFrameElements =
  [ zoomInButton
  , flipButton
  , moveGripper
  , resizeGripper
  , deckIndicator
  ]

dialogSlot ∷ DeckHTML
dialogSlot =
  HH.slot' cpDialog unit \_ →
    { component: Dialog.comp
    , initialState: H.parentState Dialog.initialState
    }

backside ∷ DeckHTML
backside =
  HH.div
    [ HP.classes [ CSS.card ] ]
    [ HH.slot' cpBackSide unit \_ →
        { component: Back.comp
        , initialState: Back.initialState
        }
    ]

deckIndicator ∷ DeckHTML
deckIndicator =
  HH.slot' cpIndicator unit \_ →
    { component: Indicator.comp
    , initialState: Indicator.initialState
    }

flipButton ∷ DeckHTML
flipButton =
  HH.button
    [ HP.classes [ CSS.flipDeck ]
    , HE.onClick (HE.input_ FlipDeck)
    , ARIA.label "Flip deck"
    , HP.title "Flip deck"
    ]
    []

moveGripper ∷ DeckHTML
moveGripper =
  HH.button
    [ HP.classes [ CSS.grabDeck ]
    , HE.onMouseDown (HE.input GrabDeck)
    , ARIA.label "Grab deck"
    , HP.title "Grab deck"
    ]
    []

resizeGripper ∷ DeckHTML
resizeGripper =
  HH.button
    [ HP.classes [ CSS.resizeDeck ]
    , HE.onMouseDown (HE.input ResizeDeck)
    , ARIA.label "Resize deck"
    , HP.title "Resize deck"
    ]
    []

zoomInButton ∷ DeckHTML
zoomInButton =
  HH.button
     [ HP.classes [ CSS.zoomDeck ]
     , ARIA.label "Zoom in"
     , HP.title "Zoom in"
     , HE.onClick (HE.input_ ZoomIn)
     ]
     [ glyph B.glyphiconZoomIn ]

zoomOutButton ∷ DeckHTML
zoomOutButton =
  HH.button
   [ HP.classes [ CSS.zoomDeck ]
   , ARIA.label "Zoom out"
   , HP.title "Zoom out"
   , HE.onClick (HE.input_ ZoomOut)
   ]
   [ glyph B.glyphiconZoomOut ]

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Deck.Component.Render
  ( renderDeck
  , renderError
  ) where

import SlamData.Prelude

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Events.Handler as HEH
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Render.Common (glyph)
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Deck.BackSide.Component as Back
import SlamData.Workspace.Deck.Common (DeckOptions, DeckHTML)
import SlamData.Workspace.Deck.Component.ChildSlot (cpIndicator, cpBackSide, cpDialog)
import SlamData.Workspace.Deck.Component.CSS as CSS
import SlamData.Workspace.Deck.Component.Cycle (DeckComponent)
import SlamData.Workspace.Deck.Component.Query (Query(..))
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckLevel as DL
import SlamData.Workspace.Deck.Dialog.Component as Dialog
import SlamData.Workspace.Deck.Indicator.Component as Indicator
import SlamData.Workspace.Deck.Slider as Slider

renderError ∷ String → DeckHTML
renderError err =
  HH.div
    [ HP.classes [ B.alert, B.alertDanger ] ]
    [ HH.h1
        [ HP.class_ B.textCenter ]
        [ HH.text err ]
    ]

renderDeck ∷ DeckOptions → DeckComponent → DCS.State → DeckHTML
renderDeck opts deckComponent st =
  HH.div
    ([ HP.classes $ [CSS.deckContainer] ⊕ (guard st.focused $> CSS.focused) ]
     ⊕ deckProperties
     ⊕ Slider.containerProperties st)
    [ HH.div
        [ HP.class_ CSS.deckFrame ]
        $ frameElements opts.accessType st ⊕ [ renderName st.name, deckIndicator ]
    , HH.div
        [ HP.class_ CSS.deck
        , HP.key "deck"
        ]
        [ Slider.render opts deckComponent st $ st.displayMode ≡ DCS.Normal
        , renderBackside $ st.displayMode ≡ DCS.Backside
        , renderDialog $ st.displayMode ≡ DCS.Dialog
        ]
    ]

  where

  renderDialog visible =
    HH.div
      [ HP.classes $ [CSS.dialogWrapper] ⊕ (guard (not visible) $> CSS.invisible)
      , ARIA.hidden $ show $ not visible
      ]
      [ dialogSlot ]

  renderBackside visible =
    HH.div
      [ HP.classes $ [CSS.cardSlider] ⊕ (guard (not visible) $> CSS.invisible)
      , ARIA.hidden $ show $ not visible
      ]
      [ backside ]

deckProperties ∷ ∀ r. Array (HP.IProp (HP.InteractiveEvents (HP.GlobalProperties r)) (Query Unit))
deckProperties =
  [ HP.key "deck-container"
  , HE.onMouseUp (HE.input_ UpdateCardSize)
  , HE.onMouseDown \_ → HEH.stopPropagation $> Just (H.action Focus)
  , HP.ref (H.action ∘ SetCardElement)
  ]

renderName ∷ String → DeckHTML
renderName name =
  HH.div
    [ HP.class_ CSS.deckName ]
    [ HH.text name ]

frameElements ∷ AT.AccessType → DCS.State → Array DeckHTML
frameElements accessType st
  | accessType ≡ AT.ReadOnly = mempty
  | st.level ≡ DL.root = rootFrameElements
  | otherwise = childFrameElements

rootFrameElements ∷ Array DeckHTML
rootFrameElements =
  [ zoomOutButton
  , flipButton
  ]

childFrameElements ∷ Array DeckHTML
childFrameElements =
  [ zoomInButton
  , flipButton
  , moveGripper
  , resizeGripper
  ]

dialogSlot ∷ DeckHTML
dialogSlot =
  HH.slot' cpDialog unit \_ →
    { component: Dialog.comp
    , initialState: H.parentState Dialog.initialState
    }

backside ∷ DeckHTML
backside =
  HH.div
    [ HP.classes [ CSS.card ] ]
    [ HH.slot' cpBackSide unit \_ →
        { component: Back.comp
        , initialState: Back.initialState
        }
    ]

deckIndicator ∷ DeckHTML
deckIndicator =
  HH.slot' cpIndicator unit \_ →
    { component: Indicator.comp
    , initialState: Indicator.initialState
    }

flipButton ∷ DeckHTML
flipButton =
  HH.button
    [ HP.classes [ CSS.flipDeck ]
    , HE.onClick (HE.input_ FlipDeck)
    , ARIA.label "Flip deck"
    , HP.title "Flip deck"
    ]
    []

moveGripper ∷ DeckHTML
moveGripper =
  HH.button
    [ HP.classes [ CSS.grabDeck ]
    , HE.onMouseDown (HE.input GrabDeck)
    , ARIA.label "Grab deck"
    , HP.title "Grab deck"
    ]
    []

resizeGripper ∷ DeckHTML
resizeGripper =
  HH.button
    [ HP.classes [ CSS.resizeDeck ]
    , HE.onMouseDown (HE.input ResizeDeck)
    , ARIA.label "Resize deck"
    , HP.title "Resize deck"
    ]
    []

zoomInButton ∷ DeckHTML
zoomInButton =
  HH.button
     [ HP.classes [ CSS.zoomDeck ]
     , ARIA.label "Zoom in"
     , HP.title "Zoom in"
     , HE.onClick (HE.input_ ZoomIn)
     ]
     [ glyph B.glyphiconZoomIn ]

zoomOutButton ∷ DeckHTML
zoomOutButton =
  HH.button
   [ HP.classes [ CSS.zoomDeck ]
   , ARIA.label "Zoom out"
   , HP.title "Zoom out"
   , HE.onClick (HE.input_ ZoomOut)
   ]
   [ glyph B.glyphiconZoomOut ]


Fix Gen with a stack-safe version of replicateM

-- | This module defines the random generator monad used by the `Test.QuickCheck`
-- | module, as well as helper functions for constructing random generators.
module Test.QuickCheck.Gen
  ( Gen()
  , GenState()
  , Size()
  , repeatable
  , stateful
  , variant
  , sized
  , resize
  , choose
  , chooseInt
  , oneOf
  , frequency
  , arrayOf
  , arrayOf1
  , vectorOf
  , elements
  , runGen
  , evalGen
  , perturbGen
  , uniform
  , sample
  , randomSample
  , randomSample'
  ) where

import Prelude

import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Random (RANDOM())
import Control.Monad.State (State(..), runState, evalState)
import Control.Monad.State.Class (state, modify)
import Control.Monad.Rec.Class (MonadRec, tailRecM)
import Data.Array ((!!), length, range)
import Data.Tuple (Tuple(..))
import Data.Foldable (fold)
import Data.Int (fromNumber, toNumber)
import Data.Maybe (fromMaybe)
import Data.Monoid.Additive (Additive(..), runAdditive)
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..), fst, snd)
import Data.Either (Either(..))
import Data.List (List(..), fromList)
import Test.QuickCheck.LCG
import qualified Math as M

-- | Tests are parameterized by the `Size` of the randomly-generated data,
-- | the meaning of which depends on the particular generator used.
type Size = Int

-- | The state of the random generator monad
type GenState = { newSeed :: Seed, size :: Size }

-- | The random generator monad
-- |
-- | `Gen` is a state monad which encodes a linear congruential generator.
type Gen a = State GenState a

-- | Create a random generator for a function type.
repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = state $ \s -> Tuple (\a -> fst (runGen (f a) s)) s

-- | Create a random generator which uses the generator state explicitly.
stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = state $ \s -> runGen (f s) s

-- | Modify a random generator by setting a new random seed.
variant :: forall a. Seed -> Gen a -> Gen a
variant n g = state $ \s -> runGen g s { newSeed = n }

-- | Create a random generator which depends on the size parameter.
sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

-- | Modify a random generator by setting a new size parameter.
resize :: forall a. Size -> Gen a -> Gen a
resize sz g = state $ \s -> runGen g s { size = sz }

-- | Create a random generator which samples a range of `Number`s i
-- | with uniform probability.
choose :: Number -> Number -> Gen Number
choose a b = (*) (max - min) >>> (+) min <$> uniform where
  min = M.min a b
  max = M.max a b

-- | Create a random generator which chooses uniformly distributed
-- | integers from the closed interval `[a, b]`.
chooseInt :: Int -> Int -> Gen Int
chooseInt a b = clamp <$> lcgStep
  where
  clamp :: Int -> Int
  clamp x = case x `mod` (b - a + one) of
              r | r >= 0 -> a + r
                | otherwise -> b + r + one

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty collection of random generators with uniform probability.
oneOf :: forall a. Gen a -> Array (Gen a) -> Gen a
oneOf x xs = do
  n <- chooseInt zero (length xs)
  if n < one then x else fromMaybe x (xs !! (n - one))

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty, weighted collection of random generators.
frequency :: forall a. Tuple Number (Gen a) -> List (Tuple Number (Gen a)) -> Gen a
frequency x xs = let
    xxs   = Cons x xs
    total = runAdditive $ fold (map (Additive <<< fst) xxs :: List (Additive Number))
    pick n d Nil = d
    pick n d (Cons (Tuple k x) xs) = if n <= k then x else pick (n - k) d xs
  in do
    n <- choose zero total
    pick n (snd x) xxs

-- | Create a random generator which generates an array of random values.
arrayOf :: forall a. Gen a -> Gen (Array a)
arrayOf g = sized $ \n ->
  do k <- chooseInt zero n
     vectorOf k g

-- | Create a random generator which generates a non-empty array of random values.
arrayOf1 :: forall a. Gen a -> Gen (Tuple a (Array a))
arrayOf1 g = sized $ \n ->
  do k <- chooseInt zero n
     x <- g
     xs <- vectorOf (k - one) g
     return $ Tuple x xs

replicateMRec :: forall m a. (MonadRec m) => Int -> m a -> m (List a)
replicateMRec k _ | k <= 0 = return Nil
replicateMRec k gen = tailRecM go (Tuple Nil k)
  where
  go :: (Tuple (List a) Int) -> m (Either (Tuple (List a) Int) (List a))
  go (Tuple acc 0) = return $ Right acc
  go (Tuple acc n) = gen <#> \x -> Left (Tuple (Cons x acc) (n - 1))

-- | Create a random generator which generates a list of random values of the specified size.
listOf :: forall a. Int -> Gen a -> Gen (List a)
listOf = replicateMRec

-- | Create a random generator which generates a vector of random values of a specified size.
vectorOf :: forall a. Int -> Gen a -> Gen (Array a)
vectorOf k g = fromList <$> listOf k g

-- | Create a random generator which selects a value from a non-empty collection with
-- | uniform probability.
elements :: forall a. a -> Array a -> Gen a
elements x xs = do
  n <- chooseInt zero (length xs)
  pure if n == zero then x else fromMaybe x (xs !! (n - one))

-- | Run a random generator
runGen :: forall a. Gen a -> GenState -> Tuple a GenState
runGen = runState

-- | Run a random generator, keeping only the randomly-generated result
evalGen :: forall a. Gen a -> GenState -> a
evalGen = evalState

-- | Sample a random generator
sample :: forall r a. Seed -> Size -> Gen a -> Array a
sample seed sz g = evalGen (vectorOf sz g) { newSeed: seed, size: sz }

-- | Sample a random generator, using a randomly generated seed
randomSample' :: forall r a. Size -> Gen a -> Eff (random :: RANDOM | r) (Array a)
randomSample' n g = do
  seed <- randomSeed
  return $ sample seed n g

-- | Get a random sample of 10 values
randomSample :: forall r a. Gen a -> Eff (random :: RANDOM | r) (Array a)
randomSample = randomSample' 10

-- | A random generator which simply outputs the current seed
lcgStep :: Gen Int
lcgStep = state f where
  f s = Tuple (runSeed s.newSeed) (s { newSeed = lcgNext s.newSeed })

-- | A random generator which approximates a uniform random variable on `[0, 1]`
uniform :: Gen Number
uniform = (\n -> toNumber n / toNumber lcgN) <$> lcgStep

foreign import float32ToInt32 :: Number -> Int

-- | Perturb a random generator by modifying the current seed
perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n gen = do
  modify \s -> s { newSeed = perturb s.newSeed }
  gen
  where
  perturb oldSeed = mkSeed (runSeed (lcgNext (mkSeed (float32ToInt32 n))) + runSeed oldSeed)

-- | This module defines the random generator monad used by the `Test.QuickCheck`
-- | module, as well as helper functions for constructing random generators.
module Test.QuickCheck.Gen
  ( Gen()
  , GenState()
  , Size()
  , repeatable
  , stateful
  , variant
  , sized
  , resize
  , choose
  , chooseInt
  , oneOf
  , frequency
  , arrayOf
  , arrayOf1
  , vectorOf
  , elements
  , runGen
  , evalGen
  , perturbGen
  , uniform
  , sample
  , randomSample
  , randomSample'
  ) where

import Prelude

import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Random (RANDOM())
import Control.Monad.State (State(..), runState, evalState)
import Control.Monad.State.Class (state, modify)
import Control.Monad.Rec.Class (tailRecM)
import Data.Array ((!!), length, range)
import Data.Tuple (Tuple(..))
import Data.Foldable (fold)
import Data.Int (fromNumber, toNumber)
import Data.Maybe (fromMaybe)
import Data.Monoid.Additive (Additive(..), runAdditive)
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..), fst, snd)
import Data.List (List(..))
import Test.QuickCheck.LCG
import qualified Math as M

-- | Tests are parameterized by the `Size` of the randomly-generated data,
-- | the meaning of which depends on the particular generator used.
type Size = Int

-- | The state of the random generator monad
type GenState = { newSeed :: Seed, size :: Size }

-- | The random generator monad
-- |
-- | `Gen` is a state monad which encodes a linear congruential generator.
type Gen a = State GenState a

-- | Create a random generator for a function type.
repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = state $ \s -> Tuple (\a -> fst (runGen (f a) s)) s

-- | Create a random generator which uses the generator state explicitly.
stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = state $ \s -> runGen (f s) s

-- | Modify a random generator by setting a new random seed.
variant :: forall a. Seed -> Gen a -> Gen a
variant n g = state $ \s -> runGen g s { newSeed = n }

-- | Create a random generator which depends on the size parameter.
sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

-- | Modify a random generator by setting a new size parameter.
resize :: forall a. Size -> Gen a -> Gen a
resize sz g = state $ \s -> runGen g s { size = sz }

-- | Create a random generator which samples a range of `Number`s i
-- | with uniform probability.
choose :: Number -> Number -> Gen Number
choose a b = (*) (max - min) >>> (+) min <$> uniform where
  min = M.min a b
  max = M.max a b

-- | Create a random generator which chooses uniformly distributed
-- | integers from the closed interval `[a, b]`.
chooseInt :: Int -> Int -> Gen Int
chooseInt a b = clamp <$> lcgStep
  where
  clamp :: Int -> Int
  clamp x = case x `mod` (b - a + one) of
              r | r >= 0 -> a + r
                | otherwise -> b + r + one

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty collection of random generators with uniform probability.
oneOf :: forall a. Gen a -> Array (Gen a) -> Gen a
oneOf x xs = do
  n <- chooseInt zero (length xs)
  if n < one then x else fromMaybe x (xs !! (n - one))

-- | Create a random generator which selects and executes a random generator from
-- | a non-empty, weighted collection of random generators.
frequency :: forall a. Tuple Number (Gen a) -> List (Tuple Number (Gen a)) -> Gen a
frequency x xs = let
    xxs   = Cons x xs
    total = runAdditive $ fold (map (Additive <<< fst) xxs :: List (Additive Number))
    pick n d Nil = d
    pick n d (Cons (Tuple k x) xs) = if n <= k then x else pick (n - k) d xs
  in do
    n <- choose zero total
    pick n (snd x) xxs

-- | Create a random generator which generates an array of random values.
arrayOf :: forall a. Gen a -> Gen (Array a)
arrayOf g = sized $ \n ->
  do k <- chooseInt zero n
     vectorOf k g

-- | Create a random generator which generates a non-empty array of random values.
arrayOf1 :: forall a. Gen a -> Gen (Tuple a (Array a))
arrayOf1 g = sized $ \n ->
  do k <- chooseInt zero n
     x <- g
     xs <- vectorOf (k - one) g
     return $ Tuple x xs

-- | Create a random generator which generates a vector of random values of a specified size.
vectorOf :: forall a. Int -> Gen a -> Gen (Array a)
vectorOf k g
  | k <= 0    = return []
  | otherwise = sequence $ const g <$> range one k

-- | Create a random generator which selects a value from a non-empty collection with
-- | uniform probability.
elements :: forall a. a -> Array a -> Gen a
elements x xs = do
  n <- chooseInt zero (length xs)
  pure if n == zero then x else fromMaybe x (xs !! (n - one))

-- | Run a random generator
runGen :: forall a. Gen a -> GenState -> Tuple a GenState
runGen = runState

-- | Run a random generator, keeping only the randomly-generated result
evalGen :: forall a. Gen a -> GenState -> a
evalGen = evalState

-- | Sample a random generator
sample :: forall r a. Seed -> Size -> Gen a -> Array a
sample seed sz g = evalGen (vectorOf sz g) { newSeed: seed, size: sz }

-- | Sample a random generator, using a randomly generated seed
randomSample' :: forall r a. Size -> Gen a -> Eff (random :: RANDOM | r) (Array a)
randomSample' n g = do
  seed <- randomSeed
  return $ sample seed n g

-- | Get a random sample of 10 values
randomSample :: forall r a. Gen a -> Eff (random :: RANDOM | r) (Array a)
randomSample = randomSample' 10

-- | A random generator which simply outputs the current seed
lcgStep :: Gen Int
lcgStep = state f where
  f s = Tuple (runSeed s.newSeed) (s { newSeed = lcgNext s.newSeed })

-- | A random generator which approximates a uniform random variable on `[0, 1]`
uniform :: Gen Number
uniform = (\n -> toNumber n / toNumber lcgN) <$> lcgStep

foreign import float32ToInt32 :: Number -> Int

-- | Perturb a random generator by modifying the current seed
perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n gen = do
  modify \s -> s { newSeed = perturb s.newSeed }
  gen
  where
  perturb oldSeed = mkSeed (runSeed (lcgNext (mkSeed (float32ToInt32 n))) + runSeed oldSeed)


Pretty print lists without recursion

Pretty print lists without recursion

module PureSwift.PrettyPrinter
  ( prettyPrint
  ) where

import Prelude

import Data.Array as Array
import Data.Foldable (intercalate)
import Data.List (List(..))
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), maybe, maybe')
import Data.String as String
import Data.Tuple (Tuple(..))
import Prettier.Printer (DOC, line, nest, nil, pretty, spread, stack, text)
import PureSwift.AST (AccessMod(..), Attribute(..), Decl(..), DeclMod(..), Exp(..), FunctionTypeArg(..), Ident(..), Lit(..), ProtocolMemberDecl(..), Statement(..), Type(..))

-- | Alternative pretty-printing functions so that we never `flatten` line
-- | breaks into spaces. This should be equivalent to providing a width of 0 to
-- | `pretty`, except much less expensive. `pretty 0` is known to hang on
-- | non-trivial input.
group :: DOC -> DOC
group = id

bracket' :: Int -> String -> DOC -> String -> DOC
bracket' i l x r = group $ text l <> nest i (line <> x) <> line <> text r

bracket :: String -> DOC -> String -> DOC
bracket = bracket' 2

-- | The width provided to `pretty` should be irrelevant since we never flatten
-- | line breaks. Ordinarily, a width of `top` would place everything on a
-- | single line, so using it is a good way to verify the intended behavior.
prettyPrint :: Decl -> String
prettyPrint = pretty top <<< ppDecl

pad :: forall a. (List a -> DOC) -> List a -> DOC
pad _ Nil = text ""
pad f xs = f xs <> text " "

ppDecl :: Decl -> DOC
ppDecl (Enum ms i ds) = ppContainerDecl "enum" ms i Nil (ppDecl <$> ds)
ppDecl (Extension ms i ds) = ppContainerDecl "extension" ms i Nil (ppDecl <$> ds)
ppDecl (Import i) = text "import " <> ppIdent i
ppDecl (Protocol ms i is ds) = ppContainerDecl "protocol" ms i is (ppProtocolMemberDecl <$> ds)
ppDecl (TopLevel ss) = ppStatements ss
ppDecl (Constant ms i mt e) =
  group $ pad ppDeclMods ms <> intercalate (text " ") [ text "let", ident, text "=", ppExp e ]
  where
  ident = maybe' (\_ -> ppIdent i) (\t -> ppIdent i <> text ": " <> ppType t) mt

ppIdent :: Ident -> DOC
ppIdent (Ident i) = text i

ppContainerDecl
  :: String
  -> List DeclMod
  -> Ident
  -> (List Ident)
  -> List DOC
  -> DOC
ppContainerDecl name ms i is ds =
  group
    $ pad ppDeclMods ms
    <> text name <> text " " <> ppIdent i <> ppInheritance is <> text " "
    <> ppBrace ds
  where
  ppInheritance Nil = text ""
  ppInheritance is'@(Cons _ _) = text ": " <> intercalate (text ", ") (ppIdent <$> is')

ppDeclMods :: List DeclMod -> DOC
ppDeclMods = spread <<< map ppDeclMod

ppDeclMod :: DeclMod -> DOC
ppDeclMod Static = text "static"
ppDeclMod (AccessModifier a) = ppAccessMod a

ppAccessMod :: AccessMod -> DOC
ppAccessMod Private = text "private"
ppAccessMod PrivateSet = text "private(set)"
ppAccessMod FilePrivate = text "fileprivate"
ppAccessMod FilePrivateSet = text "fileprivate(set)"
ppAccessMod Internal = text "internal"
ppAccessMod InternalSet = text "internal(set)"
ppAccessMod Public = text "public"
ppAccessMod PublicSet = text "public(set)"
ppAccessMod Open = text "open"
ppAccessMod OpenSet = text "open(set)"

ppBrace :: List DOC -> DOC
ppBrace Nil = text "{}"
ppBrace ds = bracket "{" (stack ds) "}"

ppProtocolMemberDecl :: ProtocolMemberDecl -> DOC
ppProtocolMemberDecl (Method ms i as r) =
  group $ pad ppDeclMods ms <> intercalate (text " ") [ text "func", ppIdent i ] <> ppFunctionType as r

ppList :: String -> String -> List Exp -> DOC
ppList l r Nil = text l <> text r
ppList l r (Cons e Nil) = text l <> ppExp e <> text r
ppList l r es = text l <> bracket "" (ppListItems es) "" <> text r
  where
  ppListItems :: List Exp -> DOC
  ppListItems Nil = nil
  ppListItems es'@(Cons _ _) = intercalate (text "," <> line) (ppExp <$> es')

ppExp :: Exp -> DOC
ppExp (Literal l) = ppLit l
ppExp (Closure as r ss) = ppClosure as r ss
ppExp (Identifier i) = ppIdent i
ppExp (ExplicitMember e i) = ppExp e <> text "." <> ppIdent i
ppExp (FunctionCall e es) = ppExp e <> ppList "(" ")" es
ppExp (Subscript e1 e2) = ppExp e1 <> text "[" <> ppExp e2 <> text "]"

ppLit :: Lit -> DOC
ppLit (IntLit i) = text $ show i
ppLit (FloatLit f) = text $ show f
ppLit (CharLit c) = text $ show $ String.singleton c
ppLit (StringLit s) = text $ show s
ppLit (BooleanLit b) = text $ show b
ppLit (ArrayLit es) = ppList "[" "]" es
ppLit (DictLit m) =
  case Map.toAscUnfoldable m of
    Nil -> text "[:]"
    (Cons t Nil) -> text "[" <> ppDictItem t <> text "]"
    ts -> text "[" <> bracket "" (ppDictItems ts) "" <> text "]"
  where
  ppDictItems :: List (Tuple Exp Exp) -> DOC
  ppDictItems Nil = nil
  ppDictItems ts@(Cons _ _) = intercalate (text "," <> line) (ppDictItem <$> ts)

  ppDictItem :: Tuple Exp Exp -> DOC
  ppDictItem (Tuple k v) = ppExp k <> text ": " <> ppExp v

ppClosure :: List FunctionTypeArg -> Type -> List Statement -> DOC
ppClosure _ _ Nil = text "{}"
ppClosure as r ss =
  text "{ " <> ppFunctionType as r <> text " in"
    <> bracket "" (ppStatements ss) ""
    <> text "}"

ppStatements :: List Statement -> DOC
ppStatements ss = stack $ map ppStatement ss

ppStatement :: Statement -> DOC
ppStatement (Return e) = maybe nil (\e' -> text "return " <> ppExp e') e
ppStatement (Declaration d) = ppDecl d
ppStatement (Expression e) = ppExp e

ppType :: Type -> DOC
ppType (FunctionType as r) = ppFunctionType as r
ppType AnyType = text "Any"
ppType VoidType = text "Void"
ppType IntType = text "Int"
ppType FloatType = text "Float"
ppType CharType = text "Character"
ppType StringType = text "String"
ppType BoolType = text "Bool"

ppFunctionType :: List FunctionTypeArg -> Type -> DOC
ppFunctionType args r = ppFunctionTypeArgs args <> text " -> " <> ppType r
  where
  ppFunctionTypeArgs :: List FunctionTypeArg -> DOC
  ppFunctionTypeArgs args' =
    text "(" <> (intercalate (text ", ") $ ppFunctionTypeArg <$> args') <> text ")"

  ppFunctionTypeArg :: FunctionTypeArg -> DOC
  ppFunctionTypeArg (FunctionTypeArg e i atts t) =
    let
      labels = ppArgLabels e i
      attributes = ppAttributes atts
      typ = Just $ ppType t
    in
      intercalate (text " ") $ Array.catMaybes [ labels, attributes, typ ]

  ppArgLabels :: Maybe Ident -> Maybe Ident -> Maybe DOC
  ppArgLabels e i = do
    _ <- i
    let
      external = ppIdent <$> e
      internal = ppIdent <$> i
      labels = Array.catMaybes [ external, internal ]
      intercalated = intercalate (text " ") labels
    pure $ intercalated <> text ":"

  ppAttributes :: List Attribute -> Maybe DOC
  ppAttributes Nil = Nothing
  ppAttributes as = Just $ intercalate (text " ") $ ppAttribute <$> as

  ppAttribute :: Attribute -> DOC
  ppAttribute Autoclosure = text "@autoclosure"
  ppAttribute Escaping = text "@escaping"

module PureSwift.PrettyPrinter
  ( prettyPrint
  ) where

import Prelude

import Data.Array as Array
import Data.Foldable (intercalate)
import Data.List (List(..))
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), maybe, maybe')
import Data.String as String
import Data.Tuple (Tuple(..))
import Prettier.Printer (DOC, line, nest, nil, pretty, spread, stack, text)
import PureSwift.AST (AccessMod(..), Attribute(..), Decl(..), DeclMod(..), Exp(..), FunctionTypeArg(..), Ident(..), Lit(..), ProtocolMemberDecl(..), Statement(..), Type(..))

-- | Alternative pretty-printing functions so that we never `flatten` line
-- | breaks into spaces. This should be equivalent to providing a width of 0 to
-- | `pretty`, except much less expensive. `pretty 0` is known to hang on
-- | non-trivial input.
group :: DOC -> DOC
group = id

bracket' :: Int -> String -> DOC -> String -> DOC
bracket' i l x r = group $ text l <> nest i (line <> x) <> line <> text r

bracket :: String -> DOC -> String -> DOC
bracket = bracket' 2

-- | The width provided to `pretty` should be irrelevant since we never flatten
-- | line breaks. Ordinarily, a width of `top` would place everything on a
-- | single line, so using it is a good way to verify the intended behavior.
prettyPrint :: Decl -> String
prettyPrint = pretty top <<< ppDecl

pad :: forall a. (List a -> DOC) -> List a -> DOC
pad _ Nil = text ""
pad f xs = f xs <> text " "

ppDecl :: Decl -> DOC
ppDecl (Enum ms i ds) = ppContainerDecl "enum" ms i Nil (ppDecl <$> ds)
ppDecl (Extension ms i ds) = ppContainerDecl "extension" ms i Nil (ppDecl <$> ds)
ppDecl (Import i) = text "import " <> ppIdent i
ppDecl (Protocol ms i is ds) = ppContainerDecl "protocol" ms i is (ppProtocolMemberDecl <$> ds)
ppDecl (TopLevel ss) = ppStatements ss
ppDecl (Constant ms i mt e) =
  group $ pad ppDeclMods ms <> intercalate (text " ") [ text "let", ident, text "=", ppExp e ]
  where
  ident = maybe' (\_ -> ppIdent i) (\t -> ppIdent i <> text ": " <> ppType t) mt

ppIdent :: Ident -> DOC
ppIdent (Ident i) = text i

ppContainerDecl
  :: String
  -> List DeclMod
  -> Ident
  -> (List Ident)
  -> List DOC
  -> DOC
ppContainerDecl name ms i is ds =
  group
    $ pad ppDeclMods ms
    <> text name <> text " " <> ppIdent i <> ppInheritance is <> text " "
    <> ppBrace ds
  where
  ppInheritance Nil = text ""
  ppInheritance is'@(Cons _ _) = text ": " <> intercalate (text ", ") (ppIdent <$> is')

ppDeclMods :: List DeclMod -> DOC
ppDeclMods = spread <<< map ppDeclMod

ppDeclMod :: DeclMod -> DOC
ppDeclMod Static = text "static"
ppDeclMod (AccessModifier a) = ppAccessMod a

ppAccessMod :: AccessMod -> DOC
ppAccessMod Private = text "private"
ppAccessMod PrivateSet = text "private(set)"
ppAccessMod FilePrivate = text "fileprivate"
ppAccessMod FilePrivateSet = text "fileprivate(set)"
ppAccessMod Internal = text "internal"
ppAccessMod InternalSet = text "internal(set)"
ppAccessMod Public = text "public"
ppAccessMod PublicSet = text "public(set)"
ppAccessMod Open = text "open"
ppAccessMod OpenSet = text "open(set)"

ppBrace :: List DOC -> DOC
ppBrace Nil = text "{}"
ppBrace ds = bracket "{" (stack ds) "}"

ppProtocolMemberDecl :: ProtocolMemberDecl -> DOC
ppProtocolMemberDecl (Method ms i as r) =
  group $ pad ppDeclMods ms <> intercalate (text " ") [ text "func", ppIdent i ] <> ppFunctionType as r

ppList :: String -> String -> List Exp -> DOC
ppList l r Nil = text l <> text r
ppList l r (Cons e Nil) = text l <> ppExp e <> text r
ppList l r es = text l <> bracket "" (ppListItems es) "" <> text r
  where
  ppListItems :: List Exp -> DOC
  ppListItems Nil = nil
  ppListItems (Cons e' Nil) = ppExp e'
  ppListItems (Cons e' es') = ppExp e' <> text "," <> line <> ppListItems es'

ppExp :: Exp -> DOC
ppExp (Literal l) = ppLit l
ppExp (Closure as r ss) = ppClosure as r ss
ppExp (Identifier i) = ppIdent i
ppExp (ExplicitMember e i) = ppExp e <> text "." <> ppIdent i
ppExp (FunctionCall e es) = ppExp e <> ppList "(" ")" es
ppExp (Subscript e1 e2) = ppExp e1 <> text "[" <> ppExp e2 <> text "]"

ppLit :: Lit -> DOC
ppLit (IntLit i) = text $ show i
ppLit (FloatLit f) = text $ show f
ppLit (CharLit c) = text $ show $ String.singleton c
ppLit (StringLit s) = text $ show s
ppLit (BooleanLit b) = text $ show b
ppLit (ArrayLit es) = ppList "[" "]" es
ppLit (DictLit m) =
  case Map.toAscUnfoldable m of
    Nil -> text "[:]"
    (Cons t Nil) -> text "[" <> ppDictItem t <> text "]"
    ts -> text "[" <> bracket "" (ppDictItems ts) "" <> text "]"
  where
  ppDictItems :: List (Tuple Exp Exp) -> DOC
  ppDictItems Nil = nil
  ppDictItems (Cons t Nil) = ppDictItem t
  ppDictItems (Cons t ts) = ppDictItem t <> text "," <> line <> ppDictItems ts

  ppDictItem :: Tuple Exp Exp -> DOC
  ppDictItem (Tuple k v) = ppExp k <> text ": " <> ppExp v

ppClosure :: List FunctionTypeArg -> Type -> List Statement -> DOC
ppClosure _ _ Nil = text "{}"
ppClosure as r ss =
  text "{ " <> ppFunctionType as r <> text " in"
    <> bracket "" (ppStatements ss) ""
    <> text "}"

ppStatements :: List Statement -> DOC
ppStatements ss = stack $ map ppStatement ss

ppStatement :: Statement -> DOC
ppStatement (Return e) = maybe nil (\e' -> text "return " <> ppExp e') e
ppStatement (Declaration d) = ppDecl d
ppStatement (Expression e) = ppExp e

ppType :: Type -> DOC
ppType (FunctionType as r) = ppFunctionType as r
ppType AnyType = text "Any"
ppType VoidType = text "Void"
ppType IntType = text "Int"
ppType FloatType = text "Float"
ppType CharType = text "Character"
ppType StringType = text "String"
ppType BoolType = text "Bool"

ppFunctionType :: List FunctionTypeArg -> Type -> DOC
ppFunctionType args r = ppFunctionTypeArgs args <> text " -> " <> ppType r
  where
  ppFunctionTypeArgs :: List FunctionTypeArg -> DOC
  ppFunctionTypeArgs args' =
    text "(" <> (intercalate (text ", ") $ ppFunctionTypeArg <$> args') <> text ")"

  ppFunctionTypeArg :: FunctionTypeArg -> DOC
  ppFunctionTypeArg (FunctionTypeArg e i atts t) =
    let
      labels = ppArgLabels e i
      attributes = ppAttributes atts
      typ = Just $ ppType t
    in
      intercalate (text " ") $ Array.catMaybes [ labels, attributes, typ ]

  ppArgLabels :: Maybe Ident -> Maybe Ident -> Maybe DOC
  ppArgLabels e i = do
    _ <- i
    let
      external = ppIdent <$> e
      internal = ppIdent <$> i
      labels = Array.catMaybes [ external, internal ]
      intercalated = intercalate (text " ") labels
    pure $ intercalated <> text ":"

  ppAttributes :: List Attribute -> Maybe DOC
  ppAttributes Nil = Nothing
  ppAttributes as = Just $ intercalate (text " ") $ ppAttribute <$> as

  ppAttribute :: Attribute -> DOC
  ppAttribute Autoclosure = text "@autoclosure"
  ppAttribute Escaping = text "@escaping"


Fix pretty printer

Fix pretty printer

module PureSwift.PrettyPrinter
  ( prettyPrint
  ) where

import Prelude

import Data.Array as Array
import Data.Foldable (intercalate)
import Data.List (List(..))
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), maybe, maybe')
import Data.String as String
import Data.Tuple (Tuple(..))
import Prettier.Printer (DOC, line, nest, nil, pretty, spread, stack, text)
import PureSwift.AST (AccessMod(..), Attribute(..), Decl(..), DeclMod(..), Exp(..), FunctionTypeArg(..), Ident(..), Lit(..), Statement(..), Type(..))

-- | Alternative pretty-printing functions so that we never `flatten` line
-- | breaks into spaces. This should be equivalent to providing a width of 0 to
-- | `pretty`, except much less expensive. `pretty 0` is known to hang on
-- | non-trivial input.
group :: DOC -> DOC
group = id

bracket' :: Int -> String -> DOC -> String -> DOC
bracket' i l x r = group $ text l <> nest i (line <> x) <> line <> text r

bracket :: String -> DOC -> String -> DOC
bracket = bracket' 2

-- | The width provided to `pretty` should be irrelevant since we never flatten
-- | line breaks. Ordinarily, a width of `top` would place everything on a
-- | single line, so using it is a good way to verify the intended behavior.
prettyPrint :: Decl -> String
prettyPrint = pretty top <<< ppDecl

ppDecl :: Decl -> DOC
ppDecl (Enum ms i ds) = ppContainerDecl "enum" ms i ds
ppDecl (Extension ms i ds) = ppContainerDecl "extension" ms i ds
ppDecl (Import i) = text "import " <> ppIdent i
ppDecl (TopLevel ss) = ppStatements ss
ppDecl (Constant ms i mt e) = group $ intercalate (text " ")
  [ ppDeclMods ms, text "let", ident, text "=", ppExp e ]
  where
  ident = maybe' (\_ -> ppIdent i) (\t -> ppIdent i <> text ": " <> ppType t) mt

ppIdent :: Ident -> DOC
ppIdent (Ident i) = text i

ppContainerDecl
  :: String
  -> List DeclMod
  -> Ident
  -> List Decl
  -> DOC
ppContainerDecl name ms i ds = group $ intercalate (text " ")
  [ ppDeclMods ms, text name, ppIdent i, ppBrace ds ]

ppDeclMods :: List DeclMod -> DOC
ppDeclMods ms = spread $ map ppDeclMod ms

ppDeclMod :: DeclMod -> DOC
ppDeclMod Static = text "static"
ppDeclMod (AccessModifier a) = ppAccessMod a

ppAccessMod :: AccessMod -> DOC
ppAccessMod Private = text "private"
ppAccessMod PrivateSet = text "private(set)"
ppAccessMod FilePrivate = text "fileprivate"
ppAccessMod FilePrivateSet = text "fileprivate(set)"
ppAccessMod Internal = text "internal"
ppAccessMod InternalSet = text "internal(set)"
ppAccessMod Public = text "public"
ppAccessMod PublicSet = text "public(set)"
ppAccessMod Open = text "open"
ppAccessMod OpenSet = text "open(set)"

ppBrace :: List Decl -> DOC
ppBrace Nil = text "{}"
ppBrace ds = bracket "{" (ppDecls ds) "}"

ppDecls :: List Decl -> DOC
ppDecls Nil = nil
ppDecls (Cons d Nil) = ppDecl d
ppDecls (Cons d ds) = ppDecl d <> line <> ppDecls ds

ppList :: String -> String -> List Exp -> DOC
ppList l r Nil = text l <> text r
ppList l r (Cons e Nil) = text l <> ppExp e <> text r
ppList l r es = text l <> bracket "" (ppListItems es) "" <> text r
  where
  ppListItems :: List Exp -> DOC
  ppListItems Nil = nil
  ppListItems (Cons e' Nil) = ppExp e'
  ppListItems (Cons e' es') = ppExp e' <> text "," <> line <> ppListItems es'

ppExp :: Exp -> DOC
ppExp (Literal l) = ppLit l
ppExp (Closure as r ss) = ppClosure as r ss
ppExp (Identifier i) = ppIdent i
ppExp (ExplicitMember e i) = ppExp e <> text "." <> ppIdent i
ppExp (FunctionCall e es) = ppExp e <> ppList "(" ")" es

ppLit :: Lit -> DOC
ppLit (IntLit i) = text $ show i
ppLit (FloatLit f) = text $ show f
ppLit (CharLit c) = text $ show $ String.singleton c
ppLit (StringLit s) = text $ show s
ppLit (BooleanLit b) = text $ show b
ppLit (ArrayLit es) = ppList "[" "]" es
ppLit (DictLit m) =
  case Map.toAscUnfoldable m of
    Nil -> text "[:]"
    (Cons t Nil) -> text "[" <> ppDictItem t <> text "]"
    ts -> text "[" <> bracket "" (ppDictItems ts) "" <> text "]"
  where
  ppDictItems :: List (Tuple Exp Exp) -> DOC
  ppDictItems Nil = nil
  ppDictItems (Cons t Nil) = ppDictItem t
  ppDictItems (Cons t ts) = ppDictItem t <> text "," <> line <> ppDictItems ts

  ppDictItem :: Tuple Exp Exp -> DOC
  ppDictItem (Tuple k v) = ppExp k <> text ": " <> ppExp v

ppClosure :: List FunctionTypeArg -> Type -> List Statement -> DOC
ppClosure _ _ Nil = text "{}"
ppClosure as r ss =
  text "{ " <> ppFunctionType as r <> text " in"
    <> bracket "" (ppStatements ss) ""
    <> text "}"

ppStatements :: List Statement -> DOC
ppStatements ss = stack $ map ppStatement ss

ppStatement :: Statement -> DOC
ppStatement (Return e) = maybe nil (\e' -> text "return " <> ppExp e') e
ppStatement (Declaration d) = ppDecl d
ppStatement (Expression e) = ppExp e

ppType :: Type -> DOC
ppType (FunctionType as r) = ppFunctionType as r
ppType AnyType = text "Any"
ppType VoidType = text "Void"
ppType IntType = text "Int"
ppType FloatType = text "Float"
ppType CharType = text "Character"
ppType StringType = text "String"
ppType BoolType = text "Bool"

ppFunctionType :: List FunctionTypeArg -> Type -> DOC
ppFunctionType Nil r = ppType r
ppFunctionType args r = ppFunctionTypeArgs args <> text " -> " <> ppType r
  where
  ppFunctionTypeArgs :: List FunctionTypeArg -> DOC
  ppFunctionTypeArgs args' =
    text "(" <> (intercalate (text ", ") $ ppFunctionTypeArg <$> args') <> text ")"

  ppFunctionTypeArg :: FunctionTypeArg -> DOC
  ppFunctionTypeArg (FunctionTypeArg e i atts t) =
    let
      labels = ppArgLabels e i
      attributes = ppAttributes atts
      typ = Just $ ppType t
    in
      intercalate (text " ") $ Array.catMaybes [ labels, attributes, typ ]

  ppArgLabels :: Maybe Ident -> Maybe Ident -> Maybe DOC
  ppArgLabels e i = do
    _ <- i
    let
      external = ppIdent <$> e
      internal = ppIdent <$> i
      labels = Array.catMaybes [ external, internal ]
      intercalated = intercalate (text " ") labels
    pure $ intercalated <> text ":"

  ppAttributes :: List Attribute -> Maybe DOC
  ppAttributes Nil = Nothing
  ppAttributes as = Just $ intercalate (text " ") $ ppAttribute <$> as

  ppAttribute :: Attribute -> DOC
  ppAttribute Autoclosure = text "@autoclosure"
  ppAttribute Escaping = text "@escaping"

module PureSwift.PrettyPrinter
  ( prettyPrint
  ) where

import Prelude

import Data.Array as Array
import Data.Foldable (intercalate)
import Data.List (List(..))
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), maybe, maybe')
import Data.String as String
import Data.Tuple (Tuple(..))
import Prettier.Printer (DOC, bracket, group, line, nil, pretty, spread, stack, text)
import PureSwift.AST (AccessMod(..), Attribute(..), Decl(..), DeclMod(..), Exp(..), FunctionTypeArg(..), Ident(..), Lit(..), Statement(..), Type(..))

prettyPrint :: Decl -> String
prettyPrint = pretty 0 <<< ppDecl

ppDecl :: Decl -> DOC
ppDecl (Enum ms i ds) = ppContainerDecl "enum" ms i ds
ppDecl (Extension ms i ds) = ppContainerDecl "extension" ms i ds
ppDecl (Import i) = text "import " <> ppIdent i
ppDecl (TopLevel ss) = ppStatements ss
ppDecl (Constant ms i mt e) = group $ intercalate (text " ")
  [ ppDeclMods ms, text "let", ident, text "=", ppExp e ]
  where
  ident = maybe' (\_ -> ppIdent i) (\t -> ppIdent i <> text ": " <> ppType t) mt

ppIdent :: Ident -> DOC
ppIdent (Ident i) = text i

ppContainerDecl
  :: String
  -> List DeclMod
  -> Ident
  -> List Decl
  -> DOC
ppContainerDecl name ms i ds = group $ intercalate (text " ")
  [ ppDeclMods ms, text name, ppIdent i, ppBrace ds ]

ppDeclMods :: List DeclMod -> DOC
ppDeclMods ms = spread $ map ppDeclMod ms

ppDeclMod :: DeclMod -> DOC
ppDeclMod Static = text "static"
ppDeclMod (AccessModifier a) = ppAccessMod a

ppAccessMod :: AccessMod -> DOC
ppAccessMod Private = text "private"
ppAccessMod PrivateSet = text "private(set)"
ppAccessMod FilePrivate = text "fileprivate"
ppAccessMod FilePrivateSet = text "fileprivate(set)"
ppAccessMod Internal = text "internal"
ppAccessMod InternalSet = text "internal(set)"
ppAccessMod Public = text "public"
ppAccessMod PublicSet = text "public(set)"
ppAccessMod Open = text "open"
ppAccessMod OpenSet = text "open(set)"

ppBrace :: List Decl -> DOC
ppBrace Nil = text "{}"
ppBrace ds = bracket "{" (ppDecls ds) "}"

ppDecls :: List Decl -> DOC
ppDecls Nil = nil
ppDecls (Cons d Nil) = ppDecl d
ppDecls (Cons d ds) = ppDecl d <> line <> ppDecls ds

ppList :: String -> String -> List Exp -> DOC
ppList l r Nil = text l <> text r
ppList l r (Cons e Nil) = text l <> ppExp e <> text r
ppList l r es = text l <> bracket "" (ppListItems es) "" <> text r
  where
  ppListItems :: List Exp -> DOC
  ppListItems Nil = nil
  ppListItems (Cons e' Nil) = ppExp e'
  ppListItems (Cons e' es') = ppExp e' <> text "," <> line <> ppListItems es'

ppExp :: Exp -> DOC
ppExp (Literal l) = ppLit l
ppExp (Closure as r ss) = ppClosure as r ss
ppExp (Identifier i) = ppIdent i
ppExp (ExplicitMember e i) = ppExp e <> text "." <> ppIdent i
ppExp (FunctionCall e es) = ppExp e <> ppList "(" ")" es

ppLit :: Lit -> DOC
ppLit (IntLit i) = text $ show i
ppLit (FloatLit f) = text $ show f
ppLit (CharLit c) = text $ show $ String.singleton c
ppLit (StringLit s) = text $ show s
ppLit (BooleanLit b) = text $ show b
ppLit (ArrayLit es) = ppList "[" "]" es
ppLit (DictLit m) =
  case Map.toAscUnfoldable m of
    Nil -> text "[:]"
    (Cons t Nil) -> text "[" <> ppDictItem t <> text "]"
    ts -> text "[" <> bracket "" (ppDictItems ts) "" <> text "]"
  where
  ppDictItems :: List (Tuple Exp Exp) -> DOC
  ppDictItems Nil = nil
  ppDictItems (Cons t Nil) = ppDictItem t
  ppDictItems (Cons t ts) = ppDictItem t <> text "," <> line <> ppDictItems ts

  ppDictItem :: Tuple Exp Exp -> DOC
  ppDictItem (Tuple k v) = ppExp k <> text ": " <> ppExp v

ppClosure :: List FunctionTypeArg -> Type -> List Statement -> DOC
ppClosure _ _ Nil = text "{}"
ppClosure as r ss =
  text "{ " <> ppFunctionType as r <> text " in"
    <> bracket "" (ppStatements ss) ""
    <> text "}"

ppStatements :: List Statement -> DOC
ppStatements ss = stack $ map ppStatement ss

ppStatement :: Statement -> DOC
ppStatement (Return e) = maybe nil (\e' -> text "return " <> ppExp e') e
ppStatement (Declaration d) = ppDecl d
ppStatement (Expression e) = ppExp e

ppType :: Type -> DOC
ppType (FunctionType as r) = ppFunctionType as r
ppType AnyType = text "Any"
ppType VoidType = text "Void"
ppType IntType = text "Int"
ppType FloatType = text "Float"
ppType CharType = text "Character"
ppType StringType = text "String"
ppType BoolType = text "Bool"

ppFunctionType :: List FunctionTypeArg -> Type -> DOC
ppFunctionType Nil r = ppType r
ppFunctionType args r = ppFunctionTypeArgs args <> text " -> " <> ppType r
  where
  ppFunctionTypeArgs :: List FunctionTypeArg -> DOC
  ppFunctionTypeArgs args' =
    text "(" <> (intercalate (text ", ") $ ppFunctionTypeArg <$> args') <> text ")"

  ppFunctionTypeArg :: FunctionTypeArg -> DOC
  ppFunctionTypeArg (FunctionTypeArg e i atts t) =
    let
      labels = ppArgLabels e i
      attributes = ppAttributes atts
      typ = Just $ ppType t
    in
      intercalate (text " ") $ Array.catMaybes [ labels, attributes, typ ]

  ppArgLabels :: Maybe Ident -> Maybe Ident -> Maybe DOC
  ppArgLabels e i = do
    _ <- i
    let
      external = ppIdent <$> e
      internal = ppIdent <$> i
      labels = Array.catMaybes [ external, internal ]
      intercalated = intercalate (text " ") labels
    pure $ intercalated <> text ":"

  ppAttributes :: List Attribute -> Maybe DOC
  ppAttributes Nil = Nothing
  ppAttributes as = Just $ intercalate (text " ") $ ppAttribute <$> as

  ppAttribute :: Attribute -> DOC
  ppAttribute Autoclosure = text "@autoclosure"
  ppAttribute Escaping = text "@escaping"