Export lookup (#133)

Export lookup (#133)

module Data.Foldable
  ( class Foldable, foldr, foldl, foldMap
  , foldrDefault, foldlDefault, foldMapDefaultL, foldMapDefaultR
  , fold
  , foldM
  , traverse_
  , for_
  , sequence_
  , oneOf
  , oneOfMap
  , intercalate
  , surroundMap
  , surround
  , and
  , or
  , all
  , any
  , sum
  , product
  , elem
  , notElem
  , indexl
  , indexr
  , find
  , findMap
  , maximum
  , maximumBy
  , minimum
  , minimumBy
  , null
  , length
  , lookup
  ) where

import Prelude

import Control.Plus (class Plus, alt, empty)
import Data.Const (Const)
import Data.Either (Either(..))
import Data.Functor.App (App(..))
import Data.Functor.Compose (Compose(..))
import Data.Functor.Coproduct (Coproduct, coproduct)
import Data.Functor.Product (Product(..))
import Data.Identity (Identity(..))
import Data.Maybe (Maybe(..))
import Data.Maybe.First (First(..))
import Data.Maybe.Last (Last(..))
import Data.Monoid.Additive (Additive(..))
import Data.Monoid.Conj (Conj(..))
import Data.Monoid.Disj (Disj(..))
import Data.Monoid.Dual (Dual(..))
import Data.Monoid.Endo (Endo(..))
import Data.Monoid.Multiplicative (Multiplicative(..))
import Data.Newtype (alaF, unwrap)
import Data.Tuple (Tuple(..))

-- | `Foldable` represents data structures which can be _folded_.
-- |
-- | - `foldr` folds a structure from the right
-- | - `foldl` folds a structure from the left
-- | - `foldMap` folds a structure by accumulating values in a `Monoid`
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `foldrDefault`
-- | - `foldlDefault`
-- | - `foldMapDefaultR`
-- | - `foldMapDefaultL`
-- |
-- | Note: some combinations of the default implementations are unsafe to
-- | use together - causing a non-terminating mutually recursive cycle.
-- | These combinations are documented per function.
class Foldable f where
  foldr :: forall a b. (a -> b -> b) -> b -> f a -> b
  foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
  foldMap :: forall a m. Monoid m => (a -> m) -> f a -> m

-- | A default implementation of `foldr` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultR`.
foldrDefault
  :: forall f a b
   . Foldable f
  => (a -> b -> b)
  -> b
  -> f a
  -> b
foldrDefault c u xs = unwrap (foldMap (Endo <<< c) xs) u

-- | A default implementation of `foldl` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultL`.
foldlDefault
  :: forall f a b
   . Foldable f
  => (b -> a -> b)
  -> b
  -> f a
  -> b
foldlDefault c u xs = unwrap (unwrap (foldMap (Dual <<< Endo <<< flip c) xs)) u

-- | A default implementation of `foldMap` using `foldr`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldrDefault`.
foldMapDefaultR
  :: forall f a m
   . Foldable f
  => Monoid m
  => (a -> m)
  -> f a
  -> m
foldMapDefaultR f = foldr (\x acc -> f x <> acc) mempty

-- | A default implementation of `foldMap` using `foldl`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldlDefault`.
foldMapDefaultL
  :: forall f a m
   . Foldable f
  => Monoid m
  => (a -> m)
  -> f a
  -> m
foldMapDefaultL f = foldl (\acc x -> acc <> f x) mempty

instance foldableArray :: Foldable Array where
  foldr = foldrArray
  foldl = foldlArray
  foldMap = foldMapDefaultR

foreign import foldrArray :: forall a b. (a -> b -> b) -> b -> Array a -> b
foreign import foldlArray :: forall a b. (b -> a -> b) -> b -> Array a -> b

instance foldableMaybe :: Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = x `f` z
  foldl _ z Nothing  = z
  foldl f z (Just x) = z `f` x
  foldMap f Nothing  = mempty
  foldMap f (Just x) = f x

instance foldableFirst :: Foldable First where
  foldr f z (First x) = foldr f z x
  foldl f z (First x) = foldl f z x
  foldMap f (First x) = foldMap f x

instance foldableLast :: Foldable Last where
  foldr f z (Last x) = foldr f z x
  foldl f z (Last x) = foldl f z x
  foldMap f (Last x) = foldMap f x

instance foldableAdditive :: Foldable Additive where
  foldr f z (Additive x) = x `f` z
  foldl f z (Additive x) = z `f` x
  foldMap f (Additive x) = f x

instance foldableDual :: Foldable Dual where
  foldr f z (Dual x) = x `f` z
  foldl f z (Dual x) = z `f` x
  foldMap f (Dual x) = f x

instance foldableDisj :: Foldable Disj where
  foldr f z (Disj x) = f x z
  foldl f z (Disj x) = f z x
  foldMap f (Disj x) = f x

instance foldableConj :: Foldable Conj where
  foldr f z (Conj x) = f x z
  foldl f z (Conj x) = f z x
  foldMap f (Conj x) = f x

instance foldableMultiplicative :: Foldable Multiplicative where
  foldr f z (Multiplicative x) = x `f` z
  foldl f z (Multiplicative x) = z `f` x
  foldMap f (Multiplicative x) = f x

instance foldableEither :: Foldable (Either a) where
  foldr _ z (Left _)  = z
  foldr f z (Right x) = f x z
  foldl _ z (Left _)  = z
  foldl f z (Right x) = f z x
  foldMap f (Left _)  = mempty
  foldMap f (Right x) = f x

instance foldableTuple :: Foldable (Tuple a) where
  foldr f z (Tuple _ x) = f x z
  foldl f z (Tuple _ x) = f z x
  foldMap f (Tuple _ x) = f x

instance foldableIdentity :: Foldable Identity where
  foldr f z (Identity x) = f x z
  foldl f z (Identity x) = f z x
  foldMap f (Identity x) = f x

instance foldableConst :: Foldable (Const a) where
  foldr _ z _ = z
  foldl _ z _ = z
  foldMap _ _ = mempty

instance foldableProduct :: (Foldable f, Foldable g) => Foldable (Product f g) where
  foldr f z (Product (Tuple fa ga)) = foldr f (foldr f z ga) fa
  foldl f z (Product (Tuple fa ga)) = foldl f (foldl f z fa) ga
  foldMap f (Product (Tuple fa ga)) = foldMap f fa <> foldMap f ga

instance foldableCoproduct :: (Foldable f, Foldable g) => Foldable (Coproduct f g) where
  foldr f z = coproduct (foldr f z) (foldr f z)
  foldl f z = coproduct (foldl f z) (foldl f z)
  foldMap f = coproduct (foldMap f) (foldMap f)

instance foldableCompose :: (Foldable f, Foldable g) => Foldable (Compose f g) where
  foldr f i (Compose fga) = foldr (flip (foldr f)) i fga
  foldl f i (Compose fga) = foldl (foldl f) i fga
  foldMap f (Compose fga) = foldMap (foldMap f) fga

instance foldableApp :: Foldable f => Foldable (App f) where
  foldr f i (App x) = foldr f i x
  foldl f i (App x) = foldl f i x
  foldMap f (App x) = foldMap f x

-- | Fold a data structure, accumulating values in some `Monoid`.
fold :: forall f m. Foldable f => Monoid m => f m -> m
fold = foldMap identity

-- | Similar to 'foldl', but the result is encapsulated in a monad.
-- |
-- | Note: this function is not generally stack-safe, e.g., for monads which
-- | build up thunks a la `Eff`.
foldM :: forall f m a b. Foldable f => Monad m => (b -> a -> m b) -> b -> f a -> m b
foldM f b0 = foldl (\b a -> b >>= flip f a) (pure b0)

-- | Traverse a data structure, performing some effects encoded by an
-- | `Applicative` functor at each value, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | traverse_ print [1, 2, 3]
-- | ```
traverse_
  :: forall a b f m
   . Applicative m
  => Foldable f
  => (a -> m b)
  -> f a
  -> m Unit
traverse_ f = foldr ((*>) <<< f) (pure unit)

-- | A version of `traverse_` with its arguments flipped.
-- |
-- | This can be useful when running an action written using do notation
-- | for every element in a data structure:
-- |
-- | For example:
-- |
-- | ```purescript
-- | for_ [1, 2, 3] \n -> do
-- |   print n
-- |   trace "squared is"
-- |   print (n * n)
-- | ```
for_
  :: forall a b f m
   . Applicative m
  => Foldable f
  => f a
  -> (a -> m b)
  -> m Unit
for_ = flip traverse_

-- | Perform all of the effects in some data structure in the order
-- | given by the `Foldable` instance, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | sequence_ [ trace "Hello, ", trace " world!" ]
-- | ```
sequence_ :: forall a f m. Applicative m => Foldable f => f (m a) -> m Unit
sequence_ = traverse_ identity

-- | Combines a collection of elements using the `Alt` operation.
oneOf :: forall f g a. Foldable f => Plus g => f (g a) -> g a
oneOf = foldr alt empty

-- | Folds a structure into some `Plus`.
oneOfMap :: forall f g a b. Foldable f => Plus g => (a -> g b) -> f a -> g b
oneOfMap f = foldr (alt <<< f) empty

-- | Fold a data structure, accumulating values in some `Monoid`,
-- | combining adjacent elements using the specified separator.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > intercalate ", " ["Lorem", "ipsum", "dolor"]
-- | = "Lorem, ipsum, dolor"
-- |
-- | > intercalate "*" ["a", "b", "c"]
-- | = "a*b*c"
-- |
-- | > intercalate [1] [[2, 3], [4, 5], [6, 7]]
-- | = [2, 3, 1, 4, 5, 1, 6, 7]
-- | ```
intercalate :: forall f m. Foldable f => Monoid m => m -> f m -> m
intercalate sep xs = (foldl go { init: true, acc: mempty } xs).acc
  where
  go { init: true } x = { init: false, acc: x }
  go { acc: acc }   x = { init: false, acc: acc <> sep <> x }

-- | `foldMap` but with each element surrounded by some fixed value.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > surroundMap "*" show []
-- | = "*"
-- |
-- | > surroundMap "*" show [1]
-- | = "*1*"
-- |
-- | > surroundMap "*" show [1, 2]
-- | = "*1*2*"
-- |
-- | > surroundMap "*" show [1, 2, 3]
-- | = "*1*2*3*"
-- | ```
surroundMap :: forall f a m. Foldable f => Semigroup m => m -> (a -> m) -> f a -> m
surroundMap d t f = unwrap (foldMap joined f) d
  where joined a = Endo \m -> d <> t a <> m

-- | `fold` but with each element surrounded by some fixed value.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > surround "*" []
-- | = "*"
-- |
-- | > surround "*" ["1"]
-- | = "*1*"
-- |
-- | > surround "*" ["1", "2"]
-- | = "*1*2*"
-- |
-- | > surround "*" ["1", "2", "3"]
-- | = "*1*2*3*"
-- | ```
surround :: forall f m. Foldable f => Semigroup m => m -> f m -> m
surround d = surroundMap d identity

-- | The conjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether all of the values in a data
-- | structure are `true`.
and :: forall a f. Foldable f => HeytingAlgebra a => f a -> a
and = all identity

-- | The disjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether any of the values in a data
-- | structure is `true`.
or :: forall a f. Foldable f => HeytingAlgebra a => f a -> a
or = any identity

-- | `all f` is the same as `and <<< map f`; map a function over the structure,
-- | and then get the conjunction of the results.
all :: forall a b f. Foldable f => HeytingAlgebra b => (a -> b) -> f a -> b
all  = alaF Conj foldMap

-- | `any f` is the same as `or <<< map f`; map a function over the structure,
-- | and then get the disjunction of the results.
any :: forall a b f. Foldable f => HeytingAlgebra b => (a -> b) -> f a -> b
any = alaF Disj foldMap

-- | Find the sum of the numeric values in a data structure.
sum :: forall a f. Foldable f => Semiring a => f a -> a
sum = foldl (+) zero

-- | Find the product of the numeric values in a data structure.
product :: forall a f. Foldable f => Semiring a => f a -> a
product = foldl (*) one

-- | Test whether a value is an element of a data structure.
elem :: forall a f. Foldable f => Eq a => a -> f a -> Boolean
elem = any <<< (==)

-- | Test whether a value is not an element of a data structure.
notElem :: forall a f. Foldable f => Eq a => a -> f a -> Boolean
notElem x = not <<< elem x

-- | Try to get nth element from the left in a data structure
indexl :: forall a f. Foldable f => Int -> f a -> Maybe a
indexl idx = _.elem <<< foldl go { elem: Nothing, pos: 0 }
  where
  go cursor a =
    case cursor.elem of
      Just _ -> cursor
      _ ->
        if cursor.pos == idx
          then { elem: Just a, pos: cursor.pos }
          else { pos: cursor.pos + 1, elem: cursor.elem }

-- | Try to get nth element from the right in a data structure
indexr :: forall a f. Foldable f => Int -> f a -> Maybe a
indexr idx = _.elem <<< foldr go { elem: Nothing, pos: 0 }
  where
  go a cursor =
    case cursor.elem of
      Just _ -> cursor
      _ ->
        if cursor.pos == idx
          then { elem: Just a, pos: cursor.pos }
          else { pos: cursor.pos + 1, elem: cursor.elem }

-- | Try to find an element in a data structure which satisfies a predicate.
find :: forall a f. Foldable f => (a -> Boolean) -> f a -> Maybe a
find p = foldl go Nothing
  where
  go Nothing x | p x = Just x
  go r _ = r

-- | Try to find an element in a data structure which satisfies a predicate mapping.
findMap :: forall a b f. Foldable f => (a -> Maybe b) -> f a -> Maybe b
findMap p = foldl go Nothing
  where
  go Nothing x = p x
  go r _ = r

-- | Find the largest element of a structure, according to its `Ord` instance.
maximum :: forall a f. Ord a => Foldable f => f a -> Maybe a
maximum = maximumBy compare

-- | Find the largest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
maximumBy :: forall a f. Foldable f => (a -> a -> Ordering) -> f a -> Maybe a
maximumBy cmp = foldl max' Nothing
  where
  max' Nothing x  = Just x
  max' (Just x) y = Just (if cmp x y == GT then x else y)

-- | Find the smallest element of a structure, according to its `Ord` instance.
minimum :: forall a f. Ord a => Foldable f => f a -> Maybe a
minimum = minimumBy compare

-- | Find the smallest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
minimumBy :: forall a f. Foldable f => (a -> a -> Ordering) -> f a -> Maybe a
minimumBy cmp = foldl min' Nothing
  where
  min' Nothing x  = Just x
  min' (Just x) y = Just (if cmp x y == LT then x else y)

-- | Test whether the structure is empty.
-- | Optimized for structures that are similar to cons-lists, because there
-- | is no general way to do better.
null :: forall a f. Foldable f => f a -> Boolean
null = foldr (\_ _ -> false) true

-- | Returns the size/length of a finite structure.
-- | Optimized for structures that are similar to cons-lists, because there
-- | is no general way to do better.
length :: forall a b f. Foldable f => Semiring b => f a -> b
length = foldl (\c _ -> add one c) zero

-- | Lookup a value in a data structure of `Tuple`s, generalizing association lists.
lookup :: forall a b f. Foldable f => Eq a => a -> f (Tuple a b) -> Maybe b
lookup a = unwrap <<< foldMap \(Tuple a' b) -> First (if a == a' then Just b else Nothing)

module Data.Foldable
  ( class Foldable, foldr, foldl, foldMap
  , foldrDefault, foldlDefault, foldMapDefaultL, foldMapDefaultR
  , fold
  , foldM
  , traverse_
  , for_
  , sequence_
  , oneOf
  , oneOfMap
  , intercalate
  , surroundMap
  , surround
  , and
  , or
  , all
  , any
  , sum
  , product
  , elem
  , notElem
  , indexl
  , indexr
  , find
  , findMap
  , maximum
  , maximumBy
  , minimum
  , minimumBy
  , null
  , length
  ) where

import Prelude

import Control.Plus (class Plus, alt, empty)
import Data.Const (Const)
import Data.Either (Either(..))
import Data.Functor.App (App(..))
import Data.Functor.Compose (Compose(..))
import Data.Functor.Coproduct (Coproduct, coproduct)
import Data.Functor.Product (Product(..))
import Data.Identity (Identity(..))
import Data.Maybe (Maybe(..))
import Data.Maybe.First (First(..))
import Data.Maybe.Last (Last(..))
import Data.Monoid.Additive (Additive(..))
import Data.Monoid.Conj (Conj(..))
import Data.Monoid.Disj (Disj(..))
import Data.Monoid.Dual (Dual(..))
import Data.Monoid.Endo (Endo(..))
import Data.Monoid.Multiplicative (Multiplicative(..))
import Data.Newtype (alaF, unwrap)
import Data.Tuple (Tuple(..))

-- | `Foldable` represents data structures which can be _folded_.
-- |
-- | - `foldr` folds a structure from the right
-- | - `foldl` folds a structure from the left
-- | - `foldMap` folds a structure by accumulating values in a `Monoid`
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `foldrDefault`
-- | - `foldlDefault`
-- | - `foldMapDefaultR`
-- | - `foldMapDefaultL`
-- |
-- | Note: some combinations of the default implementations are unsafe to
-- | use together - causing a non-terminating mutually recursive cycle.
-- | These combinations are documented per function.
class Foldable f where
  foldr :: forall a b. (a -> b -> b) -> b -> f a -> b
  foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
  foldMap :: forall a m. Monoid m => (a -> m) -> f a -> m

-- | A default implementation of `foldr` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultR`.
foldrDefault
  :: forall f a b
   . Foldable f
  => (a -> b -> b)
  -> b
  -> f a
  -> b
foldrDefault c u xs = unwrap (foldMap (Endo <<< c) xs) u

-- | A default implementation of `foldl` using `foldMap`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldMapDefaultL`.
foldlDefault
  :: forall f a b
   . Foldable f
  => (b -> a -> b)
  -> b
  -> f a
  -> b
foldlDefault c u xs = unwrap (unwrap (foldMap (Dual <<< Endo <<< flip c) xs)) u

-- | A default implementation of `foldMap` using `foldr`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldrDefault`.
foldMapDefaultR
  :: forall f a m
   . Foldable f
  => Monoid m
  => (a -> m)
  -> f a
  -> m
foldMapDefaultR f = foldr (\x acc -> f x <> acc) mempty

-- | A default implementation of `foldMap` using `foldl`.
-- |
-- | Note: when defining a `Foldable` instance, this function is unsafe to use
-- | in combination with `foldlDefault`.
foldMapDefaultL
  :: forall f a m
   . Foldable f
  => Monoid m
  => (a -> m)
  -> f a
  -> m
foldMapDefaultL f = foldl (\acc x -> acc <> f x) mempty

instance foldableArray :: Foldable Array where
  foldr = foldrArray
  foldl = foldlArray
  foldMap = foldMapDefaultR

foreign import foldrArray :: forall a b. (a -> b -> b) -> b -> Array a -> b
foreign import foldlArray :: forall a b. (b -> a -> b) -> b -> Array a -> b

instance foldableMaybe :: Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = x `f` z
  foldl _ z Nothing  = z
  foldl f z (Just x) = z `f` x
  foldMap f Nothing  = mempty
  foldMap f (Just x) = f x

instance foldableFirst :: Foldable First where
  foldr f z (First x) = foldr f z x
  foldl f z (First x) = foldl f z x
  foldMap f (First x) = foldMap f x

instance foldableLast :: Foldable Last where
  foldr f z (Last x) = foldr f z x
  foldl f z (Last x) = foldl f z x
  foldMap f (Last x) = foldMap f x

instance foldableAdditive :: Foldable Additive where
  foldr f z (Additive x) = x `f` z
  foldl f z (Additive x) = z `f` x
  foldMap f (Additive x) = f x

instance foldableDual :: Foldable Dual where
  foldr f z (Dual x) = x `f` z
  foldl f z (Dual x) = z `f` x
  foldMap f (Dual x) = f x

instance foldableDisj :: Foldable Disj where
  foldr f z (Disj x) = f x z
  foldl f z (Disj x) = f z x
  foldMap f (Disj x) = f x

instance foldableConj :: Foldable Conj where
  foldr f z (Conj x) = f x z
  foldl f z (Conj x) = f z x
  foldMap f (Conj x) = f x

instance foldableMultiplicative :: Foldable Multiplicative where
  foldr f z (Multiplicative x) = x `f` z
  foldl f z (Multiplicative x) = z `f` x
  foldMap f (Multiplicative x) = f x

instance foldableEither :: Foldable (Either a) where
  foldr _ z (Left _)  = z
  foldr f z (Right x) = f x z
  foldl _ z (Left _)  = z
  foldl f z (Right x) = f z x
  foldMap f (Left _)  = mempty
  foldMap f (Right x) = f x

instance foldableTuple :: Foldable (Tuple a) where
  foldr f z (Tuple _ x) = f x z
  foldl f z (Tuple _ x) = f z x
  foldMap f (Tuple _ x) = f x

instance foldableIdentity :: Foldable Identity where
  foldr f z (Identity x) = f x z
  foldl f z (Identity x) = f z x
  foldMap f (Identity x) = f x

instance foldableConst :: Foldable (Const a) where
  foldr _ z _ = z
  foldl _ z _ = z
  foldMap _ _ = mempty

instance foldableProduct :: (Foldable f, Foldable g) => Foldable (Product f g) where
  foldr f z (Product (Tuple fa ga)) = foldr f (foldr f z ga) fa
  foldl f z (Product (Tuple fa ga)) = foldl f (foldl f z fa) ga
  foldMap f (Product (Tuple fa ga)) = foldMap f fa <> foldMap f ga

instance foldableCoproduct :: (Foldable f, Foldable g) => Foldable (Coproduct f g) where
  foldr f z = coproduct (foldr f z) (foldr f z)
  foldl f z = coproduct (foldl f z) (foldl f z)
  foldMap f = coproduct (foldMap f) (foldMap f)

instance foldableCompose :: (Foldable f, Foldable g) => Foldable (Compose f g) where
  foldr f i (Compose fga) = foldr (flip (foldr f)) i fga
  foldl f i (Compose fga) = foldl (foldl f) i fga
  foldMap f (Compose fga) = foldMap (foldMap f) fga

instance foldableApp :: Foldable f => Foldable (App f) where
  foldr f i (App x) = foldr f i x
  foldl f i (App x) = foldl f i x
  foldMap f (App x) = foldMap f x

-- | Fold a data structure, accumulating values in some `Monoid`.
fold :: forall f m. Foldable f => Monoid m => f m -> m
fold = foldMap identity

-- | Similar to 'foldl', but the result is encapsulated in a monad.
-- |
-- | Note: this function is not generally stack-safe, e.g., for monads which
-- | build up thunks a la `Eff`.
foldM :: forall f m a b. Foldable f => Monad m => (b -> a -> m b) -> b -> f a -> m b
foldM f b0 = foldl (\b a -> b >>= flip f a) (pure b0)

-- | Traverse a data structure, performing some effects encoded by an
-- | `Applicative` functor at each value, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | traverse_ print [1, 2, 3]
-- | ```
traverse_
  :: forall a b f m
   . Applicative m
  => Foldable f
  => (a -> m b)
  -> f a
  -> m Unit
traverse_ f = foldr ((*>) <<< f) (pure unit)

-- | A version of `traverse_` with its arguments flipped.
-- |
-- | This can be useful when running an action written using do notation
-- | for every element in a data structure:
-- |
-- | For example:
-- |
-- | ```purescript
-- | for_ [1, 2, 3] \n -> do
-- |   print n
-- |   trace "squared is"
-- |   print (n * n)
-- | ```
for_
  :: forall a b f m
   . Applicative m
  => Foldable f
  => f a
  -> (a -> m b)
  -> m Unit
for_ = flip traverse_

-- | Perform all of the effects in some data structure in the order
-- | given by the `Foldable` instance, ignoring the final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | sequence_ [ trace "Hello, ", trace " world!" ]
-- | ```
sequence_ :: forall a f m. Applicative m => Foldable f => f (m a) -> m Unit
sequence_ = traverse_ identity

-- | Combines a collection of elements using the `Alt` operation.
oneOf :: forall f g a. Foldable f => Plus g => f (g a) -> g a
oneOf = foldr alt empty

-- | Folds a structure into some `Plus`.
oneOfMap :: forall f g a b. Foldable f => Plus g => (a -> g b) -> f a -> g b
oneOfMap f = foldr (alt <<< f) empty

-- | Fold a data structure, accumulating values in some `Monoid`,
-- | combining adjacent elements using the specified separator.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > intercalate ", " ["Lorem", "ipsum", "dolor"]
-- | = "Lorem, ipsum, dolor"
-- |
-- | > intercalate "*" ["a", "b", "c"]
-- | = "a*b*c"
-- |
-- | > intercalate [1] [[2, 3], [4, 5], [6, 7]]
-- | = [2, 3, 1, 4, 5, 1, 6, 7]
-- | ```
intercalate :: forall f m. Foldable f => Monoid m => m -> f m -> m
intercalate sep xs = (foldl go { init: true, acc: mempty } xs).acc
  where
  go { init: true } x = { init: false, acc: x }
  go { acc: acc }   x = { init: false, acc: acc <> sep <> x }

-- | `foldMap` but with each element surrounded by some fixed value.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > surroundMap "*" show []
-- | = "*"
-- |
-- | > surroundMap "*" show [1]
-- | = "*1*"
-- |
-- | > surroundMap "*" show [1, 2]
-- | = "*1*2*"
-- |
-- | > surroundMap "*" show [1, 2, 3]
-- | = "*1*2*3*"
-- | ```
surroundMap :: forall f a m. Foldable f => Semigroup m => m -> (a -> m) -> f a -> m
surroundMap d t f = unwrap (foldMap joined f) d
  where joined a = Endo \m -> d <> t a <> m

-- | `fold` but with each element surrounded by some fixed value.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > surround "*" []
-- | = "*"
-- |
-- | > surround "*" ["1"]
-- | = "*1*"
-- |
-- | > surround "*" ["1", "2"]
-- | = "*1*2*"
-- |
-- | > surround "*" ["1", "2", "3"]
-- | = "*1*2*3*"
-- | ```
surround :: forall f m. Foldable f => Semigroup m => m -> f m -> m
surround d = surroundMap d identity

-- | The conjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether all of the values in a data
-- | structure are `true`.
and :: forall a f. Foldable f => HeytingAlgebra a => f a -> a
and = all identity

-- | The disjunction of all the values in a data structure. When specialized
-- | to `Boolean`, this function will test whether any of the values in a data
-- | structure is `true`.
or :: forall a f. Foldable f => HeytingAlgebra a => f a -> a
or = any identity

-- | `all f` is the same as `and <<< map f`; map a function over the structure,
-- | and then get the conjunction of the results.
all :: forall a b f. Foldable f => HeytingAlgebra b => (a -> b) -> f a -> b
all  = alaF Conj foldMap

-- | `any f` is the same as `or <<< map f`; map a function over the structure,
-- | and then get the disjunction of the results.
any :: forall a b f. Foldable f => HeytingAlgebra b => (a -> b) -> f a -> b
any = alaF Disj foldMap

-- | Find the sum of the numeric values in a data structure.
sum :: forall a f. Foldable f => Semiring a => f a -> a
sum = foldl (+) zero

-- | Find the product of the numeric values in a data structure.
product :: forall a f. Foldable f => Semiring a => f a -> a
product = foldl (*) one

-- | Test whether a value is an element of a data structure.
elem :: forall a f. Foldable f => Eq a => a -> f a -> Boolean
elem = any <<< (==)

-- | Test whether a value is not an element of a data structure.
notElem :: forall a f. Foldable f => Eq a => a -> f a -> Boolean
notElem x = not <<< elem x

-- | Try to get nth element from the left in a data structure
indexl :: forall a f. Foldable f => Int -> f a -> Maybe a
indexl idx = _.elem <<< foldl go { elem: Nothing, pos: 0 }
  where
  go cursor a =
    case cursor.elem of
      Just _ -> cursor
      _ ->
        if cursor.pos == idx
          then { elem: Just a, pos: cursor.pos }
          else { pos: cursor.pos + 1, elem: cursor.elem }

-- | Try to get nth element from the right in a data structure
indexr :: forall a f. Foldable f => Int -> f a -> Maybe a
indexr idx = _.elem <<< foldr go { elem: Nothing, pos: 0 }
  where
  go a cursor =
    case cursor.elem of
      Just _ -> cursor
      _ ->
        if cursor.pos == idx
          then { elem: Just a, pos: cursor.pos }
          else { pos: cursor.pos + 1, elem: cursor.elem }

-- | Try to find an element in a data structure which satisfies a predicate.
find :: forall a f. Foldable f => (a -> Boolean) -> f a -> Maybe a
find p = foldl go Nothing
  where
  go Nothing x | p x = Just x
  go r _ = r

-- | Try to find an element in a data structure which satisfies a predicate mapping.
findMap :: forall a b f. Foldable f => (a -> Maybe b) -> f a -> Maybe b
findMap p = foldl go Nothing
  where
  go Nothing x = p x
  go r _ = r

-- | Find the largest element of a structure, according to its `Ord` instance.
maximum :: forall a f. Ord a => Foldable f => f a -> Maybe a
maximum = maximumBy compare

-- | Find the largest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
maximumBy :: forall a f. Foldable f => (a -> a -> Ordering) -> f a -> Maybe a
maximumBy cmp = foldl max' Nothing
  where
  max' Nothing x  = Just x
  max' (Just x) y = Just (if cmp x y == GT then x else y)

-- | Find the smallest element of a structure, according to its `Ord` instance.
minimum :: forall a f. Ord a => Foldable f => f a -> Maybe a
minimum = minimumBy compare

-- | Find the smallest element of a structure, according to a given comparison
-- | function. The comparison function should represent a total ordering (see
-- | the `Ord` type class laws); if it does not, the behaviour is undefined.
minimumBy :: forall a f. Foldable f => (a -> a -> Ordering) -> f a -> Maybe a
minimumBy cmp = foldl min' Nothing
  where
  min' Nothing x  = Just x
  min' (Just x) y = Just (if cmp x y == LT then x else y)

-- | Test whether the structure is empty.
-- | Optimized for structures that are similar to cons-lists, because there
-- | is no general way to do better.
null :: forall a f. Foldable f => f a -> Boolean
null = foldr (\_ _ -> false) true

-- | Returns the size/length of a finite structure.
-- | Optimized for structures that are similar to cons-lists, because there
-- | is no general way to do better.
length :: forall a b f. Foldable f => Semiring b => f a -> b
length = foldl (\c _ -> add one c) zero

-- | Lookup a value in a data structure of `Tuple`s, generalizing association lists.
lookup :: forall a b f. Foldable f => Eq a => a -> f (Tuple a b) -> Maybe b
lookup a = unwrap <<< foldMap \(Tuple a' b) -> First (if a == a' then Just b else Nothing)


Updated for changes to Control.

Updated for changes to Control.

module Data.Foldable where

import Prelude
import Control.Apply
import Data.Either
import Data.Eq
import Data.Maybe
import Data.Monoid
import Data.Tuple

class Foldable f where
  foldr :: forall a b. (a -> b -> b) -> b -> f a -> b
  foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
  foldMap :: forall a m. (Monoid m) => (a -> m) -> f a -> m

instance foldableArray :: Foldable [] where
  foldr f z xs = foldrArray f z xs

  foldl f z xs = foldlArray f z xs

  foldMap f xs = foldr (\x acc -> f x <> acc) mempty xs

instance foldableEither :: Foldable (Either a) where
  foldr _ z (Left _)  = z
  foldr f z (Right x) = x `f` z

  foldl _ z (Left _)  = z
  foldl f z (Right x) = z `f` x

  foldMap f (Left _)  = mempty
  foldMap f (Right x) = f x

instance foldableMaybe :: Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = x `f` z

  foldl _ z Nothing  = z
  foldl f z (Just x) = z `f` x

  foldMap f Nothing  = mempty
  foldMap f (Just x) = f x

instance foldableRef :: Foldable Ref where
  foldr f z (Ref x) = x `f` z

  foldl f z (Ref x) = z `f` x

  foldMap f (Ref x) = f x

instance foldableTuple :: Foldable (Tuple a) where
  foldr f z (Tuple _ x) = x `f` z

  foldl f z (Tuple _ x) = z `f` x

  foldMap f (Tuple _ x) = f x

fold :: forall f m. (Foldable f, Monoid m) => f m -> m
fold = foldMap id

traverse_ :: forall a b f m. (Functor m, Applicative m, Foldable f) => (a -> m b) -> f a -> m {}
traverse_ f = foldr ((*>) <<< f) (pure {})

for_ :: forall a b f m. (Functor m, Applicative m, Foldable f) => f a -> (a -> m b) -> m {}
for_ = flip traverse_

sequence_ :: forall a f m. (Functor m, Applicative m, Foldable f) => f (m a) -> m {}
sequence_ = traverse_ id

mconcat :: forall f m. (Foldable f, Monoid m) => f m -> m
mconcat = foldl (<>) mempty

and :: forall f. (Foldable f) => f Boolean -> Boolean
and = foldl (&&) true

or :: forall f. (Foldable f) => f Boolean -> Boolean
or = foldl (||) false

any :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Boolean
any p = or <<< foldMap (\x -> [p x])

all :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Boolean
all p = and <<< foldMap (\x -> [p x])

sum :: forall f. (Foldable f) => f Number -> Number
sum = foldl (+) 0

product :: forall f. (Foldable f) => f Number -> Number
product = foldl (*) 1

elem :: forall a f. (Eq a, Foldable f) => a -> f a -> Boolean
elem = any  <<< (==)

notElem :: forall a f. (Eq a, Foldable f) => a -> f a -> Boolean
notElem x = not <<< elem x

find :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Maybe a
find p f = case foldMap (\x -> if p x then [x] else []) f of
  (x:_) -> Just x
  []    -> Nothing

foreign import foldrArray
  "function foldrArray(f) {\
  \  return function(z) {\
  \    return function(xs) {\
  \      var acc = z;\
  \      for (var i = xs.length - 1; i >= 0; --i) {\
  \        acc = f(xs[i])(acc);\
  \      }\
  \      return acc;\
  \    }\
  \  }\
  \}" :: forall a b. (a -> b -> b) -> b -> [a] -> b

foreign import foldlArray
  "function foldlArray(f) {\
  \  return function(z) {\
  \    return function(xs) {\
  \      var acc = z;\
  \      for (var i = 0, len = xs.length; i < len; ++i) {\
  \        acc = f(acc)(xs[i]);\
  \      }\
  \      return acc;\
  \    }\
  \  }\
  \}" :: forall a b. (b -> a -> b) -> b -> [a] -> b

module Data.Foldable where

import Prelude
import Control.Applicative
import Data.Either
import Data.Eq
import Data.Maybe
import Data.Monoid
import Data.Tuple

class Foldable f where
  foldr :: forall a b. (a -> b -> b) -> b -> f a -> b
  foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
  foldMap :: forall a m. (Monoid m) => (a -> m) -> f a -> m

instance foldableArray :: Foldable [] where
  foldr f z xs = foldrArray f z xs

  foldl f z xs = foldlArray f z xs

  foldMap f xs = foldr (\x acc -> f x <> acc) mempty xs

instance foldableEither :: Foldable (Either a) where
  foldr _ z (Left _)  = z
  foldr f z (Right x) = x `f` z

  foldl _ z (Left _)  = z
  foldl f z (Right x) = z `f` x

  foldMap f (Left _)  = mempty
  foldMap f (Right x) = f x

instance foldableMaybe :: Foldable Maybe where
  foldr _ z Nothing  = z
  foldr f z (Just x) = x `f` z

  foldl _ z Nothing  = z
  foldl f z (Just x) = z `f` x

  foldMap f Nothing  = mempty
  foldMap f (Just x) = f x

instance foldableRef :: Foldable Ref where
  foldr f z (Ref x) = x `f` z

  foldl f z (Ref x) = z `f` x

  foldMap f (Ref x) = f x

instance foldableTuple :: Foldable (Tuple a) where
  foldr f z (Tuple _ x) = x `f` z

  foldl f z (Tuple _ x) = z `f` x

  foldMap f (Tuple _ x) = f x

fold :: forall f m. (Foldable f, Monoid m) => f m -> m
fold = foldMap id

traverse_ :: forall a b f m. (Functor m, Applicative m, Foldable f) => (a -> m b) -> f a -> m {}
traverse_ f = foldr ((*>) <<< f) (pure {})

for_ :: forall a b f m. (Functor m, Applicative m, Foldable f) => f a -> (a -> m b) -> m {}
for_ = flip traverse_

sequence_ :: forall a f m. (Functor m, Applicative m, Foldable f) => f (m a) -> m {}
sequence_ = traverse_ id

mconcat :: forall f m. (Foldable f, Monoid m) => f m -> m
mconcat = foldl (<>) mempty

and :: forall f. (Foldable f) => f Boolean -> Boolean
and = foldl (&&) true

or :: forall f. (Foldable f) => f Boolean -> Boolean
or = foldl (||) false

any :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Boolean
any p = or <<< foldMap (\x -> [p x])

all :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Boolean
all p = and <<< foldMap (\x -> [p x])

sum :: forall f. (Foldable f) => f Number -> Number
sum = foldl (+) 0

product :: forall f. (Foldable f) => f Number -> Number
product = foldl (*) 1

elem :: forall a f. (Eq a, Foldable f) => a -> f a -> Boolean
elem = any  <<< (==)

notElem :: forall a f. (Eq a, Foldable f) => a -> f a -> Boolean
notElem x = not <<< elem x

find :: forall a f. (Foldable f) => (a -> Boolean) -> f a -> Maybe a
find p f = case foldMap (\x -> if p x then [x] else []) f of
  (x:_) -> Just x
  []    -> Nothing

foreign import foldrArray
  "function foldrArray(f) {\
  \  return function(z) {\
  \    return function(xs) {\
  \      var acc = z;\
  \      for (var i = xs.length - 1; i >= 0; --i) {\
  \        acc = f(xs[i])(acc);\
  \      }\
  \      return acc;\
  \    }\
  \  }\
  \}" :: forall a b. (a -> b -> b) -> b -> [a] -> b

foreign import foldlArray
  "function foldlArray(f) {\
  \  return function(z) {\
  \    return function(xs) {\
  \      var acc = z;\
  \      for (var i = 0, len = xs.length; i < len; ++i) {\
  \        acc = f(acc)(xs[i]);\
  \      }\
  \      return acc;\
  \    }\
  \  }\
  \}" :: forall a b. (b -> a -> b) -> b -> [a] -> b


Cosmetics - drop unicode symbols

Cosmetics - drop unicode symbols

module Hyper.Cookies
       ( cookies
       , CookieAttributes
       , SameSite(..)
       , Name
       , maxAge
       , MaxAge
       , defaultCookieAttributes
       , setCookie
       , Value
       , Values
       ) where

import Prelude

import Control.IxMonad (ibind)
import Control.Monad.Error.Class (throwError)
import Data.Array (catMaybes, cons, filter, foldMap, uncons, (:))
import Data.Either (Either)
import Data.JSDate (JSDate, toUTCString)
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.NonEmpty (NonEmpty(NonEmpty), (:|))
import Data.NonEmpty as NonEmpty
import Data.StrMap (StrMap)
import Data.StrMap as StrMap
import Data.String (Pattern(..), joinWith, split, trim)
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..), uncurry)
import Global (encodeURIComponent, decodeURIComponent)
import Hyper.Conn (Conn)
import Hyper.Middleware (Middleware)
import Hyper.Middleware.Class (getConn, putConn)
import Hyper.Request (class Request, getRequestData)
import Hyper.Response (class Response, HeadersOpen, writeHeader)

type Name = String
type Value = String
type Values = NonEmpty Array Value

toPair :: Array String -> Either String (Tuple String (Array String))
toPair kv =
  case kv of
    [key, value] ->
      pure (Tuple (decodeURIComponent key) [decodeURIComponent value])
    parts ->
      throwError ("Invalid cookie-pair: " <> joinWith " " parts)

splitPairs :: String -> Either String (Array (Tuple String (Array String)))
splitPairs =
  split (Pattern ";")
  >>> map trim
  >>> filter ((/=) "")
  >>> map (split (Pattern "="))
  >>> map toPair
  >>> sequence

parseCookies :: String -> Either String (StrMap Values)
parseCookies s =
  splitPairs s
  # map (foldMap toCookieMap)
  # map (StrMap.fromFoldableWith combineCookies)
  where
    toCookieMap (Tuple name values) =
      case uncons values of
        Just { head, tail } -> [Tuple name (NonEmpty head tail)]
        Nothing -> []

    combineCookies xs xs' =
      NonEmpty.head xs :| NonEmpty.head xs' : NonEmpty.tail xs <> NonEmpty.tail xs'

cookies :: forall m req res c
  .  Monad m
  => Request req m
  => Middleware
     m
     (Conn req res { cookies :: Unit | c})
     (Conn req res { cookies :: Either String (StrMap Values) | c})
     Unit
cookies = do
  conn <- getConn
  { headers } <- getRequestData
  let cookies' = maybe (pure StrMap.empty) parseCookies (StrMap.lookup "cookie" headers)
  putConn conn { components { cookies = cookies' }}
  where bind = ibind

data SameSite = Strict | Lax
newtype MaxAge = MaxAge Int
derive instance newtypeMaxAge :: Newtype MaxAge _

maxAge :: Int -> Maybe MaxAge
maxAge a | a < 0 = Nothing
         | otherwise = Just (MaxAge a)

type CookieAttributes =
  { comment :: Maybe String
  , domain :: Maybe String
  , expires :: Maybe JSDate
  , httpOnly :: Boolean
  , maxAge :: Maybe MaxAge
  , path :: Maybe String
  , sameSite :: Maybe SameSite
  , secure :: Boolean
  }

defaultCookieAttributes :: CookieAttributes
defaultCookieAttributes =
  { comment: Nothing
  , domain: Nothing
  , expires: Nothing
  , httpOnly: false
  , maxAge: Nothing
  , path: Nothing
  , sameSite: Nothing
  , secure: false
  }

setCookieHeaderValue :: Name -> Value -> CookieAttributes -> String
setCookieHeaderValue key value { comment, expires, path, maxAge: m, domain, secure, httpOnly, sameSite } =
  [ (Tuple "Comment" <<< encodeURIComponent) <$> comment
  , (Tuple "Expires" <<< toUTCString) <$> expires
  , (Tuple "Max-Age" <<< show <<< unwrap) <$> m
  , Tuple "Domain" <$> domain
  , Tuple "Path" <$> path
  , Tuple "SameSite" <<< sameSiteSer <$> sameSite
  ]
  # map (uncurry assigment <$> _)
  # cons (if secure then Just "Secure" else Nothing)
  # cons (if httpOnly then Just "HttpOnly" else Nothing)
  # catMaybes
  # cons (assigment (encodeURIComponent key)  (encodeURIComponent value))
  # joinWith ";"
 where
  assigment k v = k <> "=" <> v

  sameSiteSer :: SameSite -> String
  sameSiteSer Strict = "Strict"
  sameSiteSer Lax = "Lax"

setCookie :: forall m req res c b
  .  Monad m
  => Response res m b
  => Name
  -> Value
  -> CookieAttributes
  -> Middleware
     m
     (Conn req (res HeadersOpen) c)
     (Conn req (res HeadersOpen) c)
     Unit
setCookie key value attrs =
  writeHeader (Tuple "Set-Cookie" (setCookieHeaderValue key value attrs))

module Hyper.Cookies
       ( cookies
       , CookieAttributes
       , SameSite(..)
       , Name
       , maxAge
       , MaxAge
       , defaultCookieAttributes
       , setCookie
       , Value
       , Values
       ) where

import Prelude

import Control.IxMonad (ibind)
import Control.Monad.Error.Class (throwError)
import Data.Array (catMaybes, cons, filter, foldMap, uncons, (:))
import Data.Either (Either)
import Data.JSDate (JSDate, toUTCString)
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.NonEmpty (NonEmpty(NonEmpty), (:|))
import Data.NonEmpty as NonEmpty
import Data.StrMap (StrMap)
import Data.StrMap as StrMap
import Data.String (Pattern(..), joinWith, split, trim)
import Data.Traversable (sequence)
import Data.Tuple (Tuple(..), uncurry)
import Global (encodeURIComponent, decodeURIComponent)
import Hyper.Conn (Conn)
import Hyper.Middleware (Middleware)
import Hyper.Middleware.Class (getConn, putConn)
import Hyper.Request (class Request, getRequestData)
import Hyper.Response (class Response, HeadersOpen, writeHeader)

type Name = String
type Value = String
type Values = NonEmpty Array Value

toPair :: Array String -> Either String (Tuple String (Array String))
toPair kv =
  case kv of
    [key, value] ->
      pure (Tuple (decodeURIComponent key) [decodeURIComponent value])
    parts ->
      throwError ("Invalid cookie-pair: " <> joinWith " " parts)

splitPairs :: String -> Either String (Array (Tuple String (Array String)))
splitPairs =
  split (Pattern ";")
  >>> map trim
  >>> filter ((/=) "")
  >>> map (split (Pattern "="))
  >>> map toPair
  >>> sequence

parseCookies :: String -> Either String (StrMap Values)
parseCookies s =
  splitPairs s
  # map (foldMap toCookieMap)
  # map (StrMap.fromFoldableWith combineCookies)
  where
    toCookieMap (Tuple name values) =
      case uncons values of
        Just { head, tail } -> [Tuple name (NonEmpty head tail)]
        Nothing -> []

    combineCookies xs xs' =
      NonEmpty.head xs :| NonEmpty.head xs' : NonEmpty.tail xs <> NonEmpty.tail xs'

cookies :: forall m req res c
  .  Monad m
  => Request req m
  => Middleware
     m
     (Conn req res { cookies :: Unit | c})
     (Conn req res { cookies :: Either String (StrMap Values) | c})
     Unit
cookies = do
  conn <- getConn
  { headers } <- getRequestData
  let cookies' = maybe (pure StrMap.empty) parseCookies (StrMap.lookup "cookie" headers)
  putConn conn { components { cookies = cookies' }}
  where bind = ibind

data SameSite = Strict | Lax
newtype MaxAge = MaxAge Int
derive instance newtypeMaxAge ∷ Newtype MaxAge _

maxAge ∷ Int → Maybe MaxAge
maxAge a | a < 0 = Nothing
         | otherwise = Just (MaxAge a)

type CookieAttributes =
  { comment :: Maybe String
  , domain :: Maybe String
  , expires :: Maybe JSDate
  , httpOnly :: Boolean
  , maxAge :: Maybe MaxAge
  , path :: Maybe String
  , sameSite :: Maybe SameSite
  , secure :: Boolean
  }

defaultCookieAttributes :: CookieAttributes
defaultCookieAttributes =
  { comment: Nothing
  , domain: Nothing
  , expires: Nothing
  , httpOnly: false
  , maxAge: Nothing
  , path: Nothing
  , sameSite: Nothing
  , secure: false
  }

setCookieHeaderValue :: Name -> Value -> CookieAttributes -> String
setCookieHeaderValue key value { comment, expires, path, maxAge: m, domain, secure, httpOnly, sameSite } =
  [ (Tuple "Comment" <<< encodeURIComponent) <$> comment
  , (Tuple "Expires" <<< toUTCString) <$> expires
  , (Tuple "Max-Age" <<< show <<< unwrap) <$> m
  , Tuple "Domain" <$> domain
  , Tuple "Path" <$> path
  , Tuple "SameSite" <<< sameSiteSer <$> sameSite
  ]
  # map (uncurry assigment <$> _)
  # cons (if secure then Just "Secure" else Nothing)
  # cons (if httpOnly then Just "HttpOnly" else Nothing)
  # catMaybes
  # cons (assigment (encodeURIComponent key)  (encodeURIComponent value))
  # joinWith ";"
 where
  assigment k v = k <> "=" <> v

  sameSiteSer :: SameSite -> String
  sameSiteSer Strict = "Strict"
  sameSiteSer Lax = "Lax"

setCookie :: forall m req res c b
  .  Monad m
  => Response res m b
  => Name
  -> Value
  -> CookieAttributes
  -> Middleware
     m
     (Conn req (res HeadersOpen) c)
     (Conn req (res HeadersOpen) c)
     Unit
setCookie key value attrs =
  writeHeader (Tuple "Set-Cookie" (setCookieHeaderValue key value attrs))


websocket shouldn't close when `complete` is issued - websocket lifetime is outside the scope of RPC

module WebSocket.RPC
  ( RPCClientParams, RPCClient, ClientAppT, AllEffs, rpcClient
  , module WebSocket.RPC.Trans.Client
  , module WebSocket.RPC.Types
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Eff.Var (($=))
import Data.Argonaut (class EncodeJson, class DecodeJson, encodeJson, decodeJson, printJson, jsonParser)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import WebSocket (Connection(Connection), runMessage, runMessageEvent, WEBSOCKET, Message(Message))
import WebSocket.RPC.Trans.Client (WebSocketClientRPCT, execWebSocketClientRPCT, freshRPCID, getClientEnv, registerReplyComplete, runComplete, runReply, runWebSocketClientRPCT', unregisterReplyComplete)
import WebSocket.RPC.Types (RPCIdentified(RPCIdentified), Subscribe(Subscribe), Supply(Supply), Reply(Reply), Complete(Complete), ServerToClient(..))

type RPCClientParams sup m =
  { supply :: sup -> m Unit
  , cancel :: m Unit
  }

type RPCClient sub sup rep com m =
  { subscription :: sub
  , onReply      :: RPCClientParams sup m -> rep -> m Unit
  , onComplete   :: com -> m Unit
  }

type ClientAppT m a = Connection -> m a

type AllEffs eff =
  ( ref     :: REF
  , err     :: EXCEPTION
  , ws      :: WEBSOCKET
  , console :: CONSOLE
  | eff)

rpcClient :: forall sub sup rep com eff
           . ( EncodeJson sub
             , EncodeJson sup
             , DecodeJson rep
             , DecodeJson com
             )
          => (( RPCClient sub sup rep com (Eff (AllEffs eff)) -> WebSocketClientRPCT rep com (Eff (AllEffs eff)) Unit)
                -> WebSocketClientRPCT rep com (Eff (AllEffs eff)) Unit)
          -> ClientAppT (WebSocketClientRPCT rep com (Eff (AllEffs eff))) Unit
rpcClient userGo (Connection socket) =
  let go :: RPCClient sub sup rep com (Eff (AllEffs eff)) -> WebSocketClientRPCT rep com (Eff (AllEffs eff)) Unit
      go params@{subscription,onReply,onComplete} = do
        env <- getClientEnv

        liftEff $ socket.onopen $= \_ -> runWebSocketClientRPCT' env $ do
          _ident <- freshRPCID

          liftEff $ socket.send $ Message $ printJson $ encodeJson $ Subscribe $ RPCIdentified {_ident, _params: subscription}

          let supply :: sup -> Eff (AllEffs eff) Unit
              supply sup =
                socket.send $ Message $ printJson $ encodeJson $ Supply $ RPCIdentified {_ident, _params: Just sup}

              cancel :: Eff (AllEffs eff) Unit
              cancel = do
                socket.send $ Message $ printJson $ encodeJson $ Supply $ RPCIdentified {_ident, _params: (Nothing :: Maybe Unit)}
                runWebSocketClientRPCT' env (unregisterReplyComplete _ident)

          registerReplyComplete _ident (onReply {supply,cancel}) onComplete

          let runRep :: Reply rep -> WebSocketClientRPCT rep com (Eff (AllEffs eff)) Unit
              runRep (Reply (RPCIdentified {_ident: _ident', _params}))
                | _ident' == _ident = runReply _ident _params
                | otherwise         = pure unit -- FIXME throw warning?

              runCom :: Complete com -> WebSocketClientRPCT rep com (Eff (AllEffs eff)) Unit
              runCom (Complete (RPCIdentified {_ident: _ident', _params}))
                | _ident' == _ident = do
                    runComplete _ident' _params
                    unregisterReplyComplete _ident'
                | otherwise = pure unit

          liftEff $ socket.onmessage $= \event -> do
            let received :: String
                received = runMessage (runMessageEvent event)

            case decodeJson =<< jsonParser received of
              Left err -> log $ "WebSocket parse error: " <> err
              Right x -> case x of
                Rep rep -> runWebSocketClientRPCT' env (runRep rep)
                Com com -> runWebSocketClientRPCT' env (runCom com)
                Ping    -> socket.send $ Message $ printJson $ encodeJson ([] :: Array Unit)

  in  userGo go

module WebSocket.RPC
  ( RPCClientParams, RPCClient, ClientAppT, AllEffs, rpcClient
  , module WebSocket.RPC.Trans.Client
  , module WebSocket.RPC.Types
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Eff.Var (($=))
import Data.Argonaut (class EncodeJson, class DecodeJson, encodeJson, decodeJson, printJson, jsonParser)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import WebSocket (Connection(Connection), runMessage, runMessageEvent, WEBSOCKET, Message(Message))
import WebSocket.RPC.Trans.Client (WebSocketClientRPCT, execWebSocketClientRPCT, freshRPCID, getClientEnv, registerReplyComplete, runComplete, runReply, runWebSocketClientRPCT', unregisterReplyComplete)
import WebSocket.RPC.Types (RPCIdentified(RPCIdentified), Subscribe(Subscribe), Supply(Supply), Reply(Reply), Complete(Complete), ServerToClient(..))

type RPCClientParams sup m =
  { supply :: sup -> m Unit
  , cancel :: m Unit
  }

type RPCClient sub sup rep com m =
  { subscription :: sub
  , onReply      :: RPCClientParams sup m -> rep -> m Unit
  , onComplete   :: com -> m Unit
  }

type ClientAppT m a = Connection -> m a

type AllEffs eff =
  ( ref     :: REF
  , err     :: EXCEPTION
  , ws      :: WEBSOCKET
  , console :: CONSOLE
  | eff)

rpcClient :: forall sub sup rep com eff
           . ( EncodeJson sub
             , EncodeJson sup
             , DecodeJson rep
             , DecodeJson com
             )
          => (( RPCClient sub sup rep com (Eff (AllEffs eff)) -> WebSocketClientRPCT rep com (Eff (AllEffs eff)) Unit)
                -> WebSocketClientRPCT rep com (Eff (AllEffs eff)) Unit)
          -> ClientAppT (WebSocketClientRPCT rep com (Eff (AllEffs eff))) Unit
rpcClient userGo (Connection socket) =
  let go :: RPCClient sub sup rep com (Eff (AllEffs eff)) -> WebSocketClientRPCT rep com (Eff (AllEffs eff)) Unit
      go params@{subscription,onReply,onComplete} = do
        env <- getClientEnv

        liftEff $ socket.onopen $= \_ -> runWebSocketClientRPCT' env $ do
          _ident <- freshRPCID

          liftEff $ socket.send $ Message $ printJson $ encodeJson $ Subscribe $ RPCIdentified {_ident, _params: subscription}

          let supply :: sup -> Eff (AllEffs eff) Unit
              supply sup =
                socket.send $ Message $ printJson $ encodeJson $ Supply $ RPCIdentified {_ident, _params: Just sup}

              cancel :: Eff (AllEffs eff) Unit
              cancel = do
                socket.send $ Message $ printJson $ encodeJson $ Supply $ RPCIdentified {_ident, _params: (Nothing :: Maybe Unit)}
                socket.close
                runWebSocketClientRPCT' env (unregisterReplyComplete _ident)

          registerReplyComplete _ident (onReply {supply,cancel}) onComplete

          let runRep :: Reply rep -> WebSocketClientRPCT rep com (Eff (AllEffs eff)) Unit
              runRep (Reply (RPCIdentified {_ident: _ident', _params}))
                | _ident' == _ident = runReply _ident _params
                | otherwise         = pure unit -- FIXME throw warning?

              runCom :: Complete com -> WebSocketClientRPCT rep com (Eff (AllEffs eff)) Unit
              runCom (Complete (RPCIdentified {_ident: _ident', _params}))
                | _ident' == _ident = do
                    runComplete _ident' _params
                    liftEff socket.close
                    unregisterReplyComplete _ident'
                | otherwise = pure unit

          liftEff $ socket.onmessage $= \event -> do
            let received :: String
                received = runMessage (runMessageEvent event)

            case decodeJson =<< jsonParser received of
              Left err -> log $ "WebSocket parse error: " <> err
              Right x -> case x of
                Rep rep -> runWebSocketClientRPCT' env (runRep rep)
                Com com -> runWebSocketClientRPCT' env (runCom com)
                Ping    -> socket.send $ Message $ printJson $ encodeJson ([] :: Array Unit)

  in  userGo go


Update test for replaceR, add test for replace'

module Test.Data.String.Regex where

import Data.Array (reverse)
import Data.String (joinWith)
import Data.String.Regex
import Debug.Trace
import Control.Monad.Eff
import qualified Test.QuickCheck as QC

assert :: Boolean -> QC.QC {}
assert = QC.quickCheck' 1

main = do

  let r = regex "test" "g"

  trace "test 'test' matches correctly"
  assert $ test r "testing"
  trace "test 'test' reports false for a mismatch"
  assert $ not $ test r "foo"

  trace "test 'replace' replaces all matches"
  assert $ replace r "work" "testing testing 1 2 3" == "working working 1 2 3"

  trace "test 'replace'' replaces matches with a function"
  assert $ replace' (regex "(some) (test)" "") (\match groups -> joinWith " " (reverse groups)) "here are some test words" == "here are test some words"

  trace "test 'search' finds the first match"
  assert $ search r "the string 'test' first appears in this test at index 12" == 12

  trace "test 'match' reports the correct number of matches"
  assert $ match r "test test test" == ["test", "test", "test"]

module Test.Data.String.Regex where

import Data.String.Regex
import Debug.Trace
import Control.Monad.Eff
import qualified Test.QuickCheck as QC

assert :: Boolean -> QC.QC {}
assert = QC.quickCheck' 1

main = do

  let r = regex "test" "g"

  trace "test 'test' matches correctly"
  assert $ test r "testing"
  trace "test 'test' reports false for a mismatch"
  assert $ not $ test r "foo"

  trace "test 'replaceR' replaces all matches"
  assert $ replaceR r "work" "testing testing 1 2 3" == "working working 1 2 3"

  trace "test 'search' finds the first match"
  assert $ search r "the string 'test' first appears in this test at index 12" == 12

  trace "test 'match' reports the correct number of matches"
  assert $ match r "test test test" == ["test", "test", "test"]


Add some extra instances for RegexFlags

Add some extra instances for RegexFlags

module Data.String.Regex.Flags where

import Prelude

import Control.MonadPlus (guard)

import Data.Monoid (class Monoid)
import Data.String (joinWith)

type RegexFlagsRec =
  { global :: Boolean
  , ignoreCase :: Boolean
  , multiline :: Boolean
  , sticky :: Boolean
  , unicode :: Boolean
  }

-- | Flags that control matching.
data RegexFlags = RegexFlags RegexFlagsRec

-- | All flags set to false.
noFlags :: RegexFlags
noFlags = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: false
  , sticky: false
  , unicode: false
  }

-- | Only global flag set to true
global :: RegexFlags
global = RegexFlags
  { global: true
  , ignoreCase: false
  , multiline: false
  , sticky: false
  , unicode: false
  }

-- | Only ignoreCase flag set to true
ignoreCase :: RegexFlags
ignoreCase = RegexFlags
  { global: false
  , ignoreCase: true
  , multiline: false
  , sticky: false
  , unicode: false
  }

-- | Only multiline flag set to true
multiline :: RegexFlags
multiline = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: true
  , sticky: false
  , unicode: false
  }

-- | Only sticky flag set to true
sticky :: RegexFlags
sticky = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: false
  , sticky: true
  , unicode: false
  }

-- | Only unicode flag set to true
unicode :: RegexFlags
unicode = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: false
  , sticky: false
  , unicode: true
  }

instance semigroupRegexFlags :: Semigroup RegexFlags where
  append (RegexFlags x) (RegexFlags y) = RegexFlags
    { global: x.global || y.global
    , ignoreCase: x.ignoreCase || y.ignoreCase
    , multiline: x.multiline || y.multiline
    , sticky: x.sticky || y.sticky
    , unicode: x.unicode || y.unicode
    }

instance monoidRegexFlags :: Monoid RegexFlags where
  mempty = noFlags

instance eqRegexFlags :: Eq RegexFlags where
  eq (RegexFlags x) (RegexFlags y)
    = x.global == y.global
    && x.ignoreCase == y.ignoreCase
    && x.multiline == y.multiline
    && x.sticky == y.sticky
    && x.unicode == y.unicode

instance showRegexFlags :: Show RegexFlags where
  show (RegexFlags flags) =
    let
      usedFlags =
        []
        <> (guard flags.global $> "global")
        <> (guard flags.ignoreCase $> "ignoreCase")
        <> (guard flags.multiline $> "multiline")
        <> (guard flags.sticky $> "sticky")
        <> (guard flags.unicode $> "unicode")
    in
      if usedFlags == []
      then "noFlags"
      else "(" <> joinWith " <> " usedFlags <> ")"

module Data.String.Regex.Flags where

import Prelude
import Data.Monoid (class Monoid)

type RegexFlagsRec =
  { global :: Boolean
  , ignoreCase :: Boolean
  , multiline :: Boolean
  , sticky :: Boolean
  , unicode :: Boolean
  }

-- | Flags that control matching.
data RegexFlags = RegexFlags RegexFlagsRec

-- | All flags set to false.
noFlags :: RegexFlags
noFlags = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: false
  , sticky: false
  , unicode: false
  }

-- | Only global flag set to true
global :: RegexFlags
global = RegexFlags
  { global: true
  , ignoreCase: false
  , multiline: false
  , sticky: false
  , unicode: false
  }

-- | Only ignoreCase flag set to true
ignoreCase :: RegexFlags
ignoreCase = RegexFlags
  { global: false
  , ignoreCase: true
  , multiline: false
  , sticky: false
  , unicode: false
  }

-- | Only multiline flag set to true
multiline :: RegexFlags
multiline = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: true
  , sticky: false
  , unicode: false
  }

-- | Only sticky flag set to true
sticky :: RegexFlags
sticky = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: false
  , sticky: true
  , unicode: false
  }

-- | Only unicode flag set to true
unicode :: RegexFlags
unicode = RegexFlags
  { global: false
  , ignoreCase: false
  , multiline: false
  , sticky: false
  , unicode: true
  }

instance semigroupRegexFlags :: Semigroup RegexFlags where
  append (RegexFlags x) (RegexFlags y) = RegexFlags
    { global: x.global || y.global
    , ignoreCase: x.ignoreCase || y.ignoreCase
    , multiline: x.multiline || y.multiline
    , sticky: x.sticky || y.sticky
    , unicode: x.unicode || y.unicode
    }

instance monoidRegexFlags :: Monoid RegexFlags where
  mempty = noFlags


refactor: Database.PostgreSQL.PG -> remove unused type alias Database

module Database.PostgreSQL.PG
( module Row
, module Value
, module PostgreSQL
, command
, execute
, query
, onIntegrityError
, scalar
, withConnection
, withTransaction
) where

import Prelude

import Control.Monad.Error.Class (class MonadError, catchError, throwError)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe, maybe)
import Database.PostgreSQL (Connection, PGError(..), Pool, Query)
import Database.PostgreSQL (class FromSQLRow, class FromSQLValue, class ToSQLRow, class ToSQLValue, Connection, Database, PGError(..), PGErrorDetail, Pool, PoolConfiguration, Query(..), Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), defaultPoolConfiguration, fromSQLRow, fromSQLValue, instantFromString, instantToString, newPool, null, toSQLRow, toSQLValue, unsafeIsBuffer) as PostgreSQL
import Database.PostgreSQL (command, execute, query, scalar, withConnection, withTransaction) as P
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), fromSQLRow, toSQLRow) as Row
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row1)
import Database.PostgreSQL.Value (class FromSQLValue)
import Database.PostgreSQL.Value (class FromSQLValue, class ToSQLValue, fromSQLValue, instantFromString, instantToString, null, toSQLValue, unsafeIsBuffer) as Value
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff, liftAff)

hoistAffEither :: forall a m. MonadAff m => MonadError PGError m => Aff (Either PGError a) -> m a
hoistAffEither m = liftAff m >>= either throwError pure

-- | Run an action with a connection. The connection is released to the pool
-- | when the action returns.
withConnection
    :: forall a m
     . MonadError PGError m
    => MonadAff m
    => (m a -> Aff (Either PGError a))
    -> Pool
    -> (Connection -> m a)
    -> m a
withConnection f p k = do
  res <- liftAff $ P.withConnection p case _ of
    Right conn -> f $ k conn
    Left pgErr -> pure $ Left pgErr
  either throwError pure res

-- | Run an action within a transaction. The transaction is committed if the
-- | action returns cleanly, and rolled back if the action throws (either a
-- | `PGError` or a JavaScript exception in PG context). If you want to
-- | change the transaction mode, issue a separate `SET TRANSACTION` statement
-- | within the transaction.
withTransaction
    :: forall a m
     . MonadAff m
    => MonadError PGError m
    => (m a -> Aff (Either PGError a))
    -> Connection
    -> m a
    -> m a
withTransaction f conn action = do
  res <- liftAff $ P.withTransaction conn (f action)
  either throwError pure $ join res

-- | Execute a PostgreSQL query and discard its results.
execute
    :: forall i o m
     . ToSQLRow i
    => MonadError PGError m
    => MonadAff m
    => Connection
    -> Query i o
    -> i
    -> m Unit
execute conn sql values = do
  err <- liftAff $ P.execute conn sql values
  maybe (pure unit) throwError err

-- | Execute a PostgreSQL query and return its results.
query
    :: forall i o m
     . ToSQLRow i
    => FromSQLRow o
    => MonadError PGError m
    => MonadAff m
    => Connection
    -> Query i o
    -> i
    -> m (Array o)
query conn sql = hoistAffEither <<< P.query conn sql

-- | Execute a PostgreSQL query and return the first field of the first row in
-- | the result.
scalar
    :: forall i o m
     . ToSQLRow i
    => FromSQLValue o
    => MonadError PGError m
    => MonadAff m
    => Connection
    -> Query i (Row1 o)
    -> i
    -> m (Maybe o)
scalar conn sql = hoistAffEither <<< P.scalar conn sql

-- | Execute a PostgreSQL query and return its command tag value
-- | (how many rows were affected by the query). This may be useful
-- | for example with `DELETE` or `UPDATE` queries.
command
    :: forall i m
     . ToSQLRow i
    => MonadError PGError m
    => MonadAff m
    => Connection
    -> Query i Int
    -> i
    -> m Int
command conn sql = hoistAffEither <<< P.command conn sql

onIntegrityError
    :: forall a m
     . MonadError PGError m
    => m a
    -> m a
    -> m a
onIntegrityError errorResult db =
    catchError db handleError
    where
    handleError e =
        case e of
            IntegrityError _ -> errorResult
            _ -> throwError e

module Database.PostgreSQL.PG
( module Row
, module Value
, module PostgreSQL
, command
, execute
, query
, onIntegrityError
, scalar
, withConnection
, withTransaction
) where

import Prelude

import Control.Monad.Error.Class (class MonadError, catchError, throwError)
import Data.Either (Either(..), either)
import Data.Maybe (Maybe, maybe)
import Database.PostgreSQL (Connection, PGError(..), Pool, Query)
import Database.PostgreSQL (class FromSQLRow, class FromSQLValue, class ToSQLRow, class ToSQLValue, Connection, Database, PGError(..), PGErrorDetail, Pool, PoolConfiguration, Query(..), Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), defaultPoolConfiguration, fromSQLRow, fromSQLValue, instantFromString, instantToString, newPool, null, toSQLRow, toSQLValue, unsafeIsBuffer) as PostgreSQL
import Database.PostgreSQL (command, execute, query, scalar, withConnection, withTransaction) as P
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), fromSQLRow, toSQLRow) as Row
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row1)
import Database.PostgreSQL.Value (class FromSQLValue)
import Database.PostgreSQL.Value (class FromSQLValue, class ToSQLValue, fromSQLValue, instantFromString, instantToString, null, toSQLValue, unsafeIsBuffer) as Value
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff, liftAff)

type Database = String

hoistAffEither :: forall a m. MonadAff m => MonadError PGError m => Aff (Either PGError a) -> m a
hoistAffEither m = liftAff m >>= either throwError pure

-- | Run an action with a connection. The connection is released to the pool
-- | when the action returns.
withConnection
    :: forall a m
     . MonadError PGError m
    => MonadAff m
    => (m a -> Aff (Either PGError a))
    -> Pool
    -> (Connection -> m a)
    -> m a
withConnection f p k = do
  res <- liftAff $ P.withConnection p case _ of
    Right conn -> f $ k conn
    Left pgErr -> pure $ Left pgErr
  either throwError pure res

-- | Run an action within a transaction. The transaction is committed if the
-- | action returns cleanly, and rolled back if the action throws (either a
-- | `PGError` or a JavaScript exception in PG context). If you want to
-- | change the transaction mode, issue a separate `SET TRANSACTION` statement
-- | within the transaction.
withTransaction
    :: forall a m
     . MonadAff m
    => MonadError PGError m
    => (m a -> Aff (Either PGError a))
    -> Connection
    -> m a
    -> m a
withTransaction f conn action = do
  res <- liftAff $ P.withTransaction conn (f action)
  either throwError pure $ join res

-- | Execute a PostgreSQL query and discard its results.
execute
    :: forall i o m
     . ToSQLRow i
    => MonadError PGError m
    => MonadAff m
    => Connection
    -> Query i o
    -> i
    -> m Unit
execute conn sql values = do
  err <- liftAff $ P.execute conn sql values
  maybe (pure unit) throwError err

-- | Execute a PostgreSQL query and return its results.
query
    :: forall i o m
     . ToSQLRow i
    => FromSQLRow o
    => MonadError PGError m
    => MonadAff m
    => Connection
    -> Query i o
    -> i
    -> m (Array o)
query conn sql = hoistAffEither <<< P.query conn sql

-- | Execute a PostgreSQL query and return the first field of the first row in
-- | the result.
scalar
    :: forall i o m
     . ToSQLRow i
    => FromSQLValue o
    => MonadError PGError m
    => MonadAff m
    => Connection
    -> Query i (Row1 o)
    -> i
    -> m (Maybe o)
scalar conn sql = hoistAffEither <<< P.scalar conn sql

-- | Execute a PostgreSQL query and return its command tag value
-- | (how many rows were affected by the query). This may be useful
-- | for example with `DELETE` or `UPDATE` queries.
command
    :: forall i m
     . ToSQLRow i
    => MonadError PGError m
    => MonadAff m
    => Connection
    -> Query i Int
    -> i
    -> m Int
command conn sql = hoistAffEither <<< P.command conn sql

onIntegrityError
    :: forall a m
     . MonadError PGError m
    => m a
    -> m a
    -> m a
onIntegrityError errorResult db =
    catchError db handleError
    where
    handleError e =
        case e of
            IntegrityError _ -> errorResult
            _ -> throwError e


Traversable1 instances matching Foldable1 instances

module Data.Semigroup.Traversable where

import Prelude

import Data.Monoid.Dual (Dual(..))
import Data.Monoid.Multiplicative (Multiplicative(..))
import Data.Semigroup.Foldable (class Foldable1)
import Data.Traversable (class Traversable)

-- | `Traversable1` represents data structures with a minimum of one element that can be _traversed_,
-- | accumulating results and effects in some `Applicative` functor.
-- |
-- | - `traverse1` runs an action for every element in a data structure,
-- |   and accumulates the results.
-- | - `sequence1` runs the actions _contained_ in a data structure,
-- |   and accumulates the results.
-- |
-- | The `traverse1` and `sequence1` functions should be compatible in the
-- | following sense:
-- |
-- | - `traverse1 f xs = sequence1 (f <$> xs)`
-- | - `sequence1 = traverse1 id`
-- |
-- | `Traversable1` instances should also be compatible with the corresponding
-- | `Foldable1` instances, in the following sense:
-- |
-- | - `foldMap1 f = runConst <<< traverse1 (Const <<< f)`
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `traverse1Default`
-- | - `sequence1Default`
class (Foldable1 t, Traversable t) <= Traversable1 t where
  traverse1 :: forall a b f. Apply f => (a -> f b) -> t a -> f (t b)
  sequence1 :: forall b f. Apply f => t (f b) -> f (t b)

instance traversableDual :: Traversable1 Dual where
  traverse1 f (Dual x) = Dual <$> f x
  sequence1 = sequence1Default

instance traversableMultiplicative :: Traversable1 Multiplicative where
  traverse1 f (Multiplicative x) = Multiplicative <$> f x
  sequence1 = sequence1Default

-- | A default implementation of `traverse1` using `sequence1`.
traverse1Default
  :: forall t a b m
   . Traversable1 t
  => Apply m
  => (a -> m b)
  -> t a
  -> m (t b)
traverse1Default f ta = sequence1 (f <$> ta)

-- | A default implementation of `sequence1` using `traverse1`.
sequence1Default
  :: forall t a m
   . Traversable1 t
  => Apply m
  => t (m a)
  -> m (t a)
sequence1Default = traverse1 id

module Data.Semigroup.Traversable where

import Prelude
import Data.Traversable (class Traversable)
import Data.Semigroup.Foldable (class Foldable1)

-- | `Traversable1` represents data structures with a minimum of one element that can be _traversed_,
-- | accumulating results and effects in some `Applicative` functor.
-- |
-- | - `traverse1` runs an action for every element in a data structure,
-- |   and accumulates the results.
-- | - `sequence1` runs the actions _contained_ in a data structure,
-- |   and accumulates the results.
-- |
-- | The `traverse1` and `sequence1` functions should be compatible in the
-- | following sense:
-- |
-- | - `traverse1 f xs = sequence1 (f <$> xs)`
-- | - `sequence1 = traverse1 id`
-- |
-- | `Traversable1` instances should also be compatible with the corresponding
-- | `Foldable1` instances, in the following sense:
-- |
-- | - `foldMap1 f = runConst <<< traverse1 (Const <<< f)`
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `traverse1Default`
-- | - `sequence1Default`
class (Foldable1 t, Traversable t) <= Traversable1 t where
  traverse1 :: forall a b f. Apply f => (a -> f b) -> t a -> f (t b)
  sequence1 :: forall b f. Apply f => t (f b) -> f (t b)

-- | A default implementation of `traverse1` using `sequence1`.
traverse1Default
  :: forall t a b m
   . Traversable1 t
  => Apply m
  => (a -> m b)
  -> t a
  -> m (t b)
traverse1Default f ta = sequence1 (f <$> ta)

-- | A default implementation of `sequence1` using `traverse1`.
sequence1Default
  :: forall t a m
   . Traversable1 t
  => Apply m
  => t (m a)
  -> m (t a)
sequence1Default = traverse1 id


Add module info to completion

Add module info to completion

module IdePurescript.PscIde (getCompletion, cwd, loadDeps, getType, eitherToErr
  , getPursuitModuleCompletion, getPursuitCompletion, getAvailableModules, SearchResult, ModuleSearchResult) where

import Prelude (map, ($), pure, bind, (<$>), return)
import Data.Either (Either(Right, Left))
import Data.Maybe(Maybe(Nothing,Just))
import Data.Array((:), null, head)
import PscIde as P
import PscIde.Command as C
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception as Ex
import Control.Monad.Error.Class (throwError)
import Data.Nullable (toNullable, Nullable)
import Data.Argonaut.Decode (class DecodeJson, decodeJson)
import Data.Argonaut.Combinators ((.?))
import Data.String as S
import Data.String.Regex (replace, noFlags, regex)

eitherToErr :: forall a eff. Aff (net :: P.NET | eff) (Either String a) -> (Aff (net :: P.NET | eff) a)
eitherToErr c = do
  r <- c
  case r of
    Left s -> throwError (Ex.error s)
    Right res -> return res

result :: forall eff a b. (a -> b) ->  Aff (net :: P.NET | eff) (Either String a) -> Aff (net :: P.NET | eff) b
result f a = eitherToErr ((f <$>) <$> a)

cwd :: forall eff. Aff (net :: P.NET | eff) String
cwd = result runMsg P.cwd

runMsg :: C.Message -> String
runMsg (C.Message m) = m

getImports' :: forall eff. String
  -> Aff (net :: P.NET | eff) (Array { module :: String, qualifier :: Nullable String })
getImports' s = result conv $ P.listImports s
  where
  conv (C.ImportList imps) = conv' <$> imps
  conv' (C.Import {moduleName, qualifier}) = {
    "module": moduleName,
    qualifier: toNullable qualifier
  }

getAvailableModules :: forall eff. Aff (net :: P.NET | eff) (Array String)
getAvailableModules = result conv P.listAvailableModules
  where
  conv (C.ModuleList modules) = modules

moduleFilterModules :: String -> Array String -> (String -> Array String) -> Array String
moduleFilterModules modulePrefix unqualModules getQualifiedModule =
  if S.null modulePrefix then
    unqualModules
  else if S.contains "." modulePrefix then
    [ modulePrefix ]
  else
    let mods = getQualifiedModule modulePrefix in
    if null mods then
      [ modulePrefix ]
    else
      mods

moduleFilters :: Array String -> Array C.Filter
moduleFilters [] = []
moduleFilters modules = [ C.ModuleFilter modules ]

abbrevType :: String -> String
abbrevType = replace r "$1"
  where r = regex """(?:\w+\.)+(\w+)""" $ noFlags { global = true}

getType :: forall eff. String -> String -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) String
getType text modulePrefix unqualModules getQualifiedModule =
  result conv $ P.type' text $ moduleFilters mods
  where
    mods = moduleFilterModules modulePrefix unqualModules getQualifiedModule
    conv r = case head $ map convCompletion r of
              Just res -> abbrevType res.type
              Nothing -> ""

type CompletionResult = {type :: String, identifier :: String, module :: String}

getCompletion :: forall eff. String -> String -> Boolean -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) (Array CompletionResult)
getCompletion prefix modulePrefix moduleCompletion unqualModules getQualifiedModule =
  conv <$> (eitherToErr $ P.complete (C.PrefixFilter prefix : moduleFilters mods) Nothing)
  where
  mods = if moduleCompletion then [] else moduleFilterModules modulePrefix unqualModules getQualifiedModule
  conv = map convCompletion

convCompletion :: C.Completion -> CompletionResult
convCompletion (C.Completion { type', identifier, module' }) = { type: type', identifier, module: module' }

loadDeps :: forall eff. String
  -> Aff (net :: P.NET | eff) String
loadDeps main = result runMsg $ P.load [] [main]

type SearchResult = { module :: String, package :: String, type:: String, identifier :: String }

getPursuitCompletion :: forall eff. String -> Aff (net :: P.NET | eff) (Array SearchResult)
getPursuitCompletion str = result (map convPursuitCompletion) $ P.pursuitCompletion str

convPursuitCompletion :: C.PursuitCompletion -> SearchResult
convPursuitCompletion (C.PursuitCompletion { identifier, type', module', package })
  = { identifier, package, type: type', module: module' }

data ModuleCompletion = ModuleCompletion {
  module' :: String,
  package :: String
}

instance decodeModuleCompletion :: DecodeJson ModuleCompletion where
  decodeJson json = do
    o <- decodeJson json
    module' <- o .? "module"
    package <- o .? "package"
    pure (ModuleCompletion {
      module': module',
      package: package
      })

type ModuleSearchResult = { module :: String, package :: String }

getPursuitModuleCompletion :: forall eff. String
  -> Aff (net :: P.NET | eff) (Array ModuleSearchResult)
getPursuitModuleCompletion str = result (map convPursuitModuleCompletion) $ complete str
  where

  complete :: String -> P.Cmd (Array ModuleCompletion)
  complete q = P.sendCommand (C.Pursuit C.Package q)

  convPursuitModuleCompletion :: ModuleCompletion -> ModuleSearchResult
  convPursuitModuleCompletion (ModuleCompletion { module', package })
    = { package, module: module' }

module IdePurescript.PscIde (getCompletion, cwd, loadDeps, getType, eitherToErr
  , getPursuitModuleCompletion, getPursuitCompletion, getAvailableModules, SearchResult, ModuleSearchResult) where

import Prelude (map, ($), pure, bind, (<$>), return)
import Data.Either (Either(Right, Left))
import Data.Maybe(Maybe(Nothing,Just))
import Data.Array((:), null, head)
import PscIde as P
import PscIde.Command as C
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception as Ex
import Control.Monad.Error.Class (throwError)
import Data.Nullable (toNullable, Nullable)
import Data.Argonaut.Decode (class DecodeJson, decodeJson)
import Data.Argonaut.Combinators ((.?))
import Data.String as S
import Data.String.Regex (replace, noFlags, regex)

eitherToErr :: forall a eff. Aff (net :: P.NET | eff) (Either String a) -> (Aff (net :: P.NET | eff) a)
eitherToErr c = do
  r <- c
  case r of
    Left s -> throwError (Ex.error s)
    Right res -> return res

result :: forall eff a b. (a -> b) ->  Aff (net :: P.NET | eff) (Either String a) -> Aff (net :: P.NET | eff) b
result f a = eitherToErr ((f <$>) <$> a)

cwd :: forall eff. Aff (net :: P.NET | eff) String
cwd = result runMsg P.cwd

runMsg :: C.Message -> String
runMsg (C.Message m) = m

getImports' :: forall eff. String
  -> Aff (net :: P.NET | eff) (Array { module :: String, qualifier :: Nullable String })
getImports' s = result conv $ P.listImports s
  where
  conv (C.ImportList imps) = conv' <$> imps
  conv' (C.Import {moduleName, qualifier}) = {
    "module": moduleName,
    qualifier: toNullable qualifier
  }

getAvailableModules :: forall eff. Aff (net :: P.NET | eff) (Array String)
getAvailableModules = result conv P.listAvailableModules
  where
  conv (C.ModuleList modules) = modules

moduleFilterModules :: String -> Array String -> (String -> Array String) -> Array String
moduleFilterModules modulePrefix unqualModules getQualifiedModule =
  if S.null modulePrefix then
    unqualModules
  else if S.contains "." modulePrefix then
    [ modulePrefix ]
  else
    let mods = getQualifiedModule modulePrefix in
    if null mods then
      [ modulePrefix ]
    else
      mods

moduleFilters :: Array String -> Array C.Filter
moduleFilters [] = []
moduleFilters modules = [ C.ModuleFilter modules ]

abbrevType :: String -> String
abbrevType = replace r "$1"
  where r = regex """(?:\w+\.)+(\w+)""" $ noFlags { global = true}

getType :: forall eff. String -> String -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) String
getType text modulePrefix unqualModules getQualifiedModule =
  result conv $ P.type' text $ moduleFilters mods
  where
    mods = moduleFilterModules modulePrefix unqualModules getQualifiedModule
    conv r = case head $ map convCompletion r of
              Just res -> abbrevType res.type
              Nothing -> ""

type CompletionResult = {type :: String, identifier :: String}

getCompletion :: forall eff. String -> String -> Boolean -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) (Array CompletionResult)
getCompletion prefix modulePrefix moduleCompletion unqualModules getQualifiedModule =
  conv <$> (eitherToErr $ P.complete (C.PrefixFilter prefix : moduleFilters mods) Nothing)
  where
  mods = if moduleCompletion then [] else moduleFilterModules modulePrefix unqualModules getQualifiedModule
  conv = map convCompletion

convCompletion :: C.Completion -> CompletionResult
convCompletion (C.Completion { type', identifier }) = { type: type', identifier }

loadDeps :: forall eff. String
  -> Aff (net :: P.NET | eff) String
loadDeps main = result runMsg $ P.load [] [main]

type SearchResult = { module :: String, package :: String, type:: String, identifier :: String }

getPursuitCompletion :: forall eff. String -> Aff (net :: P.NET | eff) (Array SearchResult)
getPursuitCompletion str = result (map convPursuitCompletion) $ P.pursuitCompletion str

convPursuitCompletion :: C.PursuitCompletion -> SearchResult
convPursuitCompletion (C.PursuitCompletion { identifier, type', module', package })
  = { identifier, package, type: type', module: module' }

data ModuleCompletion = ModuleCompletion {
  module' :: String,
  package :: String
}

instance decodeModuleCompletion :: DecodeJson ModuleCompletion where
  decodeJson json = do
    o <- decodeJson json
    module' <- o .? "module"
    package <- o .? "package"
    pure (ModuleCompletion {
      module': module',
      package: package
      })

type ModuleSearchResult = { module :: String, package :: String }

getPursuitModuleCompletion :: forall eff. String
  -> Aff (net :: P.NET | eff) (Array ModuleSearchResult)
getPursuitModuleCompletion str = result (map convPursuitModuleCompletion) $ complete str
  where

  complete :: String -> P.Cmd (Array ModuleCompletion)
  complete q = P.sendCommand (C.Pursuit C.Package q)

  convPursuitModuleCompletion :: ModuleCompletion -> ModuleSearchResult
  convPursuitModuleCompletion (ModuleCompletion { module', package })
    = { package, module: module' }


Fixed compile error.

Fixed compile error.

module Graphics.WebGL.Context where

import Prelude
import Control.Monad.Eff
import Graphics.Canvas (Canvas(), CanvasElement())
import Graphics.WebGL.Raw.Types

foreign import getWebGLContextWithAttrs :: forall eff. CanvasElement -> WebGLContextAttributes -> Eff (canvas :: Canvas | eff) WebGLContext

defaultWebGLContextAttrs :: WebGLContextAttributes
defaultWebGLContextAttrs = {
	alpha: true,
	depth: true,
	stencil: false,
	antialias: true,
	premultipliedAlpha: true,
	preserveDrawingBuffer: false,
	preferLowPowerToHighPerformance: false,
	failIfMajorPerformanceCaveat: false
	}

getWebGLContext :: forall eff. CanvasElement -> Eff (canvas :: Canvas | eff) WebGLContext
getWebGLContext el = getWebGLContextWithAttrs el defaultWebGLContextAttrs

module Graphics.WebGL.Context where

import Prelude
import Control.Monad.Eff
import Graphics.Canvas (Canvas(), CanvasElement())
import Graphics.WebGL.Raw.Types

foreign import getWebGLContextWithAttrs :: CanvasElement -> WebGLContextAttributes -> Eff (canvas :: Canvas | eff) WebGLContext

defaultWebGLContextAttrs :: WebGLContextAttributes
defaultWebGLContextAttrs = {
	alpha: true,
	depth: true,
	stencil: false,
	antialias: true,
	premultipliedAlpha: true,
	preserveDrawingBuffer: false,
	preferLowPowerToHighPerformance: false,
	failIfMajorPerformanceCaveat: false
	}

getWebGLContext :: CanvasElement -> Eff (canvas :: Canvas | eff) WebGLContext
getWebGLContext el = getWebGLContextWithAttrs el defaultWebGLContextAttrs


Multiply movement rate by time to get distance.

-- | Pure functions and types representing the (pretty simple) state of the simulation
module Jundo.Simulation (
  RotationDirection(..),
  SimulationState(..),
  CameraState(..),
  CubeState(..),
  KeyboardState(..),
  MouseMove(..),
  initialSimulationState,
  applyMouseMove,
  timestep,
  toggleDirection
  ) where

import Prelude
import Jundo.Vectors
import Data.Time (Milliseconds(..), Seconds(..), toSeconds)
import Data.Vector
import Data.Vector3
import Math

type RadiansPerSecond = Number
type MetersPerSecond = Number

data RotationDirection = Clockwise | Anticlockwise

instance showRotationDirection :: Show RotationDirection where
  show Clockwise = "Clockwise"
  show Anticlockwise = "Anticlockwise"

newtype CubeState = CubeState {direction :: RotationDirection, angle :: Radians, position :: Vec3 Number}

instance showCubeState :: Show CubeState where
  show (CubeState s) = "CubeState {direction: " ++ show s.direction ++ ", angle: " ++ show s.angle ++ ", position: " ++ show s.position ++ "}"

newtype CameraState = CameraState {yaw :: Radians, pitch :: Radians, position :: Vec3 Number}

instance showCameraState :: Show CameraState where
  show (CameraState s) = " CameraState {yaw: " ++ show s.yaw ++ ", pitch: " ++ show s.pitch ++ ", position: " ++ show s.position ++ "}"

newtype SimulationState = SimulationState {cube :: CubeState, camera :: CameraState}

instance showSimulationState :: Show SimulationState where
  show (SimulationState s) = "SimulationState {camera: " ++ show s.camera ++ ", cube: " ++ show s.cube ++ "}"

mapCameraState :: (CameraState -> CameraState) -> SimulationState -> SimulationState
mapCameraState f (SimulationState s) = SimulationState {cube: s.cube, camera: f s.camera}

mapCubeState :: (CubeState -> CubeState) -> SimulationState -> SimulationState
mapCubeState f (SimulationState s) = SimulationState {cube: f s.cube, camera: s.camera}

initialSimulationState :: SimulationState
initialSimulationState = SimulationState {
  cube: CubeState {direction: Anticlockwise, angle: 0.0, position: vec3 0.0 0.0 (-6.0)},
  camera: CameraState {pitch: 0.0, yaw: 0.0, position: vec3 0.0 0.0 0.0}
  }

-- | Type for tracking which keys are currently depressed
newtype KeyboardState = KeyboardState {w :: Boolean, a :: Boolean, s :: Boolean, d :: Boolean}

instance showKeyboardState :: Show KeyboardState where
  show (KeyboardState s) = "KeyboardState {w: " ++ show s.w ++ ", a: " ++ show s.a ++ ", s: " ++ show s.s ++ ", d: " ++ show s.d ++ "}"

-- | Rotation speed of the cube
angularSpeed :: RadiansPerSecond
angularSpeed = 1.0

-- | Angle change is velocity multiplied by time
angleFromVelocity :: RadiansPerSecond -> Seconds -> Radians
angleFromVelocity v (Seconds t) = v * t

-- | Camera movement rate
movementRate :: MetersPerSecond
movementRate = 0.1

-- | Convert the keyboard state into a unit vector in the direction of movement if the camera was pointing in the -z direction
cameraUnitVelocity :: KeyboardState -> Vec3 Number
cameraUnitVelocity (KeyboardState {w: true, a: false, d: false, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: false, d: false, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: false}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: false}) = i3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: false}) = vec3 (-sqrt1_2) 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: false}) = vec3 sqrt1_2 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: true}) = vec3 (-sqrt1_2) 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: true}) = vec3 sqrt1_2 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: true, a: true, d: true, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: true, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: true}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: true}) = i3
cameraUnitVelocity _ = vec3 0.0 0.0 0.0

-- | Update the simulation state to reflect a change in simulation time, applying camera and cube movement
timestep :: Milliseconds -> KeyboardState -> SimulationState -> SimulationState
timestep step ks simulationState = mapCubeState updateCube $ mapCameraState updateCamera simulationState
  where
  stepSeconds :: Seconds
  stepSeconds = toSeconds step
  updateCube :: CubeState -> CubeState
  updateCube (CubeState cs) = CubeState {direction: cs.direction, position: cs.position, angle: cs.angle + angleChange cs.direction}
    where
    angleChange direction = directionMultiplier * angleFromVelocity angularSpeed stepSeconds
    directionMultiplier = case cs.direction of
      Anticlockwise -> 1.0
      Clockwise -> -1.0
  updateCamera :: CameraState -> CameraState
  updateCamera (CameraState cs) = CameraState {pitch: cs.pitch, yaw: cs.yaw, position: vAdd cs.position positionChange}
    where
    positionChange = scale (movementRate * stepSeconds) $ rotateVec3 j3 cs.yaw (cameraUnitVelocity ks)

-- | Make the cube spin the other way! Excitement.
toggleDirection :: SimulationState -> SimulationState
toggleDirection = mapCubeState (\(CubeState s) -> CubeState {direction: newDirection s.direction, angle: s.angle, position: s.position})
  where
  newDirection d = case d of
    Clockwise -> Anticlockwise
    Anticlockwise -> Clockwise

-- | Type representing a change in mouse position (x y)
data MouseMove = MouseMove Number Number

instance showMouseMove :: Show MouseMove where
  show (MouseMove dx dy) = "MouseMove (" ++ show dx ++ ", " ++ show dy ++ ")"

-- | Radians of pitch change per unit mouse movement
pitchSensitivity :: Radians
pitchSensitivity = 0.01

-- | Radians of yaw change per unit mouse movement
yawSensitivity :: Radians
yawSensitivity = 0.01

-- | Apply a change in mouse position to the simulation state
applyMouseMove :: MouseMove -> SimulationState -> SimulationState
applyMouseMove (MouseMove dx dy) = mapCameraState \(CameraState cs) -> CameraState {
  pitch: ensurePitch $ cs.pitch + dy * pitchSensitivity,
  yaw: cs.yaw + dx * yawSensitivity,
  position: cs.position
  }
  where
  -- Pitch must be between -0.5 pi and 0.5 pi
  ensurePitch :: Radians -> Radians
  ensurePitch p | p < -0.5 * pi = -0.5 * pi
  ensurePitch p | p > 0.5 * pi = 0.5 * pi
  ensurePitch p = p

-- | Pure functions and types representing the (pretty simple) state of the simulation
module Jundo.Simulation (
  RotationDirection(..),
  SimulationState(..),
  CameraState(..),
  CubeState(..),
  KeyboardState(..),
  MouseMove(..),
  initialSimulationState,
  applyMouseMove,
  timestep,
  toggleDirection
  ) where

import Prelude
import Jundo.Vectors
import Data.Time (Milliseconds(..), Seconds(..), toSeconds)
import Data.Vector
import Data.Vector3
import Math

type RadiansPerSecond = Number
type MetersPerSecond = Number

data RotationDirection = Clockwise | Anticlockwise

instance showRotationDirection :: Show RotationDirection where
  show Clockwise = "Clockwise"
  show Anticlockwise = "Anticlockwise"

newtype CubeState = CubeState {direction :: RotationDirection, angle :: Radians, position :: Vec3 Number}

instance showCubeState :: Show CubeState where
  show (CubeState s) = "CubeState {direction: " ++ show s.direction ++ ", angle: " ++ show s.angle ++ ", position: " ++ show s.position ++ "}"

newtype CameraState = CameraState {yaw :: Radians, pitch :: Radians, position :: Vec3 Number}

instance showCameraState :: Show CameraState where
  show (CameraState s) = " CameraState {yaw: " ++ show s.yaw ++ ", pitch: " ++ show s.pitch ++ ", position: " ++ show s.position ++ "}"

newtype SimulationState = SimulationState {cube :: CubeState, camera :: CameraState}

instance showSimulationState :: Show SimulationState where
  show (SimulationState s) = "SimulationState {camera: " ++ show s.camera ++ ", cube: " ++ show s.cube ++ "}"

mapCameraState :: (CameraState -> CameraState) -> SimulationState -> SimulationState
mapCameraState f (SimulationState s) = SimulationState {cube: s.cube, camera: f s.camera}

mapCubeState :: (CubeState -> CubeState) -> SimulationState -> SimulationState
mapCubeState f (SimulationState s) = SimulationState {cube: f s.cube, camera: s.camera}

initialSimulationState :: SimulationState
initialSimulationState = SimulationState {
  cube: CubeState {direction: Anticlockwise, angle: 0.0, position: vec3 0.0 0.0 (-6.0)},
  camera: CameraState {pitch: 0.0, yaw: 0.0, position: vec3 0.0 0.0 0.0}
  }

-- | Type for tracking which keys are currently depressed
newtype KeyboardState = KeyboardState {w :: Boolean, a :: Boolean, s :: Boolean, d :: Boolean}

instance showKeyboardState :: Show KeyboardState where
  show (KeyboardState s) = "KeyboardState {w: " ++ show s.w ++ ", a: " ++ show s.a ++ ", s: " ++ show s.s ++ ", d: " ++ show s.d ++ "}"

-- | Rotation speed of the cube
angularSpeed :: RadiansPerSecond
angularSpeed = 1.0

-- | Angle change is velocity multiplied by time
angleFromVelocity :: RadiansPerSecond -> Seconds -> Radians
angleFromVelocity v (Seconds t) = v * t

-- | Camera movement rate
movementRate :: MetersPerSecond
movementRate = 0.1

-- | Convert the keyboard state into a unit vector in the direction of movement if the camera was pointing in the -z direction
cameraUnitVelocity :: KeyboardState -> Vec3 Number
cameraUnitVelocity (KeyboardState {w: true, a: false, d: false, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: false, d: false, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: false}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: false}) = i3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: false}) = vec3 (-sqrt1_2) 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: false}) = vec3 sqrt1_2 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: true}) = vec3 (-sqrt1_2) 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: true}) = vec3 sqrt1_2 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: true, a: true, d: true, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: true, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: true}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: true}) = i3
cameraUnitVelocity _ = vec3 0.0 0.0 0.0

-- | Update the simulation state to reflect a change in simulation time, applying camera and cube movement
timestep :: Milliseconds -> KeyboardState -> SimulationState -> SimulationState
timestep step ks simulationState = mapCubeState updateCube $ mapCameraState updateCamera simulationState
  where
  stepSeconds :: Seconds
  stepSeconds = toSeconds step
  updateCube :: CubeState -> CubeState
  updateCube (CubeState cs) = CubeState {direction: cs.direction, position: cs.position, angle: cs.angle + angleChange cs.direction}
    where
    angleChange direction = directionMultiplier * angleFromVelocity angularSpeed stepSeconds
    directionMultiplier = case cs.direction of
      Anticlockwise -> 1.0
      Clockwise -> -1.0
  updateCamera :: CameraState -> CameraState
  updateCamera (CameraState cs) = CameraState {pitch: cs.pitch, yaw: cs.yaw, position: vAdd cs.position positionChange}
    where
    positionChange = scale movementRate $ rotateVec3 j3 cs.yaw (cameraUnitVelocity ks)

-- | Make the cube spin the other way! Excitement.
toggleDirection :: SimulationState -> SimulationState
toggleDirection = mapCubeState (\(CubeState s) -> CubeState {direction: newDirection s.direction, angle: s.angle, position: s.position})
  where
  newDirection d = case d of
    Clockwise -> Anticlockwise
    Anticlockwise -> Clockwise

-- | Type representing a change in mouse position (x y)
data MouseMove = MouseMove Number Number

instance showMouseMove :: Show MouseMove where
  show (MouseMove dx dy) = "MouseMove (" ++ show dx ++ ", " ++ show dy ++ ")"

-- | Radians of pitch change per unit mouse movement
pitchSensitivity :: Radians
pitchSensitivity = 0.01

-- | Radians of yaw change per unit mouse movement
yawSensitivity :: Radians
yawSensitivity = 0.01

-- | Apply a change in mouse position to the simulation state
applyMouseMove :: MouseMove -> SimulationState -> SimulationState
applyMouseMove (MouseMove dx dy) = mapCameraState \(CameraState cs) -> CameraState {
  pitch: ensurePitch $ cs.pitch + dy * pitchSensitivity,
  yaw: cs.yaw + dx * yawSensitivity,
  position: cs.position
  }
  where
  -- Pitch must be between -0.5 pi and 0.5 pi
  ensurePitch :: Radians -> Radians
  ensurePitch p | p < -0.5 * pi = -0.5 * pi
  ensurePitch p | p > 0.5 * pi = 0.5 * pi
  ensurePitch p = p