Remove stray log

Remove stray log

module Main where

import Prelude

import Data.Argonaut.Core (stringify)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Encode (encodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Array as Array
import Data.DateTime (DateTime)
import Data.DateTime.Instant (toDateTime)
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.Maybe (Maybe(..), maybe)
import Data.Set as Set
import Data.String as Str
import Data.Traversable (traverse)
import Effect (Effect)
import Effect.Console as Console
import Effect.Exception (catchException, throw, throwException)
import Effect.Now (now)
import Effect.Ref as Ref
import Foreign.Object as FO
import Node.ChildProcess as Child
import Node.Encoding as Encoding
import Node.FS.Stats as Stats
import Node.FS.Sync as File
import Node.Path as Path
import Node.Platform (Platform(Win32))
import Node.Process as Process
import Node.Stream as Stream
import Partial.Unsafe (unsafePartial)
import Psa (PsaOptions, StatVerbosity(..), parsePsaResult, parsePsaError, encodePsaError, output)
import Psa.Printer.Default as DefaultPrinter
import Psa.Printer.Json as JsonPrinter

foreign import version :: String

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

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

parseOptions
  :: PsaOptions
  -> Array String
  -> Effect ParseOptions
parseOptions opts args =
  defaultLibDir <$>
    Array.foldM parse
      { extra: []
      , purs: "purs"
      , 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 { statVerbosity = VerboseStats } }

    | arg == "--censor-stats" =
      pure p { opts = p.opts { statVerbosity = NoStats } }

    | 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-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.Pattern ",") (Str.drop 15 arg)) } }

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

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

    | isPrefix "--purs=" arg =
      pure p { purs = Str.drop 7 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 (Str.Pattern 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

main :: Effect Unit
main = void do
  cwd <- Process.cwd
  argv <- Array.drop 2 <$> Process.argv

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

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

  stashData <-
    if stash
      then readStashFile stashFile
      else emptyStash

  spawn' purs args \buffer -> do
    let stderr = Str.split (Str.Pattern "\n") buffer
    for_ stderr \err ->
      case jsonParser err >>= decodeJson >>= parsePsaResult of
        Left _ -> Console.error err
        Right out -> do
          files <- Ref.new FO.empty
          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 JsonPrinter.print out'
            else DefaultPrinter.print opts' out'
          if FO.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, unsafePartial (Array.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 <- Ref.new ""
    Stream.onDataString (Child.stderr child) Encoding.UTF8 \chunk ->
      Ref.modify_ (_ <> chunk) buffer
    Child.onExit child \status ->
      case status of
        Child.Normally n -> do
          Ref.read 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 == Just Win32
       then
         case Str.stripSuffix (Str.Pattern ".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
    cache <- FO.lookup filename <$> Ref.read files
    contents <-
      case cache of
        Just lines -> pure lines
        Nothing -> do
          lines <- Str.split (Str.Pattern "\n") <$> File.readTextFile Encoding.UTF8 filename
          Ref.modify_ (FO.insert filename lines) files
          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 :: forall a. Effect { date :: DateTime, stash :: Array a }
  emptyStash = { date: _ , stash: [] } <$> toDateTime <$> 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 = stringify (encodeStash warnings)
    File.writeTextFile Encoding.UTF8 stashFile file

  mergeWarnings filenames date old new = do
    fileStat <- Ref.new FO.empty
    old' <- flip Array.filterA old \x ->
      case x.filename of
        Nothing -> pure false
        Just f ->
          if Set.member f filenames
            then pure false
            else do
              stat <- FO.lookup f <$> Ref.read fileStat
              case stat of
                Just s -> pure s
                Nothing -> do
                  s <- catchException (\_ -> pure false) $
                    (date > _) <<< Stats.modifiedTime <$> File.stat f
                  _ <- Ref.modify_ (FO.insert f s) fileStat
                  pure s
    pure $ old' <> new

usage :: String
usage = """psa - Error/Warning reporting frontend for 'purs compile'

Usage: psa [--censor-lib] [--censor-src]
           [--censor-codes=CODES] [--filter-codes=CODES]
           [--no-colors] [--no-source]
           [--is-lib=DIR] [--purs=PURS] [--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-stats         Censor warning/error summary
  --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')
  --purs=PURS            Name of purs executable (defaults to 'purs')

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

module Main where

import Prelude

import Data.Argonaut.Core (stringify)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Encode (encodeJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Array as Array
import Data.DateTime (DateTime)
import Data.DateTime.Instant (toDateTime)
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.Maybe (Maybe(..), maybe)
import Data.Set as Set
import Data.String as Str
import Data.Traversable (traverse)
import Effect (Effect)
import Effect.Console as Console
import Effect.Exception (catchException, throw, throwException)
import Effect.Now (now)
import Effect.Ref as Ref
import Foreign.Object as FO
import Node.ChildProcess as Child
import Node.Encoding as Encoding
import Node.FS.Stats as Stats
import Node.FS.Sync as File
import Node.Path as Path
import Node.Platform (Platform(Win32))
import Node.Process as Process
import Node.Stream as Stream
import Partial.Unsafe (unsafePartial)
import Psa (PsaOptions, StatVerbosity(..), parsePsaResult, parsePsaError, encodePsaError, output)
import Psa.Printer.Default as DefaultPrinter
import Psa.Printer.Json as JsonPrinter
import Unsafe.Coerce (unsafeCoerce)

foreign import version :: String

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

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

parseOptions
  :: PsaOptions
  -> Array String
  -> Effect ParseOptions
parseOptions opts args =
  defaultLibDir <$>
    Array.foldM parse
      { extra: []
      , purs: "purs"
      , 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 { statVerbosity = VerboseStats } }

    | arg == "--censor-stats" =
      pure p { opts = p.opts { statVerbosity = NoStats } }

    | 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-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.Pattern ",") (Str.drop 15 arg)) } }

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

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

    | isPrefix "--purs=" arg =
      pure p { purs = Str.drop 7 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 (Str.Pattern 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

main :: Effect Unit
main = void do
  cwd <- Process.cwd
  argv <- Array.drop 2 <$> Process.argv

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

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

  Console.log (unsafeCoerce opts')
  stashData <-
    if stash
      then readStashFile stashFile
      else emptyStash

  spawn' purs args \buffer -> do
    let stderr = Str.split (Str.Pattern "\n") buffer
    for_ stderr \err ->
      case jsonParser err >>= decodeJson >>= parsePsaResult of
        Left _ -> Console.error err
        Right out -> do
          files <- Ref.new FO.empty
          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 JsonPrinter.print out'
            else DefaultPrinter.print opts' out'
          if FO.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, unsafePartial (Array.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 <- Ref.new ""
    Stream.onDataString (Child.stderr child) Encoding.UTF8 \chunk ->
      Ref.modify_ (_ <> chunk) buffer
    Child.onExit child \status ->
      case status of
        Child.Normally n -> do
          Ref.read 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 == Just Win32
       then
         case Str.stripSuffix (Str.Pattern ".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
    cache <- FO.lookup filename <$> Ref.read files
    contents <-
      case cache of
        Just lines -> pure lines
        Nothing -> do
          lines <- Str.split (Str.Pattern "\n") <$> File.readTextFile Encoding.UTF8 filename
          Ref.modify_ (FO.insert filename lines) files
          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 :: forall a. Effect { date :: DateTime, stash :: Array a }
  emptyStash = { date: _ , stash: [] } <$> toDateTime <$> 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 = stringify (encodeStash warnings)
    File.writeTextFile Encoding.UTF8 stashFile file

  mergeWarnings filenames date old new = do
    fileStat <- Ref.new FO.empty
    old' <- flip Array.filterA old \x ->
      case x.filename of
        Nothing -> pure false
        Just f ->
          if Set.member f filenames
            then pure false
            else do
              stat <- FO.lookup f <$> Ref.read fileStat
              case stat of
                Just s -> pure s
                Nothing -> do
                  s <- catchException (\_ -> pure false) $
                    (date > _) <<< Stats.modifiedTime <$> File.stat f
                  _ <- Ref.modify_ (FO.insert f s) fileStat
                  pure s
    pure $ old' <> new

usage :: String
usage = """psa - Error/Warning reporting frontend for 'purs compile'

Usage: psa [--censor-lib] [--censor-src]
           [--censor-codes=CODES] [--filter-codes=CODES]
           [--no-colors] [--no-source]
           [--is-lib=DIR] [--purs=PURS] [--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-stats         Censor warning/error summary
  --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')
  --purs=PURS            Name of purs executable (defaults to 'purs')

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


union fns

union fns

module Data.Array.NonEmpty
  ( NonEmptyArray
  , fromArray
  , fromNonEmpty
  , toArray
  , toNonEmpty

  , fromFoldable
  , fromFoldable1
  , toUnfoldable
  , singleton
  , (..), range
  , replicate
  , some

  , length

  , (:), cons
  , cons'
  , snoc
  , snoc'
  , appendArray
  , insert
  , insertBy

  , head
  , last
  , tail
  , init
  , uncons
  , unsnoc

  , (!!), index
  , elemIndex
  , elemLastIndex
  , findIndex
  , findLastIndex
  , insertAt
  , deleteAt
  , updateAt
  , updateAtIndices
  , modifyAt
  , modifyAtIndices
  , alterAt

  , reverse
  , concat
  , concatMap
  , filter
  , partition
  , filterA
  , mapMaybe
  , catMaybes

  , sort
  , sortBy
  , sortWith
  , slice
  , take
  , takeEnd
  , takeWhile
  , drop
  , dropEnd
  , dropWhile
  , span

-- TODO
--  , group
--  , group'
--  , groupBy

  , nub
  , nubBy
  , union
  , union'
  , unionBy
  , unionBy'
  , delete
  , deleteBy

--  , (\\), difference
--  , intersect
--  , intersectBy

  , zipWith
  , zipWithA
  , zip
  , unzip

  , foldM
  , foldRecM

  , unsafeIndex

--  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Lazy (class Lazy)
import Control.Monad.Rec.Class (class MonadRec)
import Data.Array as A
import Data.Bifunctor (bimap)
import Data.Eq (class Eq1)
import Data.Foldable (class Foldable)
import Data.FoldableWithIndex (class FoldableWithIndex)
import Data.FunctorWithIndex (class FunctorWithIndex)
import Data.Maybe (Maybe(..), fromJust)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Ord (class Ord1)
import Data.Semigroup.Foldable (class Foldable1)
import Data.Traversable (class Traversable)
import Data.TraversableWithIndex (class TraversableWithIndex)
import Data.Tuple (Tuple)
import Data.Unfoldable (class Unfoldable)
import Partial.Unsafe (unsafePartial)

newtype NonEmptyArray a = NonEmptyArray (Array a)

instance showNonEmptyArray :: Show a => Show (NonEmptyArray a) where
  show (NonEmptyArray xs) = "(NonEmptyArray " <> show xs <> ")"

derive newtype instance eqNonEmptyArray :: Eq a => Eq (NonEmptyArray a)
derive newtype instance eq1NonEmptyArray :: Eq1 NonEmptyArray

derive newtype instance ordNonEmptyArray :: Ord a => Ord (NonEmptyArray a)
derive newtype instance ord1NonEmptyArray :: Ord1 NonEmptyArray

derive newtype instance functorNonEmptyArray :: Functor NonEmptyArray
derive newtype instance functorWithIndexNonEmptyArray :: FunctorWithIndex Int NonEmptyArray

derive newtype instance foldableNonEmptyArray :: Foldable NonEmptyArray
derive newtype instance foldableWithIndexNonEmptyArray :: FoldableWithIndex Int NonEmptyArray

derive newtype instance traversableNonEmptyArray :: Traversable NonEmptyArray
derive newtype instance traversableWithIndexNonEmptyArray :: TraversableWithIndex Int NonEmptyArray

derive newtype instance applyNonEmptyArray :: Apply NonEmptyArray

derive newtype instance applicativeNonEmptyArray :: Applicative NonEmptyArray

derive newtype instance bindNonEmptyArray :: Bind NonEmptyArray

derive newtype instance monadNonEmptyArray :: Monad NonEmptyArray

derive newtype instance altNonEmptyArray :: Alt NonEmptyArray

-- | Internal - adapt an Array transform to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt :: forall a b. (Array a -> Array b) -> NonEmptyArray a -> NonEmptyArray b
unsafeAdapt f = NonEmptyArray <<< adaptAny f

-- | Internal - adapt an Array transform with argument to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt' :: forall a b c. (a -> Array b -> Array c) -> a -> NonEmptyArray b -> NonEmptyArray c
unsafeAdapt' f = unsafeAdapt <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt'' :: forall a b c d. (a -> b -> Array c -> Array d) -> a -> b -> NonEmptyArray c -> NonEmptyArray d
unsafeAdapt'' f = unsafeAdapt' <<< f

-- | Internal - adapt an Array transform to NonEmptyArray,
--   with polymorphic result.
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
adaptAny :: forall a b. (Array a -> b) -> NonEmptyArray a -> b
adaptAny f = f <<< toArray

-- | Internal - adapt an Array transform with argument to NonEmptyArray,
--   with polymorphic result.
adaptAny' :: forall a b c. (a -> Array b -> c) -> a -> NonEmptyArray b -> c
adaptAny' f = adaptAny <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray,
--   with polymorphic result.
adaptAny'' :: forall a b c d. (a -> b -> Array c -> d) -> a -> b -> NonEmptyArray c -> d
adaptAny'' f = adaptAny' <<< f

-- | Internal - adapt Array functions returning Maybes to NonEmptyArray
adaptMaybe :: forall a b. (Array a -> Maybe b) -> NonEmptyArray a -> b
adaptMaybe f = unsafePartial $ fromJust <<< f <<< toArray

fromArray :: forall a. Array a -> Maybe (NonEmptyArray a)
fromArray xs
  | A.length xs > 0 = Just (NonEmptyArray xs)
  | otherwise       = Nothing

-- | INTERNAL
unsafeFromArray :: forall a. Array a -> NonEmptyArray a
unsafeFromArray = NonEmptyArray

fromNonEmpty :: forall a. NonEmpty Array a -> NonEmptyArray a
fromNonEmpty (x :| xs) = cons' x xs

toArray :: forall a. NonEmptyArray a -> Array a
toArray (NonEmptyArray xs) = xs

toNonEmpty :: forall a. NonEmptyArray a -> NonEmpty Array a
toNonEmpty = uncons >>> \{head: x, tail: xs} -> x :| xs

fromFoldable :: forall f a. Foldable f => f a -> Maybe (NonEmptyArray a)
fromFoldable = fromArray <<< A.fromFoldable

fromFoldable1 :: forall f a. Foldable1 f => f a -> NonEmptyArray a
fromFoldable1 = unsafeFromArray <<< A.fromFoldable

toUnfoldable :: forall f a. Unfoldable f => NonEmptyArray a -> f a
toUnfoldable = adaptAny A.toUnfoldable

singleton :: forall a. a -> NonEmptyArray a
singleton = NonEmptyArray <<< A.singleton

range :: Int -> Int -> Maybe (NonEmptyArray Int)
range x y = fromArray $ A.range x y

infix 8 range as ..

replicate :: forall a. Int -> a -> Maybe (NonEmptyArray a)
replicate i x
  | i > 0     = Just $ NonEmptyArray $ A.replicate i x
  | otherwise = Nothing

some
  :: forall f a
   . Alternative f
  => Lazy (f (Array a))
  => f a -> f (NonEmptyArray a)
some = map NonEmptyArray <<< A.some

length :: forall a. NonEmptyArray a -> Int
length = adaptAny A.length

cons :: forall a. a -> NonEmptyArray a -> NonEmptyArray a
cons = unsafeAdapt' A.cons

infixr 6 cons as :

cons' :: forall a. a -> Array a -> NonEmptyArray a
cons' x xs = unsafeFromArray $ A.cons x xs

snoc :: forall a. NonEmptyArray a -> a -> NonEmptyArray a
snoc xs x = unsafeFromArray $ A.snoc (toArray xs) x

snoc' :: forall a. Array a -> a -> NonEmptyArray a
snoc' xs x = unsafeFromArray $ A.snoc xs x

appendArray :: forall a. NonEmptyArray a -> Array a -> NonEmptyArray a
appendArray xs ys = unsafeFromArray $ toArray xs <> ys

insert :: forall a. Ord a => a -> NonEmptyArray a -> NonEmptyArray a
insert = unsafeAdapt' A.insert

insertBy :: forall a. (a -> a -> Ordering) -> a -> NonEmptyArray a -> NonEmptyArray a
insertBy = unsafeAdapt'' A.insertBy

head :: forall a. NonEmptyArray a -> a
head = adaptMaybe A.head

last :: forall a. NonEmptyArray a -> a
last = adaptMaybe A.last

tail :: forall a. NonEmptyArray a -> Array a
tail = adaptMaybe A.tail

init :: forall a. NonEmptyArray a -> Array a
init = adaptMaybe A.init

uncons :: forall a. NonEmptyArray a -> { head :: a, tail :: Array a }
uncons = adaptMaybe A.uncons

unsnoc :: forall a. NonEmptyArray a -> { init :: Array a, last :: a }
unsnoc = adaptMaybe A.unsnoc

index :: forall a. NonEmptyArray a -> Int -> Maybe a
index = adaptAny A.index

infixl 8 index as !!

elemIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemIndex = adaptAny' A.elemIndex

elemLastIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemLastIndex = adaptAny' A.elemLastIndex

findIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findIndex = adaptAny' A.findIndex

findLastIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findLastIndex = adaptAny' A.findLastIndex

insertAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
insertAt i x = map NonEmptyArray <<< A.insertAt i x <<< toArray

deleteAt :: forall a. Int -> NonEmptyArray a -> Maybe (Array a)
deleteAt = adaptAny' A.deleteAt

updateAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
updateAt i x = map NonEmptyArray <<< A.updateAt i x <<< toArray

updateAtIndices :: forall t a. Foldable t => t (Tuple Int a) -> NonEmptyArray a -> NonEmptyArray a
updateAtIndices = unsafeAdapt' A.updateAtIndices

modifyAt :: forall a. Int -> (a -> a) -> NonEmptyArray a -> Maybe (NonEmptyArray a)
modifyAt i f = map NonEmptyArray <<< A.modifyAt i f <<< toArray

modifyAtIndices :: forall t a. Foldable t => t Int -> (a -> a) -> NonEmptyArray a -> NonEmptyArray a
modifyAtIndices = unsafeAdapt'' A.modifyAtIndices

alterAt :: forall a. Int -> (a -> Maybe a) -> NonEmptyArray a -> Maybe (Array a)
alterAt i f = A.alterAt i f <<< toArray

reverse :: forall a. NonEmptyArray a -> NonEmptyArray a
reverse = unsafeAdapt A.reverse

concat :: forall a. NonEmptyArray (NonEmptyArray a) -> NonEmptyArray a
concat = NonEmptyArray <<< A.concat <<< toArray <<< map toArray

concatMap :: forall a b. (a -> NonEmptyArray b) -> NonEmptyArray a -> NonEmptyArray b
concatMap = flip bind

filter :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
filter = adaptAny' A.filter

partition
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { yes :: Array a, no :: Array a}
partition = adaptAny' A.partition

filterA
  :: forall a f
   . Applicative f
  => (a -> f Boolean)
  -> NonEmptyArray a
  -> f (Array a)
filterA = adaptAny' A.filterA

mapMaybe :: forall a b. (a -> Maybe b) -> NonEmptyArray a -> Array b
mapMaybe = adaptAny' A.mapMaybe

catMaybes :: forall a. NonEmptyArray (Maybe a) -> Array a
catMaybes = adaptAny A.catMaybes

sort :: forall a. Ord a => NonEmptyArray a -> NonEmptyArray a
sort = unsafeAdapt A.sort

sortBy :: forall a. (a -> a -> Ordering) -> NonEmptyArray a -> NonEmptyArray a
sortBy = unsafeAdapt' A.sortBy

sortWith :: forall a b. Ord b => (a -> b) -> NonEmptyArray a -> NonEmptyArray a
sortWith = unsafeAdapt' A.sortWith

slice :: forall a. Int -> Int -> NonEmptyArray a -> Array a
slice = adaptAny'' A.slice

take :: forall a. Int -> NonEmptyArray a -> Array a
take = adaptAny' A.take

takeEnd :: forall a. Int -> NonEmptyArray a -> Array a
takeEnd = adaptAny' A.takeEnd

takeWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
takeWhile = adaptAny' A.takeWhile

drop :: forall a. Int -> NonEmptyArray a -> Array a
drop = adaptAny' A.drop

dropEnd :: forall a. Int -> NonEmptyArray a -> Array a
dropEnd = adaptAny' A.dropEnd

dropWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
dropWhile = adaptAny' A.dropWhile

span
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { init :: Array a, rest :: Array a }
span = adaptAny' A.span

--TODO
--group :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

--TODO
--group' :: forall a. Ord a => NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

--TODO
--groupBy :: forall a. (a -> a -> Boolean) -> NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

nub :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a
nub = unsafeAdapt A.nub

nubBy :: forall a. (a -> a -> Boolean) -> NonEmptyArray a -> NonEmptyArray a
nubBy = unsafeAdapt' A.nubBy

union :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a -> NonEmptyArray a
union = unionBy (==)

union' :: forall a. Eq a => NonEmptyArray a -> Array a -> NonEmptyArray a
union' = unionBy' (==)

unionBy
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> NonEmptyArray a
  -> NonEmptyArray a
unionBy eq xs ys = unsafeFromArray $ A.unionBy eq (toArray xs) (toArray ys)

unionBy'
  :: forall a
   . (a -> a -> Boolean)
  -> NonEmptyArray a
  -> Array a
  -> NonEmptyArray a
unionBy' eq xs = unsafeFromArray <<< A.unionBy eq (toArray xs)

delete :: forall a. Eq a => a -> NonEmptyArray a -> Array a
delete = adaptAny' A.delete

deleteBy :: forall a. (a -> a -> Boolean) -> a -> NonEmptyArray a -> Array a
deleteBy = adaptAny'' A.deleteBy

zipWith
  :: forall a b c
   . (a -> b -> c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> NonEmptyArray c
zipWith f xs ys = NonEmptyArray $ A.zipWith f (toArray xs) (toArray ys)

zipWithA
  :: forall m a b c
   . Applicative m
  => (a -> b -> m c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> m (NonEmptyArray c)
zipWithA f xs ys = NonEmptyArray <$> A.zipWithA f (toArray xs) (toArray ys)

zip :: forall a b. NonEmptyArray a -> NonEmptyArray b -> NonEmptyArray (Tuple a b)
zip xs ys = NonEmptyArray $ toArray xs `A.zip` toArray ys

unzip :: forall a b. NonEmptyArray (Tuple a b) -> Tuple (NonEmptyArray a) (NonEmptyArray b)
unzip = bimap NonEmptyArray NonEmptyArray <<< A.unzip <<< toArray

foldM :: forall m a b. Monad m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldM = adaptAny'' A.foldM

foldRecM :: forall m a b. MonadRec m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldRecM = adaptAny'' A.foldRecM

unsafeIndex :: forall a. Partial => NonEmptyArray a -> Int -> a
unsafeIndex = adaptAny A.unsafeIndex

module Data.Array.NonEmpty
  ( NonEmptyArray
  , fromArray
  , fromNonEmpty
  , toArray
  , toNonEmpty

  , fromFoldable
  , fromFoldable1
  , toUnfoldable
  , singleton
  , (..), range
  , replicate
  , some
-- TODO
--  , many

  , length

  , (:), cons
  , cons'
  , snoc
  , snoc'
  , appendArray
  , insert
  , insertBy

  , head
  , last
  , tail
  , init
  , uncons
  , unsnoc

  , (!!), index
  , elemIndex
  , elemLastIndex
  , findIndex
  , findLastIndex
  , insertAt
  , deleteAt
  , updateAt
  , updateAtIndices
  , modifyAt
  , modifyAtIndices
  , alterAt

  , reverse
  , concat
  , concatMap
  , filter
  , partition
  , filterA
  , mapMaybe
  , catMaybes

  , sort
  , sortBy
  , sortWith
  , slice
  , take
  , takeEnd
  , takeWhile
  , drop
  , dropEnd
  , dropWhile
  , span

-- TODO
--  , group
--  , group'
--  , groupBy

  , nub
  , nubBy
--  , union
--  , unionBy
  , delete
  , deleteBy

--  , (\\), difference
--  , intersect
--  , intersectBy

  , zipWith
  , zipWithA
  , zip
  , unzip

  , foldM
  , foldRecM

  , unsafeIndex

--  , module Exports
  ) where

import Prelude

import Control.Alt (class Alt)
import Control.Alternative (class Alternative)
import Control.Lazy (class Lazy)
import Control.Monad.Rec.Class (class MonadRec)
import Data.Array as A
import Data.Bifunctor (bimap)
import Data.Eq (class Eq1)
import Data.Foldable (class Foldable)
import Data.FoldableWithIndex (class FoldableWithIndex)
import Data.FunctorWithIndex (class FunctorWithIndex)
import Data.Maybe (Maybe(..), fromJust)
import Data.NonEmpty (NonEmpty, (:|))
import Data.Ord (class Ord1)
import Data.Semigroup.Foldable (class Foldable1)
import Data.Traversable (class Traversable)
import Data.TraversableWithIndex (class TraversableWithIndex)
import Data.Tuple (Tuple)
import Data.Unfoldable (class Unfoldable)
import Partial.Unsafe (unsafePartial)

newtype NonEmptyArray a = NonEmptyArray (Array a)

instance showNonEmptyArray :: Show a => Show (NonEmptyArray a) where
  show (NonEmptyArray xs) = "(NonEmptyArray " <> show xs <> ")"

derive newtype instance eqNonEmptyArray :: Eq a => Eq (NonEmptyArray a)
derive newtype instance eq1NonEmptyArray :: Eq1 NonEmptyArray

derive newtype instance ordNonEmptyArray :: Ord a => Ord (NonEmptyArray a)
derive newtype instance ord1NonEmptyArray :: Ord1 NonEmptyArray

derive newtype instance functorNonEmptyArray :: Functor NonEmptyArray
derive newtype instance functorWithIndexNonEmptyArray :: FunctorWithIndex Int NonEmptyArray

derive newtype instance foldableNonEmptyArray :: Foldable NonEmptyArray
derive newtype instance foldableWithIndexNonEmptyArray :: FoldableWithIndex Int NonEmptyArray

derive newtype instance traversableNonEmptyArray :: Traversable NonEmptyArray
derive newtype instance traversableWithIndexNonEmptyArray :: TraversableWithIndex Int NonEmptyArray

derive newtype instance applyNonEmptyArray :: Apply NonEmptyArray

derive newtype instance applicativeNonEmptyArray :: Applicative NonEmptyArray

derive newtype instance bindNonEmptyArray :: Bind NonEmptyArray

derive newtype instance monadNonEmptyArray :: Monad NonEmptyArray

derive newtype instance altNonEmptyArray :: Alt NonEmptyArray

-- | Internal - adapt an Array transform to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt :: forall a b. (Array a -> Array b) -> NonEmptyArray a -> NonEmptyArray b
unsafeAdapt f = NonEmptyArray <<< adaptAny f

-- | Internal - adapt an Array transform with argument to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt' :: forall a b c. (a -> Array b -> Array c) -> a -> NonEmptyArray b -> NonEmptyArray c
unsafeAdapt' f = unsafeAdapt <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
unsafeAdapt'' :: forall a b c d. (a -> b -> Array c -> Array d) -> a -> b -> NonEmptyArray c -> NonEmptyArray d
unsafeAdapt'' f = unsafeAdapt' <<< f

-- | Internal - adapt an Array transform to NonEmptyArray,
--   with polymorphic result.
--
-- Note that this is unsafe: if the transform returns an empty array, this can
-- explode at runtime.
adaptAny :: forall a b. (Array a -> b) -> NonEmptyArray a -> b
adaptAny f = f <<< toArray

-- | Internal - adapt an Array transform with argument to NonEmptyArray,
--   with polymorphic result.
adaptAny' :: forall a b c. (a -> Array b -> c) -> a -> NonEmptyArray b -> c
adaptAny' f = adaptAny <<< f

-- | Internal - adapt an Array transform with two arguments to NonEmptyArray,
--   with polymorphic result.
adaptAny'' :: forall a b c d. (a -> b -> Array c -> d) -> a -> b -> NonEmptyArray c -> d
adaptAny'' f = adaptAny' <<< f

-- | Internal - adapt Array functions returning Maybes to NonEmptyArray
adaptMaybe :: forall a b. (Array a -> Maybe b) -> NonEmptyArray a -> b
adaptMaybe f = unsafePartial $ fromJust <<< f <<< toArray

fromArray :: forall a. Array a -> Maybe (NonEmptyArray a)
fromArray xs
  | A.length xs > 0 = Just (NonEmptyArray xs)
  | otherwise       = Nothing

-- | INTERNAL
unsafeFromArray :: forall a. Array a -> NonEmptyArray a
unsafeFromArray = NonEmptyArray

fromNonEmpty :: forall a. NonEmpty Array a -> NonEmptyArray a
fromNonEmpty (x :| xs) = cons' x xs

toArray :: forall a. NonEmptyArray a -> Array a
toArray (NonEmptyArray xs) = xs

toNonEmpty :: forall a. NonEmptyArray a -> NonEmpty Array a
toNonEmpty = uncons >>> \{head: x, tail: xs} -> x :| xs

fromFoldable :: forall f a. Foldable f => f a -> Maybe (NonEmptyArray a)
fromFoldable = fromArray <<< A.fromFoldable

fromFoldable1 :: forall f a. Foldable1 f => f a -> NonEmptyArray a
fromFoldable1 = unsafeFromArray <<< A.fromFoldable

toUnfoldable :: forall f a. Unfoldable f => NonEmptyArray a -> f a
toUnfoldable = adaptAny A.toUnfoldable

singleton :: forall a. a -> NonEmptyArray a
singleton = NonEmptyArray <<< A.singleton

range :: Int -> Int -> Maybe (NonEmptyArray Int)
range x y = fromArray $ A.range x y

infix 8 range as ..

replicate :: forall a. Int -> a -> Maybe (NonEmptyArray a)
replicate i x
  | i > 0     = Just $ NonEmptyArray $ A.replicate i x
  | otherwise = Nothing

some
  :: forall f a
   . Alternative f
  => Lazy (f (Array a))
  => f a -> f (NonEmptyArray a)
some = map NonEmptyArray <<< A.some

length :: forall a. NonEmptyArray a -> Int
length = adaptAny A.length

cons :: forall a. a -> NonEmptyArray a -> NonEmptyArray a
cons = unsafeAdapt' A.cons

infixr 6 cons as :

cons' :: forall a. a -> Array a -> NonEmptyArray a
cons' x xs = unsafeFromArray $ A.cons x xs

snoc :: forall a. NonEmptyArray a -> a -> NonEmptyArray a
snoc xs x = unsafeFromArray $ A.snoc (toArray xs) x

snoc' :: forall a. Array a -> a -> NonEmptyArray a
snoc' xs x = unsafeFromArray $ A.snoc xs x

appendArray :: forall a. NonEmptyArray a -> Array a -> NonEmptyArray a
appendArray xs ys = unsafeFromArray $ toArray xs <> ys

insert :: forall a. Ord a => a -> NonEmptyArray a -> NonEmptyArray a
insert = unsafeAdapt' A.insert

insertBy :: forall a. (a -> a -> Ordering) -> a -> NonEmptyArray a -> NonEmptyArray a
insertBy = unsafeAdapt'' A.insertBy

head :: forall a. NonEmptyArray a -> a
head = adaptMaybe A.head

last :: forall a. NonEmptyArray a -> a
last = adaptMaybe A.last

tail :: forall a. NonEmptyArray a -> Array a
tail = adaptMaybe A.tail

init :: forall a. NonEmptyArray a -> Array a
init = adaptMaybe A.init

uncons :: forall a. NonEmptyArray a -> { head :: a, tail :: Array a }
uncons = adaptMaybe A.uncons

unsnoc :: forall a. NonEmptyArray a -> { init :: Array a, last :: a }
unsnoc = adaptMaybe A.unsnoc

index :: forall a. NonEmptyArray a -> Int -> Maybe a
index = adaptAny A.index

infixl 8 index as !!

elemIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemIndex = adaptAny' A.elemIndex

elemLastIndex :: forall a. Eq a => a -> NonEmptyArray a -> Maybe Int
elemLastIndex = adaptAny' A.elemLastIndex

findIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findIndex = adaptAny' A.findIndex

findLastIndex :: forall a. (a -> Boolean) -> NonEmptyArray a -> Maybe Int
findLastIndex = adaptAny' A.findLastIndex

insertAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
insertAt i x = map NonEmptyArray <<< A.insertAt i x <<< toArray

deleteAt :: forall a. Int -> NonEmptyArray a -> Maybe (Array a)
deleteAt = adaptAny' A.deleteAt

updateAt :: forall a. Int -> a -> NonEmptyArray a -> Maybe (NonEmptyArray a)
updateAt i x = map NonEmptyArray <<< A.updateAt i x <<< toArray

updateAtIndices :: forall t a. Foldable t => t (Tuple Int a) -> NonEmptyArray a -> NonEmptyArray a
updateAtIndices = unsafeAdapt' A.updateAtIndices

modifyAt :: forall a. Int -> (a -> a) -> NonEmptyArray a -> Maybe (NonEmptyArray a)
modifyAt i f = map NonEmptyArray <<< A.modifyAt i f <<< toArray

modifyAtIndices :: forall t a. Foldable t => t Int -> (a -> a) -> NonEmptyArray a -> NonEmptyArray a
modifyAtIndices = unsafeAdapt'' A.modifyAtIndices

alterAt :: forall a. Int -> (a -> Maybe a) -> NonEmptyArray a -> Maybe (Array a)
alterAt i f = A.alterAt i f <<< toArray

reverse :: forall a. NonEmptyArray a -> NonEmptyArray a
reverse = unsafeAdapt A.reverse

concat :: forall a. NonEmptyArray (NonEmptyArray a) -> NonEmptyArray a
concat = NonEmptyArray <<< A.concat <<< toArray <<< map toArray

concatMap :: forall a b. (a -> NonEmptyArray b) -> NonEmptyArray a -> NonEmptyArray b
concatMap = flip bind

filter :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
filter = adaptAny' A.filter

partition
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { yes :: Array a, no :: Array a}
partition = adaptAny' A.partition

filterA
  :: forall a f
   . Applicative f
  => (a -> f Boolean)
  -> NonEmptyArray a
  -> f (Array a)
filterA = adaptAny' A.filterA

mapMaybe :: forall a b. (a -> Maybe b) -> NonEmptyArray a -> Array b
mapMaybe = adaptAny' A.mapMaybe

catMaybes :: forall a. NonEmptyArray (Maybe a) -> Array a
catMaybes = adaptAny A.catMaybes

sort :: forall a. Ord a => NonEmptyArray a -> NonEmptyArray a
sort = unsafeAdapt A.sort

sortBy :: forall a. (a -> a -> Ordering) -> NonEmptyArray a -> NonEmptyArray a
sortBy = unsafeAdapt' A.sortBy

sortWith :: forall a b. Ord b => (a -> b) -> NonEmptyArray a -> NonEmptyArray a
sortWith = unsafeAdapt' A.sortWith

slice :: forall a. Int -> Int -> NonEmptyArray a -> Array a
slice = adaptAny'' A.slice

take :: forall a. Int -> NonEmptyArray a -> Array a
take = adaptAny' A.take

takeEnd :: forall a. Int -> NonEmptyArray a -> Array a
takeEnd = adaptAny' A.takeEnd

takeWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
takeWhile = adaptAny' A.takeWhile

drop :: forall a. Int -> NonEmptyArray a -> Array a
drop = adaptAny' A.drop

dropEnd :: forall a. Int -> NonEmptyArray a -> Array a
dropEnd = adaptAny' A.dropEnd

dropWhile :: forall a. (a -> Boolean) -> NonEmptyArray a -> Array a
dropWhile = adaptAny' A.dropWhile

span
  :: forall a
   . (a -> Boolean)
  -> NonEmptyArray a
  -> { init :: Array a, rest :: Array a }
span = adaptAny' A.span

--TODO
--group :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

--TODO
--group' :: forall a. Ord a => NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

--TODO
--groupBy :: forall a. (a -> a -> Boolean) -> NonEmptyArray a -> NonEmptyArray (NonEmptyArray a)

nub :: forall a. Eq a => NonEmptyArray a -> NonEmptyArray a
nub = unsafeAdapt A.nub

nubBy :: forall a. (a -> a -> Boolean) -> NonEmptyArray a -> NonEmptyArray a
nubBy = unsafeAdapt' A.nubBy

delete :: forall a. Eq a => a -> NonEmptyArray a -> Array a
delete = adaptAny' A.delete

deleteBy :: forall a. (a -> a -> Boolean) -> a -> NonEmptyArray a -> Array a
deleteBy = adaptAny'' A.deleteBy

zipWith
  :: forall a b c
   . (a -> b -> c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> NonEmptyArray c
zipWith f xs ys = NonEmptyArray $ A.zipWith f (toArray xs) (toArray ys)

zipWithA
  :: forall m a b c
   . Applicative m
  => (a -> b -> m c)
  -> NonEmptyArray a
  -> NonEmptyArray b
  -> m (NonEmptyArray c)
zipWithA f xs ys = NonEmptyArray <$> A.zipWithA f (toArray xs) (toArray ys)

zip :: forall a b. NonEmptyArray a -> NonEmptyArray b -> NonEmptyArray (Tuple a b)
zip xs ys = NonEmptyArray $ toArray xs `A.zip` toArray ys

unzip :: forall a b. NonEmptyArray (Tuple a b) -> Tuple (NonEmptyArray a) (NonEmptyArray b)
unzip = bimap NonEmptyArray NonEmptyArray <<< A.unzip <<< toArray

foldM :: forall m a b. Monad m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldM = adaptAny'' A.foldM

foldRecM :: forall m a b. MonadRec m => (a -> b -> m a) -> a -> NonEmptyArray b -> m a
foldRecM = adaptAny'' A.foldRecM

unsafeIndex :: forall a. Partial => NonEmptyArray a -> Int -> a
unsafeIndex = adaptAny A.unsafeIndex


Handle IRNull a bit

Handle IRNull a bit

Original commit e6f7ad495551e804dd44299bb30a40a4720ce8f3

module Swift
    ( renderSwiftClass
    ) where

import Prelude

import Doc
import IR

import Data.Foldable (for_, intercalate)
import Data.Function (on)

import Data.List as L
import Data.List.NonEmpty as NE

import Data.Map as M

import Data.Set as S
import Data.Tuple (Tuple(..))

renderSwiftClass :: IRClassData -> Doc Unit
renderSwiftClass { name, properties } = do
    line $ words ["struct", name]
    line "{"
    indent do
        let props = properties # M.toUnfoldable <#> \(Tuple name typ) -> { name, typ }
        let propGroups = L.groupBy (eq `on` _.typ) props
        for_ propGroups renderPropGroup
    line "}"

    blank

    for_ (M.values properties) renderUnions

renderPropGroup :: NE.NonEmptyList { name :: String, typ :: IRType} -> Doc Unit
renderPropGroup props = line do
    let names = intercalate ", " (_.name <$> props)
    words ["let", names <> ":"]
    string " "

    let { typ } = NE.head props
    string $ renderType typ

renderType :: IRType -> String
renderType = case _ of
    IRNothing -> "Any"
    IRNull -> "Any?"
    IRInteger -> "Int"
    IRDouble -> "Double"
    IRBool -> "Bool"
    IRString -> "String"
    IRArray a -> "[" <> renderType a <> "]"
    IRClass { name } -> name
    IRUnion s ->  unionName s

renderUnions :: IRType -> Doc Unit
renderUnions = case _ of
    IRUnion s -> do
        renderUnion s
        for_ (S.toUnfoldable s :: Array _) renderUnions
    IRArray (IRUnion s) -> renderUnion s
    _ -> pure unit

unionName :: S.Set IRType -> String
unionName s = intercalate "Or" $ (caseName <$> S.toUnfoldable s :: Array _)

caseName :: IRType -> String
caseName = case _ of
    IRArray a -> renderType a <> "s"
    IRNull -> "Nullable"
    t -> renderType t

renderUnion :: S.Set IRType -> Doc Unit
renderUnion types = do
    line $ words ["enum", unionName types, "{"]
    indent do
        for_ types \typ -> line do
            string "case ."
            string $ "some" <> caseName typ
            string "("
            string $ renderType typ
            string ")"
    line "}"
    blank

module Swift
    ( renderSwiftClass
    ) where

import Prelude

import Doc
import IR

import Data.Foldable (for_, intercalate)
import Data.Function (on)

import Data.List as L
import Data.List.NonEmpty as NE

import Data.Map as M

import Data.Set as S
import Data.Tuple (Tuple(..))

renderSwiftClass :: IRClassData -> Doc Unit
renderSwiftClass { name, properties } = do
    line $ words ["struct", name]
    line "{"
    indent do
        let props = properties # M.toUnfoldable <#> \(Tuple name typ) -> { name, typ }
        let propGroups = L.groupBy (eq `on` _.typ) props
        for_ propGroups renderPropGroup
    line "}"

    blank

    for_ (M.values properties) renderUnions

renderPropGroup :: NE.NonEmptyList { name :: String, typ :: IRType} -> Doc Unit
renderPropGroup props = line do
    let names = intercalate ", " (_.name <$> props)
    words ["let", names <> ":"]
    string " "

    let { typ } = NE.head props
    string $ renderType typ

renderType :: IRType -> String
renderType = case _ of
    IRNothing -> "Any"
    IRNull -> "Any"
    IRInteger -> "Int"
    IRDouble -> "Double"
    IRBool -> "Bool"
    IRString -> "String"
    IRArray a -> "[" <> renderType a <> "]"
    IRClass { name } -> name
    IRUnion s ->  unionName s

renderUnions :: IRType -> Doc Unit
renderUnions = case _ of
    IRUnion s -> do
        renderUnion s
        for_ (S.toUnfoldable s :: Array _) renderUnions
    IRArray (IRUnion s) -> renderUnion s
    _ -> pure unit

unionName :: S.Set IRType -> String
unionName s = intercalate "Or" $ (caseName <$> S.toUnfoldable s :: Array _)

caseName :: IRType -> String
caseName = case _ of
    IRArray a -> renderType a <> "s"
    IRUnion s ->  unionName s
    t -> renderType t

renderUnion :: S.Set IRType -> Doc Unit
renderUnion types = do
    line $ words ["enum", unionName types, "{"]
    indent do
        for_ types \typ -> line do
            string "case ."
            string $ "some" <> caseName typ
            string "("
            string $ renderType typ
            string ")"
    line "}"
    blank


Clear filter (#870)

Clear filter (#870)

{-
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.BackSide.Component where

import SlamData.Prelude

import Data.Array as Arr
import Data.Foldable as F
import Data.String as Str
import Data.Map as Map

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
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.Effects (Slam)
import SlamData.Render.Common (glyph)
import SlamData.Render.CSS as Rc
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component.CSS as CCSS
import SlamData.Quasar.Auth (retrieveIdToken)

import SlamData.Workspace.Card.Draftboard.Model (DeckPosition)
import SlamData.Workspace.Deck.DeckId (DeckId)
import SlamData.Workspace.Deck.Model (Deck)

data Query a
  = UpdateFilter String a
  | DoAction BackAction a
  | UpdateCardType (Maybe CT.CardType) (Array CT.CardType) a
  | Init a
  -- TODO: this is a bit of a hack, we probably instead want a way of
  -- customising the available and enabled actions based on card type & state
  -- in the long run -gb
  | SetUnwrappable DeckMap a

data BackAction
  = Trash
  | Rename
  | Share
  | Embed
  | Publish
  | DeleteDeck
  | Mirror
  | Wrap
  | Unwrap DeckMap
  | Share
  | Unshare

allBackActions ∷ State → Array BackAction
allBackActions state =
  [ Trash
  , Rename
  ]
  ⊕ (if state.isLogged
      then [ Share
           , Unshare
           ]
      else [ ])
  ⊕ [ Embed
    , Publish
    , DeleteDeck
    , Mirror
    , Wrap
    ]
  ⊕ (guard (state.activeCardType == Just CT.Draftboard) $> Unwrap state.unwrappableDecks)

type DeckMap = Map.Map DeckId (DeckPosition × Deck)

type State =
  { filterString ∷ String
  , activeCardType ∷ Maybe CT.CardType
  , cardTypes ∷ Array CT.CardType
  , saved ∷ Boolean
  , isLogged ∷ Boolean
  , unwrappableDecks ∷ DeckMap
  }

initialState ∷ State
initialState =
  { filterString: ""
  , activeCardType: Nothing
  , cardTypes: mempty
  , saved: false
  , isLogged: false
  , unwrappableDecks: Map.empty
  }

labelAction ∷ BackAction → String
labelAction = case _ of
  Trash → "Delete card"
  Rename → "Rename deck"
  Share → "Share deck"
  Embed → "Embed deck"
  Publish → "Publish deck"
  DeleteDeck → "Delete deck"
  Mirror → "Mirror"
  Wrap → "Wrap"
  Unwrap _ → "Collapse board"
  Unshare → "Unshare deck"

keywordsAction ∷ BackAction → Array String
keywordsAction = case _ of
  Trash → ["remove", "delete", "trash"]
  Rename → ["rename", "title"]
  Share → ["share"]
  Embed → ["embed"]
  Publish → ["publish", "presentation", "view"]
  DeleteDeck → ["remove", "delete", "trash"]
  Mirror → ["mirror", "copy", "duplicate", "shallow"]
  Wrap → ["wrap", "pin", "card"]
  Unwrap _ → ["collapse", "unwrap", "breakout", "remove", "merge"]
  Unshare → ["unshare", "manage"]

actionEnabled ∷ State → BackAction → Boolean
actionEnabled st a =
  case st.activeCardType, a of
    Just CT.ErrorCard, Trash → false
    Just CT.NextAction, Trash → false
    Nothing, Trash → false
    _, Unwrap _ → not Map.isEmpty st.unwrappableDecks
    _, Mirror | F.elem CT.Draftboard st.cardTypes → false
    _, _ → true

actionGlyph ∷ BackAction → HTML
actionGlyph = case _ of
  Trash → glyph B.glyphiconTrash
  Rename → glyph B.glyphiconPencil
  Share → glyph B.glyphiconShare
  Unshare → glyph B.glyphiconWrench
  Embed → glyph B.glyphiconShareAlt
  Publish → glyph B.glyphiconBlackboard
  Mirror → glyph B.glyphiconDuplicate
  Wrap → glyph B.glyphiconLogIn
  Unwrap _ → glyph B.glyphiconLogOut
  DeleteDeck → HH.i [ HP.classes [ Rc.actionIcon, Rc.deleteDeckIcon ] ] [ ]

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Slam

comp ∷ H.Component State Query Slam
comp =
  H.lifecycleComponent
    { render
    , eval
    , finalizer: Nothing
    , initializer: Just (H.action Init)
    }

render ∷ State → HTML
render state =
  HH.div
    [ HP.class_ CCSS.deckCard ]
    [ HH.div
        [ HP.class_ Rc.deckBackSide ]
        [ HH.div_
            [ HH.form_
                [ HH.div_
                    [ HH.input
                        [ HP.value state.filterString
                        , HE.onValueInput (HE.input UpdateFilter)
                        , ARIA.label "Filter actions"
                        , HP.placeholder "Filter actions"
                        ]
                    , HH.button
                        [ HP.buttonType HP.ButtonButton
                        , HE.onClick (HE.input_ (UpdateFilter ""))
                        ]
                        [ glyph B.glyphiconRemove ]
                    ]
                ]
            , HH.ul_
                $ map (backsideAction true) actions.enabledActions
                ⊕ map (backsideAction false) actions.disabledActions
            ]
        ]
    ]
  where

  actions ∷ {enabledActions ∷ Array BackAction, disabledActions ∷ Array BackAction}
  actions =
    foldl
      (\{enabledActions, disabledActions} action →
         if backActionConforms action
           then { enabledActions: Arr.snoc enabledActions action, disabledActions }
           else { enabledActions, disabledActions: Arr.snoc disabledActions action }
      )
      {enabledActions: [], disabledActions: []}
      (allBackActions state)

  backActionConforms ∷ BackAction → Boolean
  backActionConforms ba =
    actionEnabled state ba &&
      F.any
        (isJust ∘ Str.stripPrefix (Str.trim $ Str.toLower state.filterString))
        (keywordsAction ba)

  backsideAction ∷ Boolean → BackAction → HTML
  backsideAction enabled action =
    HH.li_
      [ HH.button attrs
          [ icon
          , HH.p_ [ HH.text $ labelAction action ]
          ]
      ]
    where
      attrs =
        [ HP.title lbl
        , ARIA.label lbl
        , HP.disabled (not enabled)
        , HP.buttonType HP.ButtonButton
        ] ⊕ if enabled then [ HE.onClick (HE.input_ (DoAction action)) ] else [ ]

      lbl = labelAction action ⊕ if enabled then "" else " disabled"
      icon = actionGlyph action

eval ∷ Query ~> DSL
eval (DoAction _ next) = pure next
eval (UpdateFilter str next) =
  H.modify (_ { filterString = str }) $> next
eval (UpdateCardType cty ctys next) =
  H.modify (_ { activeCardType = cty, cardTypes = ctys, unwrappableDecks = Map.empty :: DeckMap }) $> next
eval (Init next) = next <$ do
  isLogged ← map isJust $ H.fromEff retrieveIdToken
  H.modify (_ { isLogged = isLogged })
eval (SetUnwrappable decks next) =
  H.modify (_ { unwrappableDecks = decks }) $> next

{-
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.BackSide.Component where

import SlamData.Prelude

import Data.Array as Arr
import Data.Foldable as F
import Data.String as Str
import Data.Map as Map

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
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.Effects (Slam)
import SlamData.Render.Common (glyph)
import SlamData.Render.CSS as Rc
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component.CSS as CCSS
import SlamData.Quasar.Auth (retrieveIdToken)

import SlamData.Workspace.Card.Draftboard.Model (DeckPosition)
import SlamData.Workspace.Deck.DeckId (DeckId)
import SlamData.Workspace.Deck.Model (Deck)

data Query a
  = UpdateFilter String a
  | DoAction BackAction a
  | UpdateCardType (Maybe CT.CardType) (Array CT.CardType) a
  | Init a
  -- TODO: this is a bit of a hack, we probably instead want a way of
  -- customising the available and enabled actions based on card type & state
  -- in the long run -gb
  | SetUnwrappable DeckMap a

data BackAction
  = Trash
  | Rename
  | Share
  | Embed
  | Publish
  | DeleteDeck
  | Mirror
  | Wrap
  | Unwrap DeckMap
  | Share
  | Unshare

allBackActions ∷ State → Array BackAction
allBackActions state =
  [ Trash
  , Rename
  ]
  ⊕ (if state.isLogged
      then [ Share
           , Unshare
           ]
      else [ ])
  ⊕ [ Embed
    , Publish
    , DeleteDeck
    , Mirror
    , Wrap
    ]
  ⊕ (guard (state.activeCardType == Just CT.Draftboard) $> Unwrap state.unwrappableDecks)

type DeckMap = Map.Map DeckId (DeckPosition × Deck)

type State =
  { filterString ∷ String
  , activeCardType ∷ Maybe CT.CardType
  , cardTypes ∷ Array CT.CardType
  , saved ∷ Boolean
  , isLogged ∷ Boolean
  , unwrappableDecks ∷ DeckMap
  }

initialState ∷ State
initialState =
  { filterString: ""
  , activeCardType: Nothing
  , cardTypes: mempty
  , saved: false
  , isLogged: false
  , unwrappableDecks: Map.empty
  }

labelAction ∷ BackAction → String
labelAction = case _ of
  Trash → "Delete card"
  Rename → "Rename deck"
  Share → "Share deck"
  Embed → "Embed deck"
  Publish → "Publish deck"
  DeleteDeck → "Delete deck"
  Mirror → "Mirror"
  Wrap → "Wrap"
  Unwrap _ → "Collapse board"
  Unshare → "Unshare deck"

keywordsAction ∷ BackAction → Array String
keywordsAction = case _ of
  Trash → ["remove", "delete", "trash"]
  Rename → ["rename", "title"]
  Share → ["share"]
  Embed → ["embed"]
  Publish → ["publish", "presentation", "view"]
  DeleteDeck → ["remove", "delete", "trash"]
  Mirror → ["mirror", "copy", "duplicate", "shallow"]
  Wrap → ["wrap", "pin", "card"]
  Unwrap _ → ["collapse", "unwrap", "breakout", "remove", "merge"]
  Unshare → ["unshare", "manage"]

actionEnabled ∷ State → BackAction → Boolean
actionEnabled st a =
  case st.activeCardType, a of
    Just CT.ErrorCard, Trash → false
    Just CT.NextAction, Trash → false
    Nothing, Trash → false
    _, Unwrap _ → not Map.isEmpty st.unwrappableDecks
    _, Mirror | F.elem CT.Draftboard st.cardTypes → false
    _, _ → true

actionGlyph ∷ BackAction → HTML
actionGlyph = case _ of
  Trash → glyph B.glyphiconTrash
  Rename → glyph B.glyphiconPencil
  Share → glyph B.glyphiconShare
  Unshare → glyph B.glyphiconWrench
  Embed → glyph B.glyphiconShareAlt
  Publish → glyph B.glyphiconBlackboard
  Mirror → glyph B.glyphiconDuplicate
  Wrap → glyph B.glyphiconLogIn
  Unwrap _ → glyph B.glyphiconLogOut
  DeleteDeck → HH.i [ HP.classes [ Rc.actionIcon, Rc.deleteDeckIcon ] ] [ ]

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Slam

comp ∷ H.Component State Query Slam
comp =
  H.lifecycleComponent
    { render
    , eval
    , finalizer: Nothing
    , initializer: Just (H.action Init)
    }

render ∷ State → HTML
render state =
  HH.div
    [ HP.class_ CCSS.deckCard ]
    [ HH.div
        [ HP.class_ Rc.deckBackSide ]
        [ HH.div_
            [ HH.form_
                [ HH.div_
                    [ HH.input
                        [ HP.value state.filterString
                        , HE.onValueInput (HE.input UpdateFilter)
                        , ARIA.label "Filter actions"
                        , HP.placeholder "Filter actions"
                        ]
                    , HH.button
                          [ HP.buttonType HP.ButtonButton ]
                          [ glyph B.glyphiconRemove ]
                    ]
                ]
            , HH.ul_
                $ map (backsideAction true) actions.enabledActions
                ⊕ map (backsideAction false) actions.disabledActions
            ]
        ]
    ]
  where

  actions ∷ {enabledActions ∷ Array BackAction, disabledActions ∷ Array BackAction}
  actions =
    foldl
      (\{enabledActions, disabledActions} action →
         if backActionConforms action
           then { enabledActions: Arr.snoc enabledActions action, disabledActions }
           else { enabledActions, disabledActions: Arr.snoc disabledActions action }
      )
      {enabledActions: [], disabledActions: []}
      (allBackActions state)

  backActionConforms ∷ BackAction → Boolean
  backActionConforms ba =
    actionEnabled state ba &&
      F.any
        (isJust ∘ Str.stripPrefix (Str.trim $ Str.toLower state.filterString))
        (keywordsAction ba)

  backsideAction ∷ Boolean → BackAction → HTML
  backsideAction enabled action =
    HH.li_
      [ HH.button attrs
          [ icon
          , HH.p_ [ HH.text $ labelAction action ]
          ]
      ]
    where
      attrs =
        [ HP.title lbl
        , ARIA.label lbl
        , HP.disabled (not enabled)
        , HP.buttonType HP.ButtonButton
        ] ⊕ if enabled then [ HE.onClick (HE.input_ (DoAction action)) ] else [ ]

      lbl = labelAction action ⊕ if enabled then "" else " disabled"
      icon = actionGlyph action

eval ∷ Query ~> DSL
eval (DoAction _ next) = pure next
eval (UpdateFilter str next) =
  H.modify (_ { filterString = str }) $> next
eval (UpdateCardType cty ctys next) =
  H.modify (_ { activeCardType = cty, cardTypes = ctys, unwrappableDecks = Map.empty :: DeckMap }) $> next
eval (Init next) = next <$ do
  isLogged ← map isJust $ H.fromEff retrieveIdToken
  H.modify (_ { isLogged = isLogged })
eval (SetUnwrappable decks next) =
  H.modify (_ { unwrappableDecks = decks }) $> next


Make Breadcrumbs component compile

Make Breadcrumbs component compile

{-
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.FileSystem.Breadcrumbs.Component
  ( State
  , Breadcrumb
  , rootBreadcrumb
  , mkBreadcrumbs
  , Query(..)
  , comp
  ) where

import SlamData.Prelude

import Data.List (List(..), (:), reverse)
import Data.Path.Pathy (rootDir, runDirName, dirName, parentDir)

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B

import SlamData.Monad (Slam)
import SlamData.Common.Sort (Sort)
import SlamData.FileSystem.Routing (browseURL)
import SlamData.FileSystem.Routing.Salt (Salt)

import Utils.Path (DirPath)

type State =
  { breadcrumbs ∷ List Breadcrumb
  , sort ∷ Sort
  , salt ∷ Salt
  }

type Breadcrumb =
  { name ∷ String
  , link ∷ DirPath
  }

rootBreadcrumb ∷ Breadcrumb
rootBreadcrumb =
  { name: "Home"
  , link: rootDir
  }

mkBreadcrumbs ∷ DirPath → Sort → Salt → State
mkBreadcrumbs path sort salt =
  { breadcrumbs: reverse $ go Nil path
  , sort: sort
  , salt: salt
  }
  where
  go ∷ List Breadcrumb → DirPath → List Breadcrumb
  go result p =
    let result' = { name: maybe "" runDirName (dirName p), link: p } : result
    in case parentDir p of
      Just dir → go result' dir
      Nothing → rootBreadcrumb : result

data Query a = Update DirPath Sort Salt a

comp ∷ State → H.Component HH.HTML Query Unit Void Slam
comp initialState =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ State → H.ComponentHTML Query
render r =
  HH.ol
    [ HP.classes [ B.breadcrumb, B.colXs7 ] ]
    $ foldl (\views model → view model <> views) [ ] r.breadcrumbs
  where
  view b =
    [ HH.li_
        [ HH.a
            [ HP.href (browseURL Nothing r.sort r.salt b.link) ]
            [ HH.text b.name ]
        ]
    ]

eval ∷ Query ~> H.ComponentDSL State Query Void Slam
eval (Update path sort salt next) = do
  H.put $ mkBreadcrumbs path sort salt
  pure next

{-
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.FileSystem.Breadcrumbs.Component
  ( State
  , Breadcrumb
  , rootBreadcrumb
  , mkBreadcrumbs
  , Query(..)
  , comp
  ) where

import SlamData.Prelude

import Data.List (List(..), (:), reverse)
import Data.Path.Pathy (rootDir, runDirName, dirName, parentDir)

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B

import SlamData.Monad (Slam)
import SlamData.Common.Sort (Sort)
import SlamData.FileSystem.Routing (browseURL)
import SlamData.FileSystem.Routing.Salt (Salt)

import Utils.Path (DirPath)

type State =
  { breadcrumbs :: List Breadcrumb
  , sort :: Sort
  , salt :: Salt
  }

type Breadcrumb =
  { name :: String
  , link :: DirPath
  }

rootBreadcrumb :: Breadcrumb
rootBreadcrumb =
  { name: "Home"
  , link: rootDir
  }

mkBreadcrumbs :: DirPath -> Sort -> Salt -> State
mkBreadcrumbs path sort salt =
  { breadcrumbs: reverse $ go Nil path
  , sort: sort
  , salt: salt
  }
  where
  go :: List Breadcrumb -> DirPath -> List Breadcrumb
  go result p =
    let result' = { name: maybe "" runDirName (dirName p), link: p } : result
    in case parentDir p of
      Just dir -> go result' dir
      Nothing -> rootBreadcrumb : result

data Query a = Update DirPath Sort Salt a

comp :: H.Component State Query Slam
comp = H.component { render, eval }

render :: State -> H.ComponentHTML Query
render r =
  HH.ol
    [ HP.classes [ B.breadcrumb, B.colXs7 ] ]
    $ foldl (\views model -> view model <> views) [ ] r.breadcrumbs
  where
  view b =
    [ HH.li_
        [ HH.a
            [ HP.href (browseURL Nothing r.sort r.salt b.link) ]
            [ HH.text b.name ]
        ]
    ]

eval :: Query ~> H.ComponentDSL State Query Slam
eval (Update path sort salt next) = do
  H.put $ mkBreadcrumbs path sort salt
  pure next


add MonadThrow MonadError instances for Effect

-- | This module defines the `MonadError` type class and its instances.

module Control.Monad.Error.Class where

import Prelude

import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)
import Effect (Effect)
import Effect as Effect
import Effect.Exception (Error)

-- | The `MonadThrow` type class represents those monads which support errors via
-- | `throwError`, where `throwError e` halts, yielding the error `e`.
-- |
-- | An implementation is provided for `ExceptT`, and for other monad transformers
-- | defined in this library.
-- |
-- | Laws:
-- |
-- | - Left zero: `throwError e >>= f = throwError e`
-- |
class Monad m <= MonadThrow e m | m -> e where
  throwError :: forall a. e -> m a

-- | The `MonadError` type class represents those monads which support catching
-- | errors.
-- |
-- | - `catchError x f` calls the error handler `f` if an error is thrown during the
-- |   evaluation of `x`.
-- |
-- | An implementation is provided for `ExceptT`, and for other monad transformers
-- | defined in this library.
-- |
-- | Laws:
-- |
-- | - Catch: `catchError (throwError e) f = f e`
-- | - Pure: `catchError (pure a) f = pure a`
-- |
class MonadThrow e m <= MonadError e m | m -> e where
  catchError :: forall a. m a -> (e -> m a) -> m a

-- | This function allows you to provide a predicate for selecting the
-- | exceptions that you're interested in, and handle only those exceptons.
-- | If the inner computation throws an exception, and the predicate returns
-- | Nothing, then the whole computation will still fail with that exception.
catchJust
  :: forall e m a b
   . MonadError e m
  => (e -> Maybe b) -- ^ Predicate to select exceptions
  -> m a            -- ^ Computation to run
  -> (b -> m a)     -- ^ Handler
  -> m a
catchJust p act handler = catchError act handle
  where
  handle e =
    case p e of
      Nothing -> throwError e
      Just b -> handler b

-- | Return `Right` if the given action succeeds, `Left` if it throws.
try
  :: forall e m a
   . MonadError e m
  => m a
  -> m (Either e a)
try a = (Right <$> a) `catchError` (pure <<< Left)

instance monadThrowEither :: MonadThrow e (Either e) where
  throwError = Left

instance monadErrorEither :: MonadError e (Either e) where
  catchError (Left e) h = h e
  catchError (Right x) _ = Right x

instance monadThrowMaybe :: MonadThrow Unit Maybe where
  throwError = const Nothing

instance monadErrorMaybe :: MonadError Unit Maybe where
  catchError Nothing f  = f unit
  catchError (Just a) _ = Just a

instance monadThrowEffect :: MonadThrow Error Effect where
  throwError = Effect.throwException

instance monadErrorEffect :: MonadError Error Effect where
  catchError = flip Effect.catchException

-- | Make sure that a resource is cleaned up in the event of an exception. The
-- | release action is called regardless of whether the body action throws or
-- | returns.
withResource
  :: forall e m r a
   . MonadError e m
  => m r
  -> (r -> m Unit)
  -> (r -> m a)
  -> m a
withResource acquire release kleisli = do
  resource <- acquire
  result <- try $ kleisli resource
  release resource
  either throwError pure result

-- | This module defines the `MonadError` type class and its instances.

module Control.Monad.Error.Class where

import Prelude

import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)

-- | The `MonadThrow` type class represents those monads which support errors via
-- | `throwError`, where `throwError e` halts, yielding the error `e`.
-- |
-- | An implementation is provided for `ExceptT`, and for other monad transformers
-- | defined in this library.
-- |
-- | Laws:
-- |
-- | - Left zero: `throwError e >>= f = throwError e`
-- |
class Monad m <= MonadThrow e m | m -> e where
  throwError :: forall a. e -> m a

-- | The `MonadError` type class represents those monads which support catching
-- | errors.
-- |
-- | - `catchError x f` calls the error handler `f` if an error is thrown during the
-- |   evaluation of `x`.
-- |
-- | An implementation is provided for `ExceptT`, and for other monad transformers
-- | defined in this library.
-- |
-- | Laws:
-- |
-- | - Catch: `catchError (throwError e) f = f e`
-- | - Pure: `catchError (pure a) f = pure a`
-- |
class MonadThrow e m <= MonadError e m | m -> e where
  catchError :: forall a. m a -> (e -> m a) -> m a

-- | This function allows you to provide a predicate for selecting the
-- | exceptions that you're interested in, and handle only those exceptons.
-- | If the inner computation throws an exception, and the predicate returns
-- | Nothing, then the whole computation will still fail with that exception.
catchJust
  :: forall e m a b
   . MonadError e m
  => (e -> Maybe b) -- ^ Predicate to select exceptions
  -> m a            -- ^ Computation to run
  -> (b -> m a)     -- ^ Handler
  -> m a
catchJust p act handler = catchError act handle
  where
  handle e =
    case p e of
      Nothing -> throwError e
      Just b -> handler b

-- | Return `Right` if the given action succeeds, `Left` if it throws.
try
  :: forall e m a
   . MonadError e m
  => m a
  -> m (Either e a)
try a = (Right <$> a) `catchError` (pure <<< Left)

instance monadThrowEither :: MonadThrow e (Either e) where
  throwError = Left

instance monadErrorEither :: MonadError e (Either e) where
  catchError (Left e) h = h e
  catchError (Right x) _ = Right x

instance monadThrowMaybe :: MonadThrow Unit Maybe where
  throwError = const Nothing

instance monadErrorMaybe :: MonadError Unit Maybe where
  catchError Nothing f  = f unit
  catchError (Just a) _ = Just a

-- | Make sure that a resource is cleaned up in the event of an exception. The
-- | release action is called regardless of whether the body action throws or
-- | returns.
withResource
  :: forall e m r a
   . MonadError e m
  => m r
  -> (r -> m Unit)
  -> (r -> m a)
  -> m a
withResource acquire release kleisli = do
  resource <- acquire
  result <- try $ kleisli resource
  release resource
  either throwError pure result


Add Applicative and Functor instances for MaybeT

module Control.Monad.Maybe.Trans where

import Prelude
import Control.Monad
import Control.Monad.Trans
import Data.Either
import Data.Maybe
import Data.Tuple

data MaybeT m a = MaybeT (m (Maybe a))

instance functorMaybeT :: (Monad m) => Functor (MaybeT m) where
  (<$>) = liftA1

instance applicativeMaybeT :: (Monad m) => Applicative (MaybeT m) where
  pure = return
  (<*>) = ap

instance monadMaybeT :: (Monad m) => Monad (MaybeT m) where
  return x = MaybeT $ return $ Just x
  (>>=) x f = MaybeT $ do
    v <- runMaybeT x
    case v of
      Nothing -> return Nothing
      Just y  -> runMaybeT (f y)

instance monadTransMaybeT :: MonadTrans MaybeT where
  lift = MaybeT <<< liftM1 Just

runMaybeT :: forall m a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT x) = x

mapMaybeT :: forall m1 m2 a b. (m1 (Maybe a) -> m2 (Maybe b)) -> MaybeT m1 a -> MaybeT m2 b
mapMaybeT f = MaybeT <<< f <<< runMaybeT

liftCatchMaybe :: forall m e a. (m (Maybe a) -> (e -> m (Maybe a)) -> m (Maybe a)) -> MaybeT m a -> (e -> MaybeT m a) -> MaybeT m a
liftCatchMaybe catch m h = MaybeT $ catch (runMaybeT m) (runMaybeT <<< h)

liftListenMaybe :: forall m a w. (Monad m) => (m (Maybe a) -> m (Tuple (Maybe a) w)) -> MaybeT m a -> MaybeT m (Tuple a w)
liftListenMaybe listen = mapMaybeT $ \m -> do
  Tuple a w <- listen m
  return $ (\r -> Tuple r w) <$> a

liftPassMaybe :: forall m a w. (Monad m) => (m (Tuple (Maybe a) (w -> w)) -> m (Maybe a)) -> MaybeT m (Tuple a (w -> w)) -> MaybeT m a
liftPassMaybe pass = mapMaybeT $ \m -> pass $ do
  a <- m
  return $ case a of
    Nothing -> Tuple Nothing id
    Just (Tuple v f) -> Tuple (Just v) f

module Control.Monad.Maybe.Trans where

import Prelude
import Control.Monad
import Control.Monad.Trans
import Data.Either
import Data.Maybe
import Data.Tuple

data MaybeT m a = MaybeT (m (Maybe a))

instance monadMaybeT :: (Monad m) => Monad (MaybeT m) where
  return x = MaybeT $ return $ Just x
  (>>=) x f = MaybeT $ do
    v <- runMaybeT x
    case v of
      Nothing -> return Nothing
      Just y  -> runMaybeT (f y)

instance monadTransMaybeT :: MonadTrans MaybeT where
  lift = MaybeT <<< liftM1 Just

runMaybeT :: forall m a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT x) = x

mapMaybeT :: forall m1 m2 a b. (m1 (Maybe a) -> m2 (Maybe b)) -> MaybeT m1 a -> MaybeT m2 b
mapMaybeT f = MaybeT <<< f <<< runMaybeT

liftCatchMaybe :: forall m e a. (m (Maybe a) -> (e -> m (Maybe a)) -> m (Maybe a)) -> MaybeT m a -> (e -> MaybeT m a) -> MaybeT m a
liftCatchMaybe catch m h = MaybeT $ catch (runMaybeT m) (runMaybeT <<< h)

liftListenMaybe :: forall m a w. (Monad m) => (m (Maybe a) -> m (Tuple (Maybe a) w)) -> MaybeT m a -> MaybeT m (Tuple a w)
liftListenMaybe listen = mapMaybeT $ \m -> do
  Tuple a w <- listen m
  return $ (\r -> Tuple r w) <$> a

liftPassMaybe :: forall m a w. (Monad m) => (m (Tuple (Maybe a) (w -> w)) -> m (Maybe a)) -> MaybeT m (Tuple a (w -> w)) -> MaybeT m a
liftPassMaybe pass = mapMaybeT $ \m -> pass $ do
  a <- m
  return $ case a of
    Nothing -> Tuple Nothing id
    Just (Tuple v f) -> Tuple (Just v) f


Updated test to actually run a record update.

module ObjectUpdate where

  update1 = \o -> o { foo = "Foo" }

  update2 :: forall r. { foo :: String | r } -> { foo :: String | r }
  update2 = \o -> o { foo = "Foo" }

  replace = \o -> case o of
    { foo = "Foo" } -> o { foo = "Bar" }
    { foo = "Bar" } -> o { bar = "Baz" }
    o -> o

  polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r }
  polyUpdate = \o -> o { foo = "Foo" }

  inferPolyUpdate = \o -> o { foo = "Foo" }

module Main where

import ObjectUpdate

main = Debug.Trace.trace ((update1 {foo: ""}).foo)

module ObjectUpdate where

  update1 = \o -> o { foo = "Foo" }

  update2 :: forall r. { foo :: String | r } -> { foo :: String | r }
  update2 = \o -> o { foo = "Foo" }

  replace = \o -> case o of
    { foo = "Foo" } -> o { foo = "Bar" }
    { foo = "Bar" } -> o { bar = "Baz" }
    o -> o

  polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r }
  polyUpdate = \o -> o { foo = "Foo" }

  inferPolyUpdate = \o -> o { foo = "Foo" }

module Main where

main = Debug.Trace.trace "Done"