Move roundtrips to top level

Move roundtrips to top level

module Test.Main where

import Prelude

import Data.Argonaut.Core (Json)
import Data.Argonaut.Parser (jsonParser)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Except (runExcept)
import Data.Either (Either, either, isRight)
import Data.Foreign (MultipleErrors)
import Data.Foreign.NullOrUndefined (NullOrUndefined)
import Data.StrMap (StrMap)
import Simple.JSON (class ReadForeign, class WriteForeign, readJSON, writeJSON)
import Test.Spec (describe, it)
import Test.Spec.Assertions (fail, shouldEqual)
import Test.Spec.Reporter (consoleReporter)
import Test.Spec.Runner (RunnerEffects, run)
import Type.Proxy (Proxy(..))

type E a = Either MultipleErrors a

handleJSON :: forall a. ReadForeign a => String -> E a
handleJSON json = runExcept $ readJSON json

type MyTest =
  { a :: Int
  , b :: String
  , c :: Boolean
  , d :: Array String
  }

type MyTestNull =
  { a :: Int
  , b :: String
  , c :: Boolean
  , d :: Array String
  , e :: NullOrUndefined (Array String)
  }

type MyTestStrMap =
  { a :: Int
  , b :: StrMap Int
  }

roundtrips :: forall a. ReadForeign a => WriteForeign a => Proxy a -> String -> Aff (RunnerEffects ()) Unit
roundtrips _ enc0 = do
  let dec0 :: E a
      dec0 = handleJSON enc0
      enc1 = either (const "bad1") writeJSON dec0
      json0 :: Either String Json
      json0 = jsonParser enc0
      json1 :: Either String Json
      json1 = jsonParser enc1
      dec1 :: E a
      dec1 = handleJSON enc1
      enc2 = either (const "bad2") writeJSON dec1
  when (json0 /= json1) $ fail $ "\n\torig: " <> show json0 <> "\n\tenc: " <> show json1
  when (enc1 /= enc2) $ fail enc0

main :: Eff (RunnerEffects ()) Unit
main = run [consoleReporter] do
  describe "readJSON" do
    it "fails with invalid JSON" do
      let result = handleJSON """
        { "c": 1, "d": 2}
      """
      isRight (result :: E MyTest) `shouldEqual` false
  describe "roundtrips" do
    it "works with proper JSON" $ roundtrips (Proxy :: Proxy MyTest) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"]}
      """
    it "works with JSON lacking NullOrUndefined field" $ roundtrips (Proxy :: Proxy MyTest) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"]}
      """
    it "works with JSON containing NullOrUndefined field" $ roundtrips (Proxy :: Proxy MyTestNull) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"], "e": ["C", "D"]}
      """
    it "works with JSON containing StrMap field" $ roundtrips (Proxy :: Proxy MyTestStrMap) """
        { "a": 1, "b": {"asdf": 1, "c": 2} }
      """

module Test.Main where

import Prelude

import Data.Argonaut.Core (Json)
import Data.Argonaut.Parser (jsonParser)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Except (runExcept)
import Data.Either (Either, either, isRight)
import Data.Foreign (MultipleErrors)
import Data.Foreign.NullOrUndefined (NullOrUndefined)
import Data.StrMap (StrMap)
import Simple.JSON (class ReadForeign, class WriteForeign, readJSON, writeJSON)
import Test.Spec (describe, it)
import Test.Spec.Assertions (fail, shouldEqual)
import Test.Spec.Reporter (consoleReporter)
import Test.Spec.Runner (RunnerEffects, run)
import Type.Proxy (Proxy(..))

type E a = Either MultipleErrors a

handleJSON :: forall a. ReadForeign a => String -> E a
handleJSON json = runExcept $ readJSON json

type MyTest =
  { a :: Int
  , b :: String
  , c :: Boolean
  , d :: Array String
  }

type MyTestNull =
  { a :: Int
  , b :: String
  , c :: Boolean
  , d :: Array String
  , e :: NullOrUndefined (Array String)
  }

type MyTestStrMap =
  { a :: Int
  , b :: StrMap Int
  }

main :: Eff (RunnerEffects ()) Unit
main = run [consoleReporter] do
  let roundtrips :: forall a. ReadForeign a => WriteForeign a => Proxy a -> String -> Aff (RunnerEffects ()) Unit
      roundtrips _ enc0 = do
        let dec0 :: E a
            dec0 = handleJSON enc0
            enc1 = either (const "bad1") writeJSON dec0
            json0 :: Either String Json
            json0 = jsonParser enc0
            json1 :: Either String Json
            json1 = jsonParser enc1
            dec1 :: E a
            dec1 = handleJSON enc1
            enc2 = either (const "bad2") writeJSON dec1
        when (json0 /= json1) $ fail $ "\n\torig: " <> show json0 <> "\n\tenc: " <> show json1
        when (enc1 /= enc2) $ fail enc0
  describe "readJSON" do
    it "fails with invalid JSON" do
      let result = handleJSON """
        { "c": 1, "d": 2}
      """
      isRight (result :: E MyTest) `shouldEqual` false
  describe "roundtrips" do
    it "works with proper JSON" $ roundtrips (Proxy :: Proxy MyTest) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"]}
      """
    it "works with JSON lacking NullOrUndefined field" $ roundtrips (Proxy :: Proxy MyTest) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"]}
      """
    it "works with JSON containing NullOrUndefined field" $ roundtrips (Proxy :: Proxy MyTestNull) """
        { "a": 1, "b": "asdf", "c": true, "d": ["A", "B"], "e": ["C", "D"]}
      """
    it "works with JSON containing StrMap field" $ roundtrips (Proxy :: Proxy MyTestStrMap) """
        { "a": 1, "b": {"asdf": 1, "c": 2} }
      """


Clean up browser Config.purs

Clean up browser Config.purs

module Genetics.Browser.Config
       ( BrowserConfig(..)
       , parseBrowserConfig
       ) where

import Prelude

import Control.Monad.Except (except, throwError, withExcept)
import Data.Argonaut (Json)
import Data.Bifunctor (lmap)
import Data.Either (isLeft, Either(..))
import Data.Foldable (any)
import Data.Foreign (F, Foreign, ForeignError(..), readArray, readString, unsafeReadTagged)
import Data.Foreign.Index ((!))
import Data.Maybe (Maybe(..), isNothing)
import Data.StrMap (StrMap)
import Data.Traversable (traverse)
import Genetics.Browser.Biodalliance (BrowserConstructor, RenderWrapper)
import Genetics.Browser.Biodalliance.Config (RendererInfo, parseRenderers)
import Genetics.Browser.Config.Track (TracksMap, readTracksMap)
import Genetics.Browser.Events.TrackSource (SourceConfig, makeTrackSource, validateSourceConfig)
import Unsafe.Coerce (unsafeCoerce)

-- TODO `wrapRenderer` and `browser` should both be in a BD-specific config,
-- and be optional if there are no BD tracks.
-- | The configuration type for the whole browser
newtype BrowserConfig = BrowserConfig { wrapRenderer :: RenderWrapper
                                      , bdRenderers :: StrMap RendererInfo
                                      , browser :: BrowserConstructor
                                      , tracks :: TracksMap
                                      , events :: Maybe { bdEventSources :: Array SourceConfig
                                                        , cyEventSources :: Array SourceConfig
                                                        }
                                      }

readJson :: Foreign -> F Json
readJson f = pure $ unsafeCoerce f

parseSourceConfig :: Foreign -> F SourceConfig
parseSourceConfig f = do
  eventName     <- f ! "eventName" >>= readString
  eventTemplate <- f ! "eventTemplate" >>= readJson
  rawTemplate   <- f ! "rawTemplate" >>= readJson
  pure $ { eventName
         , eventTemplate
         , rawTemplate
         }

readTaggedWithError :: forall a. String -> String -> Foreign -> F a
readTaggedWithError s e f = withExcept (append (pure $ ForeignError e)) $ unsafeReadTagged s f

eitherToF :: Either String ~> F
eitherToF = except <<< lmap (pure <<< ForeignError)

parseBrowserConfig :: Foreign -> F BrowserConfig
parseBrowserConfig f = do
  wrapRenderer <- f ! "wrapRenderer" >>= readTaggedWithError "Function" "Error on 'wrapRenderer':"
  browser <- f ! "browser" >>= readTaggedWithError "Function" "Error on 'browser':"
  tracks <- f ! "tracks" >>= readTracksMap

  events <- do
    evs <- f ! "eventSources"
    bd <- evs ! "bd" >>= readArray >>= traverse parseSourceConfig
    cy <- evs ! "cy" >>= readArray >>= traverse parseSourceConfig

    _ <- eitherToF $ traverse validateSourceConfig bd
    _ <- eitherToF $ traverse validateSourceConfig cy

    pure $ Just $ { bdEventSources: bd
                  , cyEventSources: cy
                  }

  bdRenderers <- f ! "renderers" >>= parseRenderers
  pure $ BrowserConfig { wrapRenderer, bdRenderers, browser, tracks, events }

module Genetics.Browser.Config
       ( BrowserConfig(..)
       , parseBrowserConfig
       ) where

import Prelude

import Control.Monad.Except (except, throwError, withExcept)
import Data.Argonaut (Json)
import Data.Bifunctor (lmap)
import Data.Either (isLeft)
import Data.Foldable (any)
import Data.Foreign (F, Foreign, ForeignError(..), readArray, readString, unsafeReadTagged)
import Data.Foreign.Index ((!))
import Data.Maybe (Maybe(..), isNothing)
import Data.StrMap (StrMap)
import Data.Traversable (traverse)
import Genetics.Browser.Biodalliance (BrowserConstructor, RenderWrapper)
import Genetics.Browser.Biodalliance.Config (RendererInfo, parseRenderers)
import Genetics.Browser.Config.Track (TracksMap, readTracksMap)
import Genetics.Browser.Events.TrackSource (SourceConfig, makeTrackSource, validateSourceConfig)
import Unsafe.Coerce (unsafeCoerce)

-- TODO `wrapRenderer` and `browser` should both be in a BD-specific config,
-- and be optional if there are no BD tracks.
-- | The configuration type for the whole browser
newtype BrowserConfig = BrowserConfig { wrapRenderer :: RenderWrapper
                                      , bdRenderers :: StrMap RendererInfo
                                      , browser :: BrowserConstructor
                                      , tracks :: TracksMap
                                      , events :: Maybe { bdEventSources :: Array SourceConfig
                                                        , cyEventSources :: Array SourceConfig
                                                        }
                                      }

readJson :: Foreign -> F Json
readJson f = pure $ unsafeCoerce f

parseSourceConfig :: Foreign -> F SourceConfig
parseSourceConfig f = do
  eventName     <- f ! "eventName" >>= readString
  eventTemplate <- f ! "eventTemplate" >>= readJson
  rawTemplate   <- f ! "rawTemplate" >>= readJson
  pure $ { eventName
         , eventTemplate
         , rawTemplate
         }

readTaggedWithError :: forall a. String -> String -> Foreign -> F a
readTaggedWithError s e f = withExcept (append (pure $ ForeignError e)) $ unsafeReadTagged s f

parseBrowserConfig :: Foreign -> F BrowserConfig
parseBrowserConfig f = do
  wrapRenderer <- f ! "wrapRenderer" >>= readTaggedWithError "Function" "Error on 'wrapRenderer':"
  browser <- f ! "browser" >>= readTaggedWithError "Function" "Error on 'browser':"
  tracks <- f ! "tracks" >>= readTracksMap

  events <- do
    evs <- f ! "eventSources"
    bd <- evs ! "bd" >>= readArray >>= traverse parseSourceConfig
    cy <- evs ! "cy" >>= readArray >>= traverse parseSourceConfig

    _ <- except $ traverse (\sc -> lmap (pure <<< ForeignError) $ validateSourceConfig sc) bd
    _ <- except $ traverse (\sc -> lmap (pure <<< ForeignError) $ validateSourceConfig sc) cy

    pure $ Just $ { bdEventSources: bd
                  , cyEventSources: cy
                  }

  bdRenderers <- f ! "renderers" >>= parseRenderers
  pure $ BrowserConfig { wrapRenderer, bdRenderers, browser, tracks, events }


Remove partial patterns from Css.Render

Remove partial patterns from Css.Render

module Css.Render where

import Css.Property
import Css.Selector
import Css.String
import Css.Stylesheet
import Data.Array
import Data.Either
import Data.Foldable
import Data.Maybe
import Data.Monoid
import Data.These
import Data.Tuple
import qualified Data.Array.NonEmpty as NEL

newtype Inline = Inline String

getInline :: Inline -> String
getInline (Inline s) = s

instance semigroupInline :: Semigroup Inline where
  (<>) (Inline a) (Inline b) = Inline (a <> b)

instance monoidInline :: Monoid Inline where
  mempty = Inline mempty

newtype Sheet = Sheet String

getSheet :: Sheet -> String
getSheet (Sheet s) = s

instance semigroupFile :: Semigroup Sheet where
  (<>) (Sheet a) (Sheet b) = Sheet (a <> b)

instance monoidFile :: Monoid Sheet where
  mempty = Sheet mempty

type Rendered = Maybe (These Inline Sheet)

maybeThisSide :: forall a b. These a b -> Maybe a
maybeThisSide (Both a _) = Just a
maybeThisSide (That _) = Nothing
maybeThisSide (This a) = Just a

maybeThatSide :: forall a b. These a b -> Maybe b
maybeThatSide (Both _ b) = Just b
maybeThatSide (That b) = Just b
maybeThatSide (This _) = Nothing

renderedInline :: Rendered -> Maybe String
renderedInline = (>>= ((getInline <$>) <<< maybeThisSide))

renderedSheet :: Rendered -> Maybe String
renderedSheet = (>>= ((getSheet <$>) <<< maybeThatSide))

render :: forall a. StyleM a -> Rendered
render = rules [] <<< runS

rules :: [App] -> [Rule] -> Rendered
rules sel rs = topRules <> nestedSheets
  where property (Property k v) = Just (Tuple k v)
        property _              = Nothing
        nested   (Nested a ns)  = Just (Tuple a ns)
        nested   _              = Nothing
        topRules = rule' sel (mapMaybe property rs)
        nestedSheets = intercalate (Just (That (Sheet " "))) $ uncurry nestedRules <$> mapMaybe nested rs
        nestedRules a = rules (a : sel)

rule' :: forall a. [App] -> [Tuple (Key a) Value] -> Rendered
rule' sel props = maybe q o $ nel sel
  where p = props >>= collect
        q = (This <<< Inline <<< properties <<< NEL.toArray) <$> nel p
        o sel' = Just <<< That <<< Sheet $ intercalate " " [selector (merger sel'), "{", properties p, "}"]

selector :: Selector -> String
selector = intercalate ", " <<< selector'

selector' :: Selector -> [String]
selector' (Selector (Refinement ft) p) = (<> (foldMap predicate (sort ft))) <$> selector'' ft p

selector'' :: [Predicate] -> Path Selector -> [String]
selector'' [] Star = ["*"]
selector'' (_:_) Star = [""]
selector'' _ (Elem t) = [t]
selector'' _ (PathChild a b) = sepWith " > " <$> selector' a <*> selector' b
selector'' _ (Deep a b) = sepWith " " <$> selector' a <*> selector' b
selector'' _ (Adjacent a b) = sepWith " + " <$> selector' a <*> selector' b
selector'' _ (Combined a b) = selector' a <> selector' b

sepWith :: String -> String -> String -> String
sepWith s a b = a <> s <> b

collect :: forall a. Tuple (Key a) Value -> [Either String (Tuple String String)]
collect (Tuple (Key ky) (Value v1)) = collect' ky v1

collect' :: Prefixed -> Prefixed -> [Either String (Tuple String String)]
collect' (Plain k) (Plain v) = [Right (Tuple k v)]
collect' (Prefixed ks) (Plain v) = (\(Tuple p k) -> Right $ Tuple (p <> k) v) <$> ks
collect' (Plain k) (Prefixed vs) = (\(Tuple p v) -> Right $ Tuple k (p <> v)) <$> vs
collect' (Prefixed ks) (Prefixed vs) = (\(Tuple p k) -> maybe (Left (p <> k)) (Right <<< Tuple (p <> k) <<< (p <>)) $ lookup p vs) <$> ks

properties :: [Either String (Tuple String String)] -> String
properties xs = intercalate "; " $  sheetRules <$> xs
  where sheetRules = either (\_ -> mempty) (\(Tuple k v) -> mconcat [k, ": ", v])

merger :: NEL.NonEmpty App -> Selector
merger (NEL.NonEmpty x xs) =
  case x of
    Child s -> maybe s (\xs' -> merger xs' |> s) $ nel xs
    Sub s   -> maybe s (\xs' -> merger xs' ** s) $ nel xs
    Root s  -> maybe s (\xs' -> s ** merger xs') $ nel xs
    Pop i   -> maybe (element "TODO") merger <<< nel <<< NEL.drop i $ x NEL.:| xs
    Self  sheetRules  -> maybe (star `with`  sheetRules) (\xs' -> merger xs' `with`  sheetRules) $ nel xs

predicate :: Predicate -> String
predicate (Id a) = "#" <> a
predicate (Class a) = "." <> a
predicate (Attr a) = "[" <> a <> "]"
predicate (AttrVal a v) = "[" <> a <> "='" <> v <> "']"
predicate (AttrBegins a v) = "[" <> a <> "^='" <> v <> "']"
predicate (AttrEnds a v) = "[" <> a <> "$='" <> v <> "']"

nel :: forall a. [a] -> Maybe (NEL.NonEmpty a)
nel [] = Nothing
nel (x:xs) = Just $ x NEL.:| xs

module Css.Render where

import Css.Property
import Css.Selector
import Css.String
import Css.Stylesheet
import Data.Array
import Data.Either
import Data.Foldable
import Data.Maybe
import Data.Monoid
import Data.These
import Data.Tuple
import qualified Data.Array.NonEmpty as NEL

newtype Inline = Inline String

getInline :: Inline -> String
getInline (Inline s) = s

instance semigroupInline :: Semigroup Inline where
  (<>) (Inline a) (Inline b) = Inline (a <> b)

instance monoidInline :: Monoid Inline where
  mempty = Inline mempty

newtype Sheet = Sheet String

getSheet :: Sheet -> String
getSheet (Sheet s) = s

instance semigroupFile :: Semigroup Sheet where
  (<>) (Sheet a) (Sheet b) = Sheet (a <> b)

instance monoidFile :: Monoid Sheet where
  mempty = Sheet mempty

type Rendered = Maybe (These Inline Sheet)

maybeThisSide :: forall a b. These a b -> Maybe a
maybeThisSide (Both a _) = Just a
maybeThisSide (That _) = Nothing
maybeThisSide (This a) = Just a

maybeThatSide :: forall a b. These a b -> Maybe b
maybeThatSide (Both _ b) = Just b
maybeThatSide (That b) = Just b
maybeThatSide (This _) = Nothing

renderedInline :: Rendered -> Maybe String
renderedInline = (>>= ((getInline <$>) <<< maybeThisSide))

renderedSheet :: Rendered -> Maybe String
renderedSheet = (>>= ((getSheet <$>) <<< maybeThatSide))

render :: forall a. StyleM a -> Rendered
render = rules [] <<< runS

rules :: [App] -> [Rule] -> Rendered
rules sel rs = topRules <> nestedSheets
  where property (Property k v) = Just (Tuple k v)
        property _              = Nothing
        nested   (Nested a ns)  = Just (Tuple a ns)
        nested   _              = Nothing
        topRules = rule' sel (mapMaybe property rs)
        nestedSheets = intercalate (Just (That (Sheet " "))) $ uncurry nestedRules <$> mapMaybe nested rs
        nestedRules a = rules (a : sel)

rule' :: forall a. [App] -> [Tuple (Key a) Value] -> Rendered
rule' sel props = maybe q o $ nel sel
  where p = props >>= collect
        q = (This <<< Inline <<< properties <<< NEL.toArray) <$> nel p
        o sel' = Just <<< That <<< Sheet $ intercalate " " [selector (merger sel'), "{", properties p, "}"]

selector :: Selector -> String
selector = intercalate ", " <<< selector'

selector' :: Selector -> [String]
selector' (Selector (Refinement ft) p) = (<> (foldMap predicate (sort ft))) <$> selector'' ft p

selector'' :: [Predicate] -> Path Selector -> [String]
selector'' [] Star = ["*"]
selector'' (_:_) Star = [""]
selector'' _ (Elem t) = [t]
selector'' _ (PathChild a b) = sepWith " > " <$> selector' a <*> selector' b
selector'' _ (Deep a b) = sepWith " " <$> selector' a <*> selector' b
selector'' _ (Adjacent a b) = sepWith " + " <$> selector' a <*> selector' b
selector'' _ (Combined a b) = selector' a <> selector' b

sepWith :: String -> String -> String -> String
sepWith s a b = a <> s <> b

collect :: forall a. Tuple (Key a) Value -> [Either String (Tuple String String)]
collect (Tuple (Key ky) (Value v1)) =
  case (Tuple ky v1) of
    Tuple (Plain k) (Plain v) -> [Right (Tuple k v)]

properties :: [Either String (Tuple String String)] -> String
properties xs = intercalate "; " $  sheetRules <$> xs
  where  sheetRules (Right (Tuple k v)) = mconcat [k, ": ", v]

merger :: NEL.NonEmpty App -> Selector
merger (NEL.NonEmpty x xs) =
  case x of
    Child s -> maybe s (\xs' -> merger xs' |> s) $ nel xs
    Sub s   -> maybe s (\xs' -> merger xs' ** s) $ nel xs
    Root s  -> maybe s (\xs' -> s ** merger xs') $ nel xs
    Pop i   -> maybe (element "TODO") merger <<< nel <<< NEL.drop i $ x NEL.:| xs
    Self  sheetRules  -> maybe (star `with`  sheetRules) (\xs' -> merger xs' `with`  sheetRules) $ nel xs

predicate :: Predicate -> String
predicate (Id a) = "#" <> a
predicate (Class a) = "." <> a
predicate (Attr a) = "[" <> a <> "]"
predicate (AttrVal a v) = "[" <> a <> "='" <> v <> "']"
predicate (AttrBegins a v) = "[" <> a <> "^='" <> v <> "']"
predicate (AttrEnds a v) = "[" <> a <> "$='" <> v <> "']"

nel :: forall a. [a] -> Maybe (NEL.NonEmpty a)
nel [] = Nothing
nel (x:xs) = Just $ x NEL.:| xs


Remove comment banners

Remove comment banners

It confuses `psc-docs` and ends up stripping documentation. We should
fix this in the compiler eventually.

-- | Helper functions for working with immutable Javascript arrays.
-- |
-- | _Note_: Depending on your use-case, you may prefer to use `Data.List` or
-- | `Data.Sequence` instead, which might give better performance for certain
-- | use cases. This module is useful when integrating with JavaScript libraries
-- | which use arrays, but immutable arrays are not a practical data structure
-- | for many use cases due to their poor asymptotics.
module Data.Array
  ( singleton
  , (..), range
  , replicate
  , replicateM
  , some
  , many

  , null
  , length

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

  , head
  , last
  , tail
  , init
  , uncons

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

  , reverse
  , concat
  , concatMap
  , filter
  , filterM
  , mapMaybe
  , catMaybes

  , sort
  , sortBy

  , slice
  , take
  , takeWhile
  , drop
  , dropWhile
  , span
  , group
  , group'
  , groupBy

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

  , (\\)
  , intersect
  , intersectBy

  , zipWith
  , zipWithA
  , zip
  , unzip

  , foldM
  ) where

import Prelude

import Control.Alt (Alt, (<|>))
import Control.Alternative (Alternative)
import Control.Lazy (Lazy, defer)
import Control.MonadPlus (MonadPlus)
import Control.Plus (Plus)

import Data.Foldable (foldl)
import Data.Functor.Invariant (Invariant)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Monoid (Monoid)
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..))
import qualified Data.Maybe.Unsafe as U

-- | Create an array of one element
singleton :: forall a. a -> Array a
singleton a = [a]

-- | Create an array containing a range of integers, including both endpoints.
foreign import range :: Int -> Int -> Array Int

infix 8 ..

-- | An infix synonym for `range`.
(..) :: Int -> Int -> Array Int
(..) = range

-- | Create an array with repeated instances of a value.
foreign import replicate :: forall a. Int -> a -> Array a

-- | Perform a monadic action `n` times collecting all of the results.
replicateM :: forall m a. (Monad m) => Int -> m a -> m (Array a)
replicateM n m | n < 1     = return []
               | otherwise = sequence $ replicate n m

-- | Attempt a computation multiple times, requiring at least one success.
-- |
-- | The `Lazy` constraint is used to generate the result lazily, to ensure
-- | termination.
some :: forall f a. (Alternative f, Lazy (f (Array a))) => f a -> f (Array a)
some v = (:) <$> v <*> defer (\_ -> many v)

-- | Attempt a computation multiple times, returning as many successful results
-- | as possible (possibly zero).
-- |
-- | The `Lazy` constraint is used to generate the result lazily, to ensure
-- | termination.
many :: forall f a. (Alternative f, Lazy (f (Array a))) => f a -> f (Array a)
many v = some v <|> pure []

--------------------------------------------------------------------------------
-- Array size ------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Test whether an array is empty.
null :: forall a. Array a -> Boolean
null xs = length xs == 0

-- | Get the number of elements in an array.
foreign import length :: forall a. Array a -> Int

--------------------------------------------------------------------------------
-- Extending arrays ------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Attaches an element to the front of an array, creating a new array.
-- |
-- | ```purescript
-- | cons 1 [2, 3, 4] = [1, 2, 3, 4]
-- | ```
-- |
-- | Note, the running time of this function is `O(n)`.
foreign import cons :: forall a. a -> Array a -> Array a

infixr 6 :

-- | An infix alias for `cons`.
-- |
-- | Note, the running time of this function is `O(n)`.
(:) :: forall a. a -> Array a -> Array a
(:) = cons

-- | Append an element to the end of an array, creating a new array.
foreign import snoc :: forall a. Array a -> a -> Array a

-- | Insert an element into a sorted array.
insert :: forall a. (Ord a) => a -> Array a -> Array a
insert = insertBy compare

-- | Insert an element into a sorted array, using the specified function to
-- | determine the ordering of elements.
insertBy :: forall a. (a -> a -> Ordering) -> a -> Array a -> Array a
insertBy cmp x ys =
  let i = maybe 0 (+ 1) (findLastIndex (\y -> cmp x y == GT) ys)
  in U.fromJust (insertAt i x ys)

--------------------------------------------------------------------------------
-- Non-indexed reads -----------------------------------------------------------
--------------------------------------------------------------------------------

-- | Get the first element in an array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(1)`.
head :: forall a. Array a -> Maybe a
head = uncons' (const Nothing) (\x _ -> Just x)

-- | Get the last element in an array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(1)`.
last :: forall a. Array a -> Maybe a
last xs = xs !! (length xs - 1)

-- | Get all but the first element of an array, creating a new array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(n)` where `n` is the length of the array
tail :: forall a. Array a -> Maybe (Array a)
tail = uncons' (const Nothing) (\_ xs -> Just xs)

-- | Get all but the last element of an array, creating a new array, or `Nothing` if the array is empty.
-- |
-- | Running time: `O(n)` where `n` is the length of the array
init :: forall a. Array a -> Maybe (Array a)
init xs | null xs = Nothing
        | otherwise = Just (slice zero (length xs - one) xs)

-- | Break an array into its first element and remaining elements.
-- |
-- | Using `uncons` provides a way of writing code that would use cons patterns
-- | in Haskell or pre-PureScript 0.7:
-- | ``` purescript
-- | f (x : xs) = something
-- | f [] = somethingElse
-- | ```
-- | Becomes:
-- | ``` purescript
-- | f arr = case uncons arr of
-- |   Just { head: x, tail: xs } -> something
-- |   Nothing -> somethingElse
-- | ```
uncons :: forall a. Array a -> Maybe { head :: a, tail :: Array a }
uncons = uncons' (const Nothing) \x xs -> Just { head: x, tail: xs }

foreign import uncons' :: forall a b. (Unit -> b)
                                   -> (a -> Array a -> b)
                                   -> Array a
                                   -> b

--------------------------------------------------------------------------------
-- Indexed operations ----------------------------------------------------------
--------------------------------------------------------------------------------

-- | This function provides a safe way to read a value at a particular index
-- | from an array.
index :: forall a. Array a -> Int -> Maybe a
index = indexImpl Just Nothing

foreign import indexImpl :: forall a. (forall r. r -> Maybe r)
                                   -> (forall r. Maybe r)
                                   -> Array a
                                   -> Int
                                   -> Maybe a

infixl 8 !!

-- | An infix version of `index`.
(!!) :: forall a. Array a -> Int -> Maybe a
(!!) = index

-- | Find the index of the first element equal to the specified element.
elemIndex :: forall a. (Eq a) => a -> Array a -> Maybe Int
elemIndex x = findIndex (== x)

-- | Find the index of the last element equal to the specified element.
elemLastIndex :: forall a. (Eq a) => a -> Array a -> Maybe Int
elemLastIndex x = findLastIndex (== x)

-- | Find the first index for which a predicate holds.
findIndex :: forall a. (a -> Boolean) -> Array a -> Maybe Int
findIndex = findIndexImpl Just Nothing

foreign import findIndexImpl :: forall a. (forall b. b -> Maybe b)
                                       -> (forall b. Maybe b)
                                       -> (a -> Boolean)
                                       -> Array a
                                       -> Maybe Int

-- | Find the last index for which a predicate holds.
findLastIndex :: forall a. (a -> Boolean) -> Array a -> Maybe Int
findLastIndex = findLastIndexImpl Just Nothing

foreign import findLastIndexImpl :: forall a. (forall b. b -> Maybe b)
                                           -> (forall b. Maybe b)
                                           -> (a -> Boolean)
                                           -> Array a
                                           -> Maybe Int

-- | Insert an element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
insertAt :: forall a. Int -> a -> Array a -> Maybe (Array a)
insertAt = _insertAt Just Nothing

foreign import _insertAt :: forall a. (forall b. b -> Maybe b)
                                   -> (forall b. Maybe b)
                                   -> Int
                                   -> a
                                   -> Array a
                                   -> Maybe (Array a)

-- | Delete the element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
deleteAt :: forall a. Int -> Array a -> Maybe (Array a)
deleteAt = _deleteAt Just Nothing

foreign import _deleteAt :: forall a. (forall b. b -> Maybe b)
                                   -> (forall b. Maybe b)
                                   -> Int
                                   -> Array a
                                   -> Maybe (Array a)

-- | Change the element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
updateAt :: forall a. Int -> a -> Array a -> Maybe (Array a)
updateAt = _updateAt Just Nothing

foreign import _updateAt :: forall a. (forall b. b -> Maybe b)
                                   -> (forall b. Maybe b)
                                   -> Int
                                   -> a
                                   -> Array a
                                   -> Maybe (Array a)

-- | Apply a function to the element at the specified index, creating a new
-- | array, or returning `Nothing` if the index is out of bounds.
modifyAt :: forall a. Int -> (a -> a) -> Array a -> Maybe (Array a)
modifyAt i f xs = maybe Nothing go (xs !! i)
  where
  go x = updateAt i (f x) xs

-- | Update or delete the element at the specified index by applying a
-- | function to the current value, returning a new array or `Nothing` if the
-- | index is out-of-bounds.
alterAt :: forall a. Int -> (a -> Maybe a) -> Array a -> Maybe (Array a)
alterAt i f xs = maybe Nothing go (xs !! i)
  where
  go x = case f x of
    Nothing -> deleteAt i xs
    Just x' -> updateAt i x' xs

--------------------------------------------------------------------------------
-- Transformations -------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Reverse an array, creating a new array.
foreign import reverse :: forall a. Array a -> Array a

-- | Flatten an array of arrays, creating a new array.
foreign import concat :: forall a. Array (Array a) -> Array a

-- | Apply a function to each element in an array, and flatten the results
-- | into a single, new array.
concatMap :: forall a b. (a -> Array b) -> Array a -> Array b
concatMap = flip bind

-- | Filter an array, keeping the elements which satisfy a predicate function,
-- | creating a new array.
foreign import filter :: forall a. (a -> Boolean) -> Array a -> Array a

-- | Filter where the predicate returns a monadic `Boolean`.
-- |
-- | ```purescript
-- | powerSet :: forall a. [a] -> [[a]]
-- | powerSet = filterM (const [true, false])
-- | ```
filterM :: forall a m. (Monad m) => (a -> m Boolean) -> Array a -> m (Array a)
filterM p = uncons' (\_ -> pure []) \x xs -> do
    b <- p x
    xs' <- filterM p xs
    return if b
           then x : xs'
           else xs'

-- | Apply a function to each element in an array, keeping only the results
-- | which contain a value, creating a new array.
mapMaybe :: forall a b. (a -> Maybe b) -> Array a -> Array b
mapMaybe f = concatMap (maybe [] singleton <<< f)

-- | Filter an array of optional values, keeping only the elements which contain
-- | a value, creating a new array.
catMaybes :: forall a. Array (Maybe a) -> Array a
catMaybes = mapMaybe id

--------------------------------------------------------------------------------
-- Sorting ---------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Sort the elements of an array in increasing order, creating a new array.
sort :: forall a. (Ord a) => Array a -> Array a
sort xs = sortBy compare xs

-- | Sort the elements of an array in increasing order, where elements are compared using
-- | the specified partial ordering, creating a new array.
sortBy :: forall a. (a -> a -> Ordering) -> Array a -> Array a
sortBy comp xs = sortImpl comp' xs
  where
  comp' x y = case comp x y of
    GT -> 1
    EQ -> 0
    LT -> -1

foreign import sortImpl :: forall a. (a -> a -> Int) -> Array a -> Array a

--------------------------------------------------------------------------------
-- Subarrays -------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Extract a subarray by a start and end index.
foreign import slice :: forall a. Int -> Int -> Array a -> Array a

-- | Keep only a number of elements from the start of an array, creating a new
-- | array.
take :: forall a. Int -> Array a -> Array a
take = slice 0

-- | Calculate the longest initial subarray for which all element satisfy the
-- | specified predicate, creating a new array.
takeWhile :: forall a. (a -> Boolean) -> Array a -> Array a
takeWhile p xs = (span p xs).init

-- | Drop a number of elements from the start of an array, creating a new array.
foreign import drop :: forall a. Int -> Array a -> Array a

-- | Remove the longest initial subarray for which all element satisfy the
-- | specified predicate, creating a new array.
dropWhile :: forall a. (a -> Boolean) -> Array a -> Array a
dropWhile p xs = (span p xs).rest

-- | Split an array into two parts:
-- |
-- | 1. the longest initial subarray for which all element satisfy the specified
-- |    predicate
-- | 2. the remaining elements
-- |
-- | ```purescript
-- | span (\n -> n % 2 == 1) [1,3,2,4,5] == { init: [1,3], rest: [2,4,5] }
-- | ```
span :: forall a. (a -> Boolean) -> Array a -> { init :: Array a, rest :: Array a }
span p = go []
  where
  go :: Array a -> Array a -> { init :: Array a, rest :: Array a }
  go acc xs = case uncons xs of
                Just { head: x, tail: xs } | p x -> go (x : acc) xs
                _ -> { init: reverse acc, rest: xs }

-- | Group equal, consecutive elements of an array into arrays.
-- |
-- | ```purescript
-- | group [1,1,2,2,1] == [[1,1],[2,2],[1]]
-- | ```
group :: forall a. (Eq a) => Array a -> Array (Array a)
group xs = groupBy eq xs

-- | Sort and then group the elements of an array into arrays.
-- |
-- | ```purescript
-- | group' [1,1,2,2,1] == [[1,1,1],[2,2]]
-- | ```
group' :: forall a. (Ord a) => Array a -> Array (Array a)
group' = group <<< sort

-- | Group equal, consecutive elements of an array into arrays, using the
-- | specified equivalence relation to detemine equality.
groupBy :: forall a. (a -> a -> Boolean) -> Array a -> Array (Array a)
groupBy op = go []
  where
  go :: Array (Array a) -> Array a -> Array (Array a)
  go acc xs = case uncons xs of
    Just o -> let sp = span (op o.head) o.tail
              in go ((o.head : sp.init) : acc) sp.rest
    Nothing -> reverse acc

-- | Remove the duplicates from an array, creating a new array.
nub :: forall a. (Eq a) => Array a -> Array a
nub = nubBy eq

-- | Remove the duplicates from an array, where element equality is determined
-- | by the specified equivalence relation, creating a new array.
nubBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a
nubBy eq xs = case uncons xs of
                Just o -> o.head : nubBy eq (filter (\y -> not (o.head `eq` y)) o.tail)
                Nothing -> []

-- | Calculate the union of two lists.
-- |
-- | Running time: `O(n^2)`
union :: forall a. (Eq a) => Array a -> Array a -> Array a
union = unionBy (==)

-- | Calculate the union of two arrays, using the specified function to
-- | determine equality of elements.
unionBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Array a
unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs

-- | Delete the first element of an array which is equal to the specified value,
-- | creating a new array.
delete :: forall a. (Eq a) => a -> Array a -> Array a
delete = deleteBy eq

-- | Delete the first element of an array which matches the specified value,
-- | under the equivalence relation provided in the first argument, creating a
-- | new array.
deleteBy :: forall a. (a -> a -> Boolean) -> a -> Array a -> Array a
deleteBy _  _ [] = []
deleteBy eq x ys = maybe ys (\i -> U.fromJust $ deleteAt i ys) (findIndex (eq x) ys)

infix 5 \\

-- | Delete the first occurrence of each element in the second array from the
-- | first array, creating a new array.
(\\) :: forall a. (Eq a) => Array a -> Array a -> Array a
(\\) xs ys | null xs = []
           | otherwise = uncons' (const xs) (\y ys -> delete y xs \\ ys) ys

-- | Calculate the intersection of two arrays, creating a new array.
intersect :: forall a. (Eq a) => Array a -> Array a -> Array a
intersect = intersectBy eq

-- | Calculate the intersection of two arrays, using the specified equivalence
-- | relation to compare elements, creating a new array.
intersectBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Array a
intersectBy eq xs ys = filter (\x -> isJust (findIndex (eq x) ys)) xs

-- | Apply a function to pairs of elements at the same index in two arrays,
-- | collecting the results in a new array.
-- |
-- | If one array is longer, elements will be discarded from the longer array.
-- |
-- | For example
-- |
-- | ```purescript
-- | zipWith (*) [1, 2, 3] [4, 5, 6, 7] == [4, 10, 18]
-- | ```
foreign import zipWith :: forall a b c. (a -> b -> c) -> Array a -> Array b -> Array c

-- | A generalization of `zipWith` which accumulates results in some `Applicative`
-- | functor.
zipWithA :: forall m a b c. (Applicative m) => (a -> b -> m c) -> Array a -> Array b -> m (Array c)
zipWithA f xs ys = sequence (zipWith f xs ys)

-- | Rakes two lists and returns a list of corresponding pairs.
-- | If one input list is short, excess elements of the longer list are discarded.
zip :: forall a b. Array a -> Array b -> Array (Tuple a b)
zip = zipWith Tuple

-- | Transforms a list of pairs into a list of first components and a list of
-- | second components.
unzip :: forall a b. Array (Tuple a b) -> Tuple (Array a) (Array b)
unzip = uncons' (\_ -> Tuple [] []) \(Tuple a b) ts -> case unzip ts of
  Tuple as bs -> Tuple (a : as) (b : bs)

-- | Perform a fold using a monadic step function.
foldM :: forall m a b. (Monad m) => (a -> b -> m a) -> a -> Array b -> m a
foldM f a = uncons' (\_ -> return a) (\b bs -> f a b >>= \a' -> foldM f a' bs)

-- | Helper functions for working with immutable Javascript arrays.
-- |
-- | _Note_: Depending on your use-case, you may prefer to use `Data.List` or
-- | `Data.Sequence` instead, which might give better performance for certain
-- | use cases. This module is useful when integrating with JavaScript libraries
-- | which use arrays, but immutable arrays are not a practical data structure
-- | for many use cases due to their poor asymptotics.
module Data.Array
  ( singleton
  , (..), range
  , replicate
  , replicateM
  , some
  , many

  , null
  , length

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

  , head
  , last
  , tail
  , init
  , uncons

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

  , reverse
  , concat
  , concatMap
  , filter
  , filterM
  , mapMaybe
  , catMaybes

  , sort
  , sortBy

  , slice
  , take
  , takeWhile
  , drop
  , dropWhile
  , span
  , group
  , group'
  , groupBy

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

  , (\\)
  , intersect
  , intersectBy

  , zipWith
  , zipWithA
  , zip
  , unzip

  , foldM
  ) where

import Prelude

import Control.Alt (Alt, (<|>))
import Control.Alternative (Alternative)
import Control.Lazy (Lazy, defer)
import Control.MonadPlus (MonadPlus)
import Control.Plus (Plus)

import Data.Foldable (foldl)
import Data.Functor.Invariant (Invariant)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Monoid (Monoid)
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..))
import qualified Data.Maybe.Unsafe as U

--------------------------------------------------------------------------------
-- Array creation --------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Create an array of one element
singleton :: forall a. a -> Array a
singleton a = [a]

-- | Create an array containing a range of integers, including both endpoints.
foreign import range :: Int -> Int -> Array Int

infix 8 ..

-- | An infix synonym for `range`.
(..) :: Int -> Int -> Array Int
(..) = range

-- | Create an array with repeated instances of a value.
foreign import replicate :: forall a. Int -> a -> Array a

-- | Perform a monadic action `n` times collecting all of the results.
replicateM :: forall m a. (Monad m) => Int -> m a -> m (Array a)
replicateM n m | n < 1     = return []
               | otherwise = sequence $ replicate n m

-- | Attempt a computation multiple times, requiring at least one success.
-- |
-- | The `Lazy` constraint is used to generate the result lazily, to ensure
-- | termination.
some :: forall f a. (Alternative f, Lazy (f (Array a))) => f a -> f (Array a)
some v = (:) <$> v <*> defer (\_ -> many v)

-- | Attempt a computation multiple times, returning as many successful results
-- | as possible (possibly zero).
-- |
-- | The `Lazy` constraint is used to generate the result lazily, to ensure
-- | termination.
many :: forall f a. (Alternative f, Lazy (f (Array a))) => f a -> f (Array a)
many v = some v <|> pure []

--------------------------------------------------------------------------------
-- Array size ------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Test whether an array is empty.
null :: forall a. Array a -> Boolean
null xs = length xs == 0

-- | Get the number of elements in an array.
foreign import length :: forall a. Array a -> Int

--------------------------------------------------------------------------------
-- Extending arrays ------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Attaches an element to the front of an array, creating a new array.
-- |
-- | ```purescript
-- | cons 1 [2, 3, 4] = [1, 2, 3, 4]
-- | ```
-- |
-- | Note, the running time of this function is `O(n)`.
foreign import cons :: forall a. a -> Array a -> Array a

infixr 6 :

-- | An infix alias for `cons`.
-- |
-- | Note, the running time of this function is `O(n)`.
(:) :: forall a. a -> Array a -> Array a
(:) = cons

-- | Append an element to the end of an array, creating a new array.
foreign import snoc :: forall a. Array a -> a -> Array a

-- | Insert an element into a sorted array.
insert :: forall a. (Ord a) => a -> Array a -> Array a
insert = insertBy compare

-- | Insert an element into a sorted array, using the specified function to
-- | determine the ordering of elements.
insertBy :: forall a. (a -> a -> Ordering) -> a -> Array a -> Array a
insertBy cmp x ys =
  let i = maybe 0 (+ 1) (findLastIndex (\y -> cmp x y == GT) ys)
  in U.fromJust (insertAt i x ys)

--------------------------------------------------------------------------------
-- Non-indexed reads -----------------------------------------------------------
--------------------------------------------------------------------------------

-- | Get the first element in an array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(1)`.
head :: forall a. Array a -> Maybe a
head = uncons' (const Nothing) (\x _ -> Just x)

-- | Get the last element in an array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(1)`.
last :: forall a. Array a -> Maybe a
last xs = xs !! (length xs - 1)

-- | Get all but the first element of an array, creating a new array, or `Nothing` if the array is empty
-- |
-- | Running time: `O(n)` where `n` is the length of the array
tail :: forall a. Array a -> Maybe (Array a)
tail = uncons' (const Nothing) (\_ xs -> Just xs)

-- | Get all but the last element of an array, creating a new array, or `Nothing` if the array is empty.
-- |
-- | Running time: `O(n)` where `n` is the length of the array
init :: forall a. Array a -> Maybe (Array a)
init xs | null xs = Nothing
        | otherwise = Just (slice zero (length xs - one) xs)

-- | Break an array into its first element and remaining elements.
-- |
-- | Using `uncons` provides a way of writing code that would use cons patterns
-- | in Haskell or pre-PureScript 0.7:
-- | ``` purescript
-- | f (x : xs) = something
-- | f [] = somethingElse
-- | ```
-- | Becomes:
-- | ``` purescript
-- | f arr = case uncons arr of
-- |   Just { head: x, tail: xs } -> something
-- |   Nothing -> somethingElse
-- | ```
uncons :: forall a. Array a -> Maybe { head :: a, tail :: Array a }
uncons = uncons' (const Nothing) \x xs -> Just { head: x, tail: xs }

foreign import uncons' :: forall a b. (Unit -> b)
                                   -> (a -> Array a -> b)
                                   -> Array a
                                   -> b

--------------------------------------------------------------------------------
-- Indexed operations ----------------------------------------------------------
--------------------------------------------------------------------------------

-- | This function provides a safe way to read a value at a particular index
-- | from an array.
index :: forall a. Array a -> Int -> Maybe a
index = indexImpl Just Nothing

foreign import indexImpl :: forall a. (forall r. r -> Maybe r)
                                   -> (forall r. Maybe r)
                                   -> Array a
                                   -> Int
                                   -> Maybe a

infixl 8 !!

-- | An infix version of `index`.
(!!) :: forall a. Array a -> Int -> Maybe a
(!!) = index

-- | Find the index of the first element equal to the specified element.
elemIndex :: forall a. (Eq a) => a -> Array a -> Maybe Int
elemIndex x = findIndex (== x)

-- | Find the index of the last element equal to the specified element.
elemLastIndex :: forall a. (Eq a) => a -> Array a -> Maybe Int
elemLastIndex x = findLastIndex (== x)

-- | Find the first index for which a predicate holds.
findIndex :: forall a. (a -> Boolean) -> Array a -> Maybe Int
findIndex = findIndexImpl Just Nothing

foreign import findIndexImpl :: forall a. (forall b. b -> Maybe b)
                                       -> (forall b. Maybe b)
                                       -> (a -> Boolean)
                                       -> Array a
                                       -> Maybe Int

-- | Find the last index for which a predicate holds.
findLastIndex :: forall a. (a -> Boolean) -> Array a -> Maybe Int
findLastIndex = findLastIndexImpl Just Nothing

foreign import findLastIndexImpl :: forall a. (forall b. b -> Maybe b)
                                           -> (forall b. Maybe b)
                                           -> (a -> Boolean)
                                           -> Array a
                                           -> Maybe Int

-- | Insert an element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
insertAt :: forall a. Int -> a -> Array a -> Maybe (Array a)
insertAt = _insertAt Just Nothing

foreign import _insertAt :: forall a. (forall b. b -> Maybe b)
                                   -> (forall b. Maybe b)
                                   -> Int
                                   -> a
                                   -> Array a
                                   -> Maybe (Array a)

-- | Delete the element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
deleteAt :: forall a. Int -> Array a -> Maybe (Array a)
deleteAt = _deleteAt Just Nothing

foreign import _deleteAt :: forall a. (forall b. b -> Maybe b)
                                   -> (forall b. Maybe b)
                                   -> Int
                                   -> Array a
                                   -> Maybe (Array a)

-- | Change the element at the specified index, creating a new array, or
-- | returning `Nothing` if the index is out of bounds.
updateAt :: forall a. Int -> a -> Array a -> Maybe (Array a)
updateAt = _updateAt Just Nothing

foreign import _updateAt :: forall a. (forall b. b -> Maybe b)
                                   -> (forall b. Maybe b)
                                   -> Int
                                   -> a
                                   -> Array a
                                   -> Maybe (Array a)

-- | Apply a function to the element at the specified index, creating a new
-- | array, or returning `Nothing` if the index is out of bounds.
modifyAt :: forall a. Int -> (a -> a) -> Array a -> Maybe (Array a)
modifyAt i f xs = maybe Nothing go (xs !! i)
  where
  go x = updateAt i (f x) xs

-- | Update or delete the element at the specified index by applying a
-- | function to the current value, returning a new array or `Nothing` if the
-- | index is out-of-bounds.
alterAt :: forall a. Int -> (a -> Maybe a) -> Array a -> Maybe (Array a)
alterAt i f xs = maybe Nothing go (xs !! i)
  where
  go x = case f x of
    Nothing -> deleteAt i xs
    Just x' -> updateAt i x' xs

--------------------------------------------------------------------------------
-- Transformations -------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Reverse an array, creating a new array.
foreign import reverse :: forall a. Array a -> Array a

-- | Flatten an array of arrays, creating a new array.
foreign import concat :: forall a. Array (Array a) -> Array a

-- | Apply a function to each element in an array, and flatten the results
-- | into a single, new array.
concatMap :: forall a b. (a -> Array b) -> Array a -> Array b
concatMap = flip bind

-- | Filter an array, keeping the elements which satisfy a predicate function,
-- | creating a new array.
foreign import filter :: forall a. (a -> Boolean) -> Array a -> Array a

-- | Filter where the predicate returns a monadic `Boolean`.
-- |
-- | ```purescript
-- | powerSet :: forall a. [a] -> [[a]]
-- | powerSet = filterM (const [true, false])
-- | ```
filterM :: forall a m. (Monad m) => (a -> m Boolean) -> Array a -> m (Array a)
filterM p = uncons' (\_ -> pure []) \x xs -> do
    b <- p x
    xs' <- filterM p xs
    return if b
           then x : xs'
           else xs'

-- | Apply a function to each element in an array, keeping only the results
-- | which contain a value, creating a new array.
mapMaybe :: forall a b. (a -> Maybe b) -> Array a -> Array b
mapMaybe f = concatMap (maybe [] singleton <<< f)

-- | Filter an array of optional values, keeping only the elements which contain
-- | a value, creating a new array.
catMaybes :: forall a. Array (Maybe a) -> Array a
catMaybes = mapMaybe id

--------------------------------------------------------------------------------
-- Sorting ---------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Sort the elements of an array in increasing order, creating a new array.
sort :: forall a. (Ord a) => Array a -> Array a
sort xs = sortBy compare xs

-- | Sort the elements of an array in increasing order, where elements are compared using
-- | the specified partial ordering, creating a new array.
sortBy :: forall a. (a -> a -> Ordering) -> Array a -> Array a
sortBy comp xs = sortImpl comp' xs
  where
  comp' x y = case comp x y of
    GT -> 1
    EQ -> 0
    LT -> -1

foreign import sortImpl :: forall a. (a -> a -> Int) -> Array a -> Array a

--------------------------------------------------------------------------------
-- Subarrays -------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Extract a subarray by a start and end index.
foreign import slice :: forall a. Int -> Int -> Array a -> Array a

-- | Keep only a number of elements from the start of an array, creating a new
-- | array.
take :: forall a. Int -> Array a -> Array a
take = slice 0

-- | Calculate the longest initial subarray for which all element satisfy the
-- | specified predicate, creating a new array.
takeWhile :: forall a. (a -> Boolean) -> Array a -> Array a
takeWhile p xs = (span p xs).init

-- | Drop a number of elements from the start of an array, creating a new array.
foreign import drop :: forall a. Int -> Array a -> Array a

-- | Remove the longest initial subarray for which all element satisfy the
-- | specified predicate, creating a new array.
dropWhile :: forall a. (a -> Boolean) -> Array a -> Array a
dropWhile p xs = (span p xs).rest

-- | Split an array into two parts:
-- |
-- | 1. the longest initial subarray for which all element satisfy the specified
-- |    predicate
-- | 2. the remaining elements
-- |
-- | ```purescript
-- | span (\n -> n % 2 == 1) [1,3,2,4,5] == { init: [1,3], rest: [2,4,5] }
-- | ```
span :: forall a. (a -> Boolean) -> Array a -> { init :: Array a, rest :: Array a }
span p = go []
  where
  go :: Array a -> Array a -> { init :: Array a, rest :: Array a }
  go acc xs = case uncons xs of
                Just { head: x, tail: xs } | p x -> go (x : acc) xs
                _ -> { init: reverse acc, rest: xs }

-- | Group equal, consecutive elements of an array into arrays.
-- |
-- | ```purescript
-- | group [1,1,2,2,1] == [[1,1],[2,2],[1]]
-- | ```
group :: forall a. (Eq a) => Array a -> Array (Array a)
group xs = groupBy eq xs

-- | Sort and then group the elements of an array into arrays.
-- |
-- | ```purescript
-- | group' [1,1,2,2,1] == [[1,1,1],[2,2]]
-- | ```
group' :: forall a. (Ord a) => Array a -> Array (Array a)
group' = group <<< sort

-- | Group equal, consecutive elements of an array into arrays, using the
-- | specified equivalence relation to detemine equality.
groupBy :: forall a. (a -> a -> Boolean) -> Array a -> Array (Array a)
groupBy op = go []
  where
  go :: Array (Array a) -> Array a -> Array (Array a)
  go acc xs = case uncons xs of
    Just o -> let sp = span (op o.head) o.tail
              in go ((o.head : sp.init) : acc) sp.rest
    Nothing -> reverse acc

--------------------------------------------------------------------------------
-- Set-like operations ---------------------------------------------------------
--------------------------------------------------------------------------------

-- | Remove the duplicates from an array, creating a new array.
nub :: forall a. (Eq a) => Array a -> Array a
nub = nubBy eq

-- | Remove the duplicates from an array, where element equality is determined
-- | by the specified equivalence relation, creating a new array.
nubBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a
nubBy eq xs = case uncons xs of
                Just o -> o.head : nubBy eq (filter (\y -> not (o.head `eq` y)) o.tail)
                Nothing -> []

-- | Calculate the union of two lists.
-- |
-- | Running time: `O(n^2)`
union :: forall a. (Eq a) => Array a -> Array a -> Array a
union = unionBy (==)

-- | Calculate the union of two arrays, using the specified function to
-- | determine equality of elements.
unionBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Array a
unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs

-- | Delete the first element of an array which is equal to the specified value,
-- | creating a new array.
delete :: forall a. (Eq a) => a -> Array a -> Array a
delete = deleteBy eq

-- | Delete the first element of an array which matches the specified value,
-- | under the equivalence relation provided in the first argument, creating a
-- | new array.
deleteBy :: forall a. (a -> a -> Boolean) -> a -> Array a -> Array a
deleteBy _  _ [] = []
deleteBy eq x ys = maybe ys (\i -> U.fromJust $ deleteAt i ys) (findIndex (eq x) ys)

infix 5 \\

-- | Delete the first occurrence of each element in the second array from the
-- | first array, creating a new array.
(\\) :: forall a. (Eq a) => Array a -> Array a -> Array a
(\\) xs ys | null xs = []
           | otherwise = uncons' (const xs) (\y ys -> delete y xs \\ ys) ys

-- | Calculate the intersection of two arrays, creating a new array.
intersect :: forall a. (Eq a) => Array a -> Array a -> Array a
intersect = intersectBy eq

-- | Calculate the intersection of two arrays, using the specified equivalence
-- | relation to compare elements, creating a new array.
intersectBy :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Array a
intersectBy eq xs ys = filter (\x -> isJust (findIndex (eq x) ys)) xs

--------------------------------------------------------------------------------
-- Zipping ---------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Apply a function to pairs of elements at the same index in two arrays,
-- | collecting the results in a new array.
-- |
-- | If one array is longer, elements will be discarded from the longer array.
-- |
-- | For example
-- |
-- | ```purescript
-- | zipWith (*) [1, 2, 3] [4, 5, 6, 7] == [4, 10, 18]
-- | ```
foreign import zipWith :: forall a b c. (a -> b -> c) -> Array a -> Array b -> Array c

-- | A generalization of `zipWith` which accumulates results in some `Applicative`
-- | functor.
zipWithA :: forall m a b c. (Applicative m) => (a -> b -> m c) -> Array a -> Array b -> m (Array c)
zipWithA f xs ys = sequence (zipWith f xs ys)

-- | Rakes two lists and returns a list of corresponding pairs.
-- | If one input list is short, excess elements of the longer list are discarded.
zip :: forall a b. Array a -> Array b -> Array (Tuple a b)
zip = zipWith Tuple

-- | Transforms a list of pairs into a list of first components and a list of
-- | second components.
unzip :: forall a b. Array (Tuple a b) -> Tuple (Array a) (Array b)
unzip = uncons' (\_ -> Tuple [] []) \(Tuple a b) ts -> case unzip ts of
  Tuple as bs -> Tuple (a : as) (b : bs)

--------------------------------------------------------------------------------
-- Folding ---------------------------------------------------------------------
--------------------------------------------------------------------------------

-- | Perform a fold using a monadic step function.
foldM :: forall m a b. (Monad m) => (a -> b -> m a) -> a -> Array b -> m a
foldM f a = uncons' (\_ -> return a) (\b bs -> f a b >>= \a' -> foldM f a' bs)


Update/fix tests

Update/fix tests


Sort by luminance

Sort by luminance

module Util.Types where

import Prelude ((<$>), div)
import Data.Int (toNumber)
import Data.Show (class Show)
import Data.Ord (class Ord, compare)
import Data.Eq (class Eq, eq)

import Data.Argonaut hiding (toNumber)
import Color (Color, toRGBA, toHSLA, toHexString)

newtype Color' = Color' Color
newtype Colors' = Colors' (Array Color')

instance eqColor :: Eq Color' where
  eq (Color' c1) (Color' c2) = eq c1 c2

instance ordColor :: Ord Color' where
  compare (Color' c1) (Color' c2) = compare hsla1.l hsla2.l where
    hsla1 = toHSLA c1
    hsla2 = toHSLA c2

instance showColor :: Show Color' where
  show (Color' color) = toHexString color

instance encodeJsonColor :: EncodeJson Color' where
  encodeJson (Color' color)
     = "red"   := div (toNumber rgba.r) 255.0
    ~> "green" := div (toNumber rgba.g) 255.0
    ~> "blue"  := div (toNumber rgba.b) 255.0
    ~> "alpha" := rgba.a
    ~> jsonEmptyObject
      where rgba = toRGBA color

instance encodeJsonColors :: EncodeJson Colors' where
  encodeJson (Colors' colors)
     = "compatibleVersion" := "1.4"
    ~> "pluginVersion"     := "1.4"
    ~> "colors"            := fromArray (encodeJson <$> colors)
    ~> jsonEmptyObject

module Util.Types where

import Prelude ((<$>), div)
import Data.Int (toNumber)
import Data.Show (class Show)
import Data.Ord (class Ord, compare)
import Data.Eq (class Eq, eq)

import Data.Argonaut hiding (toNumber)
import Color (Color, toRGBA, toHSLA, toHexString)

newtype Color' = Color' Color
newtype Colors' = Colors' (Array Color')

instance eqColor :: Eq Color' where
  eq (Color' c1) (Color' c2) = eq c1 c2

instance ordColor :: Ord Color' where
  compare (Color' c1) (Color' c2) = compare hsla1.h hsla2.h where
    hsla1 = toHSLA c1
    hsla2 = toHSLA c2

instance showColor :: Show Color' where
  show (Color' color) = toHexString color

instance encodeJsonColor :: EncodeJson Color' where
  encodeJson (Color' color)
     = "red"   := div (toNumber rgba.r) 255.0
    ~> "green" := div (toNumber rgba.g) 255.0
    ~> "blue"  := div (toNumber rgba.b) 255.0
    ~> "alpha" := rgba.a
    ~> jsonEmptyObject
      where rgba = toRGBA color

instance encodeJsonColors :: EncodeJson Colors' where
  encodeJson (Colors' colors)
     = "compatibleVersion" := "1.4"
    ~> "pluginVersion"     := "1.4"
    ~> "colors"            := fromArray (encodeJson <$> colors)
    ~> jsonEmptyObject


Cleaner

Cleaner

Original commit 78907e7b4c6ae3d38fdb46b6ef9fe2e42bede9dc

module Language.Pseudocode
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory)

import Data.Foldable (for_, intercalate, maximum)

import Data.List as L
import Data.Map as M
import Data.Map (Map)
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.Set (Set)
import Data.String as Str
import Data.String.Util as Str
import Data.Tuple (Tuple(..), fst)

import Utils (mapM)

renderer :: Renderer
renderer =
    { name: "Pseudocode"
    , aceMode: "groovy"
    , extension: "pseudo"
    , doc: pseudocodeDoc
    , transforms:
        { nameForClass: noForbidNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        , topLevelName: simpleNamer id
        , unions: Nothing
        }
    }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = upperNameStyle $ combineNames names

isComplex :: IRType -> Boolean
isComplex = case _ of
    IRArray a -> isComplex a
    IRMap _ -> true
    IRUnion _ -> true
    _ -> false

isStartCharacter :: Char -> Boolean
isStartCharacter c = Str.isLetterOrLetterNumber c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isStartCharacter c

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "Any" -- we can have arrays of nothing
    IRNull -> pure "Null"
    IRInteger -> pure "Double"
    IRDouble -> pure "Double"
    IRBool -> pure "Boolean"
    IRString -> pure "String"
    IRClass i -> lookupClassName i

    IRArray a | isComplex a -> do
        rendered <- renderType a
        pure $ "Array<" <> rendered <> ">"

    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"

    IRMap t -> do
        rendered <- renderType t
        pure $ "Map<String, " <> rendered <> ">"

    IRUnion types -> do
        let typeSet = unionToSet types
        case nullableFromSet typeSet of
            Nothing -> renderUnion typeSet
            Just t -> do
                rendered <- renderType t
                pure $ "Maybe<" <> rendered <> ">"

classNameStyle :: Boolean -> String -> String
classNameStyle upper = Str.legalizeCharacters isPartCharacter >>> Str.camelCase >>> (Str.startWithLetter isStartCharacter upper)

upperNameStyle :: String -> String
upperNameStyle = classNameStyle true

pseudocodeDoc :: Doc Unit
pseudocodeDoc = forEachClass_ \className properties -> do
    line $ "class " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let maxWidth = props <#> fst <#> Str.length # maximum
        for_ props \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered
    line "}"
    blank

module Language.Pseudocode
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory)

import Data.Foldable (for_, intercalate, maximum)

import Data.List as L
import Data.Map as M
import Data.Map (Map)
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.Set (Set)
import Data.String as Str
import Data.String.Util as Str
import Data.Tuple (Tuple(..), fst)

import Utils (mapM)

renderer :: Renderer
renderer =
    { name: "Pseudocode"
    , aceMode: "groovy"
    , extension: "pseudo"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> s <> "_"
        , forbiddenNames: []
        , topLevelName: simpleNamer id
        , unions: Nothing
        }
    }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = upperNameStyle $ combineNames names

isGeneric :: IRType -> Boolean
isGeneric = case _ of
    IRArray a -> isGeneric a
    IRMap _ -> true
    IRUnion _ -> true
    _ -> false

isStartCharacter :: Char -> Boolean
isStartCharacter c = Str.isLetterOrLetterNumber c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isStartCharacter c

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "Any" -- we can have arrays of nothing
    IRNull -> pure "Null"
    IRInteger -> pure "Double"
    IRDouble -> pure "Double"
    IRBool -> pure "Boolean"
    IRString -> pure "String"
    IRClass i -> lookupClassName i

    IRArray a | isGeneric a -> do
        rendered <- renderType a
        pure $ "Array<" <> rendered <> ">"

    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"

    IRMap t -> do
        rendered <- renderType t
        pure $ "Map<String, " <> rendered <> ">"

    IRUnion types ->
        case nullableFromSet $ unionToSet types of
            Nothing -> renderUnion $ unionToSet types
            Just t -> do
                rendered <- renderType t
                pure $ "Maybe<" <> rendered <> ">"

getContainedClassName :: IRType -> Doc (Maybe String)
getContainedClassName = case _ of
    IRArray a -> getContainedClassName a
    IRClass i -> Just <$> lookupClassName i
    _ -> pure Nothing

tsNameStyle :: Boolean -> String -> String
tsNameStyle upper = Str.legalizeCharacters isPartCharacter >>> Str.camelCase >>> (Str.startWithLetter isStartCharacter upper)

upperNameStyle :: String -> String
upperNameStyle = tsNameStyle true

lowerNameStyle :: String -> String
lowerNameStyle = tsNameStyle false

quote :: String -> String
quote s = "\"" <> s <> "\""

typeScriptDoc :: Doc Unit
typeScriptDoc = forEachClass_ renderClass

renderClass :: String -> Map String IRType -> Doc Unit
renderClass className properties = do
    blank
    line $ "class " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let maxWidth = props <#> fst <#> Str.length # maximum
        for_ props \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered
    line "}"


Add Array's MonadZero instance again with a compiler warning

-- | This module is **deprecated** and will be removed in a future release.
-- |
-- | The annihilation law witnessed by `MonadZero` is trivially satisfied by
-- | lawful monads due to parametricity: while evaluating `empty >>= f`, the
-- | function `f` can’t ever be called, since that would require `empty` to
-- | produce a value, which means that `empty >>= f` must be the same as
-- | `empty >>= pure`, which by the monad laws is just `empty`.
-- |
-- | Use `Monad` and `Alternative` constraints instead.

module Control.MonadZero
  ( class MonadZero
  , module Control.Alt
  , module Control.Alternative
  , module Control.Applicative
  , module Control.Apply
  , module Control.Bind
  , module Control.Monad
  , module Control.Plus
  , module Data.Functor
  ) where

import Control.Alt (class Alt, alt, (<|>))
import Control.Alternative (class Alternative, guard)
import Control.Applicative (class Applicative, pure, liftA1, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Bind (class Bind, bind, ifM, join, (<=<), (=<<), (>=>), (>>=))
import Control.Monad (class Monad, ap, liftM1)
import Control.Plus (class Plus, empty)

import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))

import Prim.TypeError (class Warn, Text)

-- | The `MonadZero` type class has no members of its own; it just specifies
-- | that the type has both `Monad` and `Alternative` instances.
-- |
-- | Types which have `MonadZero` instances should also satisfy the following
-- | laws:
-- |
-- | - Annihilation: `empty >>= f = empty`
class (Monad m, Alternative m, Warn (Text "'MonadZero' is deprecated, use 'Monad' and 'Alternative' constraints instead")) <= MonadZero m

instance monadZeroArray :: Warn (Text "`Array`'s 'MonadZero' is deprecated, use 'Monad' and 'Alternative' constraints instead")) => MonadZero Array