libs-classes-syntax-tips.txt

                            spago install prelude
(class Applicative, class Apply, class Bind, class BooleanAlgebra, class Bounded, class Category, class CommutativeRing, class Discard, class DivisionRing, class Eq, class EuclideanRing, class Field, class Functor, class HeytingAlgebra, class Monad, class Monoid, class Ord, class Ring, class Semigroup, class Semigroupoid, class Semiring, class Show, type (~>), Ordering(..), Unit, Void, absurd, add, ap, append, apply, between, bind, bottom, clamp, compare, comparing, compose, conj, const, degree, discard, disj, div, eq, flap, flip, gcd, identity, ifM, join, lcm, liftA1, liftM1, map, max, mempty, min, mod, mul, negate, not, notEq, one, otherwise, pure, recip, show, sub, top, unit, unless, unlessM, void, when, whenM, zero, (#), ($), ($>), (&&), (*), (*>), (+), (-), (/), (/=), (<), (<#>), (<$), (<$>), (<*), (<*>), (<<<), (<=), (<=<), (<>), (<@>), (=<<), (==), (>), (>=), (>=>), (>>=), (>>>), (||))

Data.Functor             
Control.Applicative
Control.Apply
Control.Monad
Data.Eq
Data.Ordering

Data.Symbol
Prim
Prim.Row
Prim.RowList
(...)

fix :: forall a b. ((a -> b) -> (a -> b)) -> a -> b
fix f = go
  where
    defer h = \x -> h unit x
    go = defer \_ -> f go

myFunction :: Int -> Int
myFunction = fix (\f a -> if a > 100 then 100 else f (a + 1))


Control.Monad.Aff         spago install aff
Affjax                    spago install affjax
Affjax.Web                spago install affjax-web
Data.Argonaut             spago install argonaut
Data.Array                spago install arrays
FRP.Behavior              spago install behaviors
Data.BigInt               spago install bigints
Graphics.Canvas           spago install canvas
Control.MonadZero         spago install control
Control.Alt
Control.Plus
Debug.Trace               spago install debug
Graphics.Drawing          spago install drawing
Data.Either               spago install either
Data.Enum                 spago install enums
Data.Exists               spago install exists
Fetch                     spago install fetch
Data.Compactable          spago install filterable
Data.Traversable          spago install foldable-traversable
Data.Foldable
Data.Foreign              spago install foreign
Control.Comonad.Cofree    spago install free
Data.Function.Uncurried   spago install functions
Data.Functor.Compose      spago install functors
Data.Int                  spago install integers
Effect.Timer              spago install js-timers
Random.LCG                spago install lcg
Data.Lazy                 spago install lazy
Data.List                 spago install lists
Math                      spago install math
Data.Maybe                spago install maybe
Data.Monoid               spago install monoid
Data.Newtype              spago install newtype
Data.Number               spago install numbers
Data.Map                  spago install ordered-collections
Parsing                   spago install parsing
Parsing.Combinators       
Parsing.String
Parsing.String.Basic
Partial.Unsafe            spago install partial
Test.QuickCheck           spago install quickcheck
Test.QuickCheck.Gen
Effect.Random             spago install random
Data.Ratio                spago install rationals
Record                    spago install record
Run                       spago install run
Data.Set                  spago install sets
Control.Monad.ST          spago install st
Data.String               spago install strings
Data.Char
Thermite                  spago install thermite
Control.Monad.State       spago install transformers
Control.Monad.Writer
Data.Tuple                spago install tuples
Type.Prelude              spago install typelevel-prelude
Turbine                   spago install turbine
Unsafe.Coerce             spago install unsafe-coerce
Unsafe.Reference          spago install unsafe-reference
Data.Validation.Semigroup spago install validation
Web.HTML                  spago install web-html
Audio.WebAudio.Oscillator spago install webaudio

import Affjax.Web (request)
import Control.Alt (alt, (<|>))
import Control.Monad.ST (newSTRef)
import Control.Monad.Writer (Writer, runWriter, tell)
import Control.MonadZero (guard)
import Data.Array (foldM, catMaybes, sort, elem, index, elemIndex)
import Data.Array.Partial (head)
import Data.Char (toCharCode)
import Data.Compactable (compact)
import Data.Date (Date, canonicalDate, diff)
import Data.Either (note, hush)
import Data.Enum (toEnum, succ, fromEnum)
import Data.Exists (Exists, mkExists, runExists)
import Data.Foldable (sum, product, foldM, maximum)
import Data.Function.Uncurried (Fn's, mkFn's, runFn's, on)
import Data.Functor.Compose (Compose)
import Data.Int (floor, fromStringAs, toStringAs, binary, octal, hexadecimal, decimal, base36, radix, toNumber, round)
import Data.Lazy (Lazy, force, defer)
import Data.List (fromFoldable, filterM, toUnfoldable)
import Data.Maybe (fromJust, maybe, fromMaybe)
import Data.Newtype (unwrap)
import Data.Number (fromString, pow)
import Data.Ord (min, max, abs)
import Data.String (toCodePointArray, singleton, fromCodePointArray, codePointFromChar, stripPrefix, Pattern)
import Data.String.CodeUnits (toCharArray, singleton)
import Data.Symbol (class IsSymbol, reflectSymbol)
import Data.Time.Duration (Days(..))
import Data.Tuple (uncurry)
import Effect.Random (random)
import Effect.Timer (clearInterval, setInteval)
import Fetch (fetch)
import Data.Tuple.Nested ((/\), type (/\))
import Data.Unfoldable (iterateN)
import Parsing (ParseError, Parser, runParser)
import Parsing.Combinators (try)
import Parsing.String (char)
import Parsing.String.Basic (number, skipSpaces)
import Partial.Unsafe (unsafePartial)
import Prim (Record)
import Prim.Row (class Cons, class Lacks)
import Random.LCG (lcgNext, mkSeed, unSeed)
import Unsafe.Coerce (unsafeCoerce)
import Unsafe.Reference (unsafeReferenceEq)

undefined :: ∀ a. a
undefined = unsafeCoerce unit

note :: forall a b. a -> Maybe b -> Either a b
hush :: forall a b. Either a b -> Maybe b

applyFlipped :: forall a b. a -> (a -> b) -> b
applyFlipped x f = f x

infixr 0 Function.apply as $
infixl 1 Function.applyFlipped as #
infixl 1 mapFlipped as <#>
infixl 4 map as <$>
infixl 4 flap as <@>
infixl 4 Control.apply as <*>

class Eq a where
  eq :: a -> a -> Boolean
  
data Ordering = LT | EQ | GT

class Eq a <= Ord a where
  compare :: a -> a -> Ordering

class Semigroupoid a where
  compose :: forall b c d. a c d -> a b c -> a b d

class (Semigroupoid a) <= Category a where
  identity :: forall t. a t t

class Semigroup a where
  append :: a -> a -> a
  
class (Semigroup m) <= Monoid m where
  mempty :: m

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

class Functor f where
  map :: forall a b. (a -> b) -> f a -> f b

infixl 4 map as <$>

instance covariantArrow :: Covariant (forall a. a -> x) where
  fmap :: (x -> y) -> (a -> x) -> (a -> y) -- result is still a function a -> ...
  fmap = (<<<)

instance contravariantArrow :: Contravariant (forall b. x -> b) where
  cmap :: (x -> b) (b -> y) -> (x -> y) -- result is still a function ... -> b
  cmap = flip (<<<)
  
It appears that a functor (resp. cofunctor) instance can only be defined 
for functions where variables x all are in positive (resp. negative) positions:

p
n -> p
n -> (n -> p)
(p -> n) -> p
n -> (n -> (n -> p))
n -> ((p -> n) -> p)
((n -> p) -> n) -> p 
(p -> (p -> n)) -> p 
(p -> n) -> (n -> p)

for example,
instance covariantArrow2 :: Covariant (forall n. (x -> n) -> x) where
  fmap :: (x -> y) -> ((x -> n) -> x) -> (x -> n) -> y

class (Functor f) <= Apply f where
  apply :: forall a b. f (a -> b) -> f a -> f b 

infixl 4 apply as <*>

applySecond :: forall a b f. Apply f => f a -> f b -> f b

infixl 4 applySecond as *>

class (Apply f) <= Applicative f where
  pure :: forall a. a -> f a

class (Functor t, Foldable t) <= Traversable t where
  traverse :: forall a b f. Applicative f => (a -> f b) -> t a -> f (t b)
  sequence :: forall a f. Applicative f => t (f a) -> f (t a)

-- sequence = traverse identity
-- traverse f = sequence <<< (map f)
-- traverse_ :: forall a b t f. Applicative f => Foldable t => (a -> f b) -> t a -> f Unit

class (Functor f) <= Distributive f where
  distribute :: forall a g. Functor g => g (f a) -> f (g a)
  collect :: forall a b g. Functor g => (a -> f b) -> g a -> f (g b)

cotraverse :: forall a b f g. Distributive f => Functor g => (g a -> b) -> g (f a) -> f b

class (Apply m) <= Bind m where
  bind :: forall a b. m a -> (a -> m b) -> m b

class (Applicative m, Bind m) <= Monad m

class Compactable f where
  compact :: forall a.
    f (Maybe a) -> f a

  separate :: forall l r.
    f (Either l r) -> { left :: f l, right :: f r }

data Tuple a b = Tuple a b

class (Monad m) <= MonadState s m | m -> s where
  state :: forall a. (s -> (Tuple a s)) -> m a

class (Functor env) <= Extend env where -- that is : map f = extend (f <<< duplicate)
  duplicate : forall a. env a -> env (env a) 
  -- that is : duplicate = extend identity
  extend :: forall a b. (env a -> b) -> env a -> env b
  -- that is : extend f = map f <<< duplicate

infixr 1 extend as <<=

composeCoKleisli :: forall b a w c. Extend w => (w a -> b) -> (w b -> c) -> w a -> c
composeCoKleisli f g w = g (f <<= w) -- f =>= extract = f
                                     -- extract =>= f = f
                                     -- f =>= (g =>= h) = (f =>= g) =>= h

infixr 1 composeCoKleisli as =>=

class (Extend env) <= Comonad env where
  extract :: forall a. env a -> a
  
class (Comonad (env e)) <= Environment env e a where
  ask :: env e a -> e
  asks :: forall e'. (e -> e') -> env e a -> e'
  local :: forall e'. (e -> e') -> env e a -> env e' a

class Comonad w <= ComonadAsk e w | w -> e where
  ask :: forall a. w a -> e

-- | Get a value which depends on the environment.
asks :: forall e1 e2 w a. ComonadAsk e1 w => (e1 -> e2) -> w a -> e2
asks f x = f (ask x)

-- | The `ComonadEnv` type class extends `ComonadAsk` with a function
-- | `local f x` that allows the value of the local context to be modified for
-- | the duration of the execution of action `x`.
-- |
-- | An implementation is provided for `EnvT`.
-- |
-- | Laws:
-- |
-- | - `ask (local f x) = f (ask x)`
-- | - `extract (local _ x) = extract a`
-- | - `extend g (local f x) = extend (g <<< local f) x`
class ComonadAsk e w <= ComonadEnv e w | w -> e where
  local :: forall a. (e -> e) -> w a -> w a

class (Functor f) <= Alt f where -- Semigroup for Type -> Type
  alt :: forall a. f a -> f a -> f a

infixl 3 alt as <|> -- Associativity, Distributivity of <$> over <|>

voidRight :: forall f a b. Functor f => a -> f b -> f a
voidRight x = map (const x)

infixl 4 voidRight as <$

class (Alt f) <= Plus f where -- Monoid for Type -> Type
  empty :: forall a. f a

    Left identity: empty <|> x == x
    Right identity: x <|> empty == x
    Annihilation: f <$> empty == empty

class (Applicative f, Plus f) <= Alternative f
class (Monad m, Alternative m) <= MonadZero m 
class (MonadZero m) <= MonadPlus m -- Distributivity: (x <|> y) >>= f == (x >>= f) <|> (y >>= f)

data Free f a = Pure a | Roll (f (Free f a))

instance freeFunctor :: Functor f => Functor (Free f) where
  map f (Pure a) = Pure (f a)
  map f (Roll x) = Roll (map (map f) x)

concatFree :: forall f a. Functor f => Free f (Free f a) -> Free f a
concatFree (Pure x) = x
concatFree (Roll y) = Roll (map concatFree y)

bindFree :: forall a b f. Functor f => Free f a -> (a -> Free f b) -> Free f b
bindFree x f = concatFree (map f x)

instance freeApply :: Functor f => Apply (Free f) where
  apply ff fx =  bindFree fx (\x -> bindFree ff (\f -> Pure $ f x)) 
   
instance freeApplicative :: Functor f => Applicative (Free f) where
  pure = Pure

instance freeBind :: Functor f => Bind (Free f) where
  bind x f = bindFree x f 

liftFree :: forall a f. Functor f => f a -> Free f a
liftFree x = Roll (map Pure x)

foldFree :: forall f r. Functor f => (f r -> r) -> Free f r -> r
foldFree _ (Pure a) = a
foldFree f (Roll x) = f (map (foldFree f) x)

class Bifunctor f where
  bimap :: (a -> b) -> (c -> d) -> f a c -> f b d
  
class (Bifunctor w) <= Biapply w where
  biapply :: w (a -> b) (c -> d) -> w a c -> w b d -- <<*>>
  
class (Biapply w) <= Biapplicative w where
  bipure :: a -> b -> w a b
  
instance biapplyTuple :: Biapply Tuple where
  biapply (Tuple f g) (Tuple a b) = Tuple (f a) (g b)

class Profunctor p where
  dimap :: forall s t a b. (s -> a) -> (b -> t) -> p a b -> p s t
  
class (Profunctor p) <= Strong p where
  first :: forall a b c. p a b -> p (a /\ c) (b /\ c)
  second :: forall a b c. p b c -> p (a /\ b) (a /\ c)

class (Profunctor p) <= Choice p where
  left :: forall a b c. p a b -> p (Either a c) (Either b c)
  right :: forall a b c. p b c -> p (Either a b) (Either a c)

type Optic p s t a b = p a b -> p s t
type Iso s t a b = forall p. Profunctor p => Optic p s t a b
type Lens s t a b = forall p. Strong p => Optic p s t a b
type Prism s t a b = forall p. Choice p => Optic p s t a b

instance Profunctor (->) where
  dimap a c b = a >>> b >>> c
  
instance Strong (->) where
  first f (a /\ c) = f a /\ c
  second = map
  
instance Choice (->) where
  left f (Left a) = Left $ f a
  left _ (Right c) = Right c
  right = map

type Setter s t a b = Optic Function s t a b

over :: forall s t a b. Setter s t a b -> (a -> b) -> s -> t
over = identity

newtype Forget r a b = Forget (a -> r)

instance Profunctor (Forget r) where
  dimap f _ (Forget z) = Forget (z <<< f)
  
instance Strong (Forget r) where
  first (Forget z) = Forget (z <<< fst)
  second (Forget z) = Forget (z <<< snd)
  
instance Monoid r => Choice (Forget r) where
  left (Forget z) = Forget (either z mempty)
  right (Forget z) = Forget (either mempty z)

type Fold r s t a b = Optic (Forget r) s t a b
type Getter s t a b = forall r. Fold r s t a b

view :: forall s t a b. Getter s t a b -> s -> a
view = unwrap <<< (#) (Forget identity)

iso :: forall s t a b. (s -> a) -> (b -> t) -> Iso s t a b
iso = dimap

lens :: forall s t a b. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens get set = lens' \s -> get s /\ set s where
  lens' to pab = dimap to (\(b /\ f) -> f b) (first pab)
  
prism :: forall s t a b. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism to fro pab = dimap fro (either identity identity) (right (rmap to pab)) where
  rmap = dimap identity

newtype Cofree f a = Cofree (Lazy (Tuple a (f (Cofree f a))))

mkCofree :: forall f a. a -> f (Cofree f a) -> Cofree f a
mkCofree a t = Cofree (defer \_ -> Tuple a t)

infixr 5 mkCofree as :<

head :: forall f a. Cofree f a -> a
head (Cofree c) = fst (force c)

tail :: forall f a. Cofree f a -> f (Cofree f a)
tail (Cofree c) = snd (force c)

instance Functor f => Functor (Cofree f) where
  map f = loop
    where
    loop (Cofree fa) = Cofree ((\(Tuple a b) -> Tuple (f a) (loop <$> b)) <$> fa)

instance Functor f => Extend (Cofree f) where
  extend f = loop
    where
    loop (Cofree fa) = Cofree ((\(Tuple _ b) -> Tuple (f (Cofree fa)) (loop <$> b)) <$> fa)

instance Functor f => Comonad (Cofree f) where
  extract = head

class Semiring a where
  add :: a -> a -> a
  zero :: a
  mul :: a -> a -> a
  one :: a

data Number :: Type

instance semiringNumber :: Semiring Number where
  add = (+)
  zero = 0
  mul = (*)
  one = 1

-- Haskell's Num:
class (Semiring a) <= Ring a where
  sub :: a -> a -> a

class (Ring a) <= CommutativeRing a

class (Ring a) <= DivisionRing a where
  recip :: a -> a -> a

-- Haskell's Integral:
class (CommutativeRing a) <= EuclideanRing a where
  degree :: a -> Int
  div :: a -> a -> a
  mod :: a -> a -> a

--Haskell's Fractional:
class (EuclideanRing a, DivisionRing a) <= Field a

type NaturalTransformation f g = forall a. f a -> g a
infixr 4 type NaturalTransformation as ~>

-- unicode CodePoint
"\x2713" :: String -- checkmark

> import Data.Int
> toStringAs hexadecimal 175
"af"

data NonEmpty a = NonEmpty a (Array a)

instance eqNonEmpty :: (Eq a, Eq (Array a)) => Eq (NonEmpty a) where
  eq (NonEmpty x xs) (NonEmpty y ys) = x == y && xs == ys

> import Data.Array(head) as Array
> Array.head xs
(Just 1)

> import Data.Array.Partial(head) as Partial
> unsafePartial Partial.head xs
1

nonEmpty :: String -> Either String Unit
nonEmpty "" = Left "Field cannot be empty"
nonEmpty _  = Right unit

newtype Person = Person
  { firstName   :: String
  , lastName    :: String
  }

person :: String -> String -> Person
person firstName lastName =
  Person { firstName, lastName}

validatePerson :: Person -> Either String Person
validatePerson (Person o) =
  person <$> (nonEmpty o.firstName *> pure o.firstName)
         <*> (nonEmpty o.lastName  *> pure o.lastName)

sort $ nub $ map sum $ foldM (\xs x -> [x:xs,xs]) [] ([1,2,5,10])
 
> import Data.List(filterM,fromFoldable,toUnfoldable)
> subsets = filterM (const [true, false])
> (map toUnfoldable $ subsets $ fromFoldable [4,2,6,3]) :: Array (Array Int)

import Data.Foldable (traverse_)
import Control.Monad.State
import Control.Monad.State.Class
sumArray = traverse_ \n -> modify \sum -> sum + n
runState (do
  sumArray [1, 2, 3]
  sumArray [4, 5]
  sumArray [6]) 0

vowelsRegex :: Regex
vowelsRegex =
  unsafePartial
    case regex "[aeiou]" (RegexFlags regexFlags) of
      Right r -> r

> :paste
… merch3 = ado
…   x <- "teeshirt" : "sweater" : Nil
…   y <- "large" : "medium" : "small" : Nil
…   z <- "black" : "white" : Nil 
…   in (x <> "-" <> y <> "-" <> z)
… 

> :paste
… merch4 = do
…   x <- "teeshirt" : "sweater" : Nil
…   y <- "large" : "medium" : "small" : Nil
…   z <- "black" : "white" : Nil 
…   pure (x <> "-" <> y <> "-" <> z)
… 

> merch3 == merch4
true

 mkdir show-instance
$ cd show-instance
$ spago init
$ spago install generics-rep
$ spago repl
> import Data.Generic.Rep
> import Data.Show
> import Data.Generic.Rep.Show
> data Action = Change String | Focus
> derive instance genAction :: Generic Action _
> instance showAction :: Show Action where show a = genericShow a
> Change "hi"
(Change "hi")

newtype State s a = State { runState :: s -> {fst :: a, snd :: s} }  

instance functorState :: Functor (State s) where
  map f (State st) = State {runState: \s -> 
                        (\{fst: b, snd} -> {fst: f b, snd}) (st.runState s)}

instance applicativeState :: Applicative (State s) where
  pure x = State {runState: \s -> {fst: x, snd: s} } 

instance applyState :: Apply (State s)  where
  apply = ap

instance bindState :: Bind (State s) where  
    bind (State h) f = State {runState: \s -> 
                                 let {fst: a, snd: newState} = h.runState s  
                                     State g = f a  
                                  in g.runState newState
                                 }  
instance monadState :: Monad (State s)

put :: forall a. a -> State (Array a) Unit  
put a = State {runState: \xs -> {fst: unit, snd: snoc xs a}}

getArray (State {runState}) = (runState []).snd

import Data.Array(snoc)
import Control.Monad.State(State(..), runState)
import Data.Tuple(fst)
import Control.Monad.State.Class(class MonadState, get, modify)

put :: forall a st. Functor st => MonadState (Array a) st => a -> st Unit
put x = void $ modify (flip snoc x)

fromSeq :: forall a. State (Array a) (Array a) -> Array a
fromSeq seq = fst $ runState seq []

seqArray :: State (Array Int) (Array Int)
seqArray = do
  put 2
  put 3
  put 4
  get

import Data.Symbol (class IsSymbol)
import Data.Variant (Variant, inj)
import Prim.Row (class Cons)
import Type.Proxy (Proxy(..))

printTLS :: forall @a. IsSymbol a => String
printTLS = reflectSymbol (Proxy :: Proxy a)

name = printTLS @"the perfect name for a typelevel string"

recordInsert
  :: forall r1 r2 @l a
   . IsSymbol l
  => Lacks l r1
  => Cons l a r1 r2
  => a
  -> Record r1
  -> Record r2
recordInsert = Record.insert (Proxy :: Proxy l)

recordInsert @"crash" 12 {} 


class Interp a where
  interp :: String -> a

instance interpString :: Interp String where
  interp a = a
else instance interpFunction :: Interp a => Interp (String -> a) where
  interp a b = interp (a <> b)
else instance interpShow :: (Show b, Interp a) => Interp (b -> a) where
  interp a b = interp (a <> show b)

i = interp

test = i "foo" 42 "bar" true "baz"

import Data.Variant (Variant, inj)

type TestRow = (a :: Int, b :: Boolean)

type TestRec = Record TestRow

rab = { a: 1, b: true } :: TestRec

type TestVar = Variant TestRow

va = inj (Proxy :: Proxy "a") 6     :: TestVar
vb = inj (Proxy :: Proxy "b") false :: TestVar

w:: forall a @l t. IsSymbol l => Cons l a t TestRow => a -> Variant TestRow
w = inj (Proxy :: Proxy l)

wa = w @"a" 6     :: TestVar
wb = w @"b" false :: TestVar

import Data.FastVect.FastVect as FV
import Type.Proxy (Proxy (..))
import Prim.Int (class Compare)
import Prim.Ordering (GT)
import Data.Reflectable (class Reflectable)

rep :: forall a @n. 
  Reflectable n Int => Compare n (-1) GT 
  => a -> FV.Vect n a
rep str = FV.replicate Proxy str

a13 :: FV.Vect 13 String
a13 = FV.replicate (Proxy :: _ 13) "a"

b8 :: FV.Vect 8 Int
b8 = rep 42

-- customized do:
import Prelude hiding (bind, discard)

bind :: forall a r q. ((a -> r) -> q) -> (a -> r) -> q
bind f a = f a

discard = bind

import Prelude

import Data.Complex (Cartesian(..), angle)
import Data.List (head)
import Data.Maybe (Maybe)
import Data.Number (abs)
import Data.Tuple.Nested ((/\))
import Effect (Effect)
import Test.QuickCheck 
  ( mkSeed
  , checkResults
  , quickCheckPure'
  , (<?>)
  , ResultSummary
  , class Arbitrary
  , arbitrary
  )
import Test.QuickCheck.Gen 
  ( Gen
  , vectorOf
  , oneOf
  , randomSampleOne
  , frequency
  )

counterExample :: ResultSummary -> Maybe String
counterExample rs =
  head rs.failures <#> _.message 

rsInt :: ResultSummary
rsInt = checkResults $ quickCheckPure' (mkSeed 13) 100 $ 
  \n -> (n + 1) * (n + 1) ==  n*n + 1 + 2*n 
    <?> "Test failed for input " <> show n

newtype Complex = C' (Cartesian Number)

instance Arbitrary Complex where
  arbitrary = C' <$> (Cartesian <$> arbitrary <*> arbitrary)

rsCplx :: ResultSummary
rsCplx = checkResults $ quickCheckPure' (mkSeed 123) 100 $ 
  \(C' z1 /\ C' z2) -> abs( angle (z1 * z2) - (angle z1 + angle z2) ) < 1e-16
    <?> "Test failed for input " <> show (z1 /\ z2)

main :: Effect Unit
main = do
  w <- sequence $ randomSampleOne <$> vectorOf 10 <$>
    (  frequency <$> 
      ( fromArray 
        [ 1.0 /\ pure 1.0
        , 0.5 /\ pure 2.0
        , 0.333 /\ pure 3.0
        , 0.25 /\ pure 4.0 
        ]
      ) 
    )
  render $ h4 $ text $ show w

module Main where

import Data.Array (sortBy)
import Data.Exists (Exists, mkExists, runExists)
import Data.Foldable (fold)
import Data.Function (flip, on, ($))
import Data.Functor (map)
import Data.Maybe (Maybe(..))
import Data.Ord (Ordering(..))

data ComparisonF a b = ComparisonF (a -> Maybe b) (b -> b -> Ordering)
newtype Comparison a = Comparison (Exists (ComparisonF a))

flipComparison :: forall a. Comparison a -> Comparison a
flipComparison (Comparison exists) = Comparison $ runExists f exists
  where f :: forall e. ComparisonF a e -> Exists (ComparisonF a)
        f (ComparisonF a b) = mkExists (ComparisonF a (flip b))

liftCompare :: forall a b. 
  (a -> b -> Ordering) -> Maybe a -> Maybe b -> Ordering
liftCompare _ Nothing Nothing   = EQ
liftCompare _ Nothing (Just _)  = LT
liftCompare _ (Just _) Nothing  = GT
liftCompare comp (Just x) (Just y) = comp x y

sortOnMultiple :: forall a b. 
  Array (Comparison b) -> (a -> b) -> Array a -> Array a
sortOnMultiple comparisons projection xs =
  let combineComparison :: Comparison b -> b -> b -> Ordering
      combineComparison (Comparison exists) = 
        runExists (\(ComparisonF f g) -> liftCompare g `on` f) exists
      ordering :: b -> b -> Ordering
      ordering = fold $ map combineComparison comparisons
  in  sortBy (ordering `on` projection) xs
  
newtype T a z = T a

instance Eq a => Eq (T a z) where
  eq (T a) (T b) = a == b
  
t1 = T 2 :: forall z. T Int z
t3 = T 6 :: forall z. T Int z

u1 = T 2 :: T Int Char
u3 = T 6 :: T Int String

nonTransitivity = t1 == u1 && t1 == u3 -- && u1 == u3

import Data.Array ((!!)) as Array
import Effect (Effect)
import Effect.Console (log)
import Data.Set (Set, insert, empty, member)
import Data.Array (length, updateAtIndices, (..), (:))
import Data.Tuple (fst)
import Data.Tuple.Nested ((/\))
import Data.Maybe (fromMaybe)
import Test.QuickCheck (class Arbitrary, arbitrary, mkSeed)
import Test.QuickCheck.Gen (evalGen)

nth :: forall a. Arbitrary a => Array a -> Int -> a
nth arr i = fromMaybe (evalGen  arbitrary { newSeed: mkSeed 0, size: 1 } ) $ arr Array.!! i

infix 5 nth as !!

cycle :: forall a. Arbitrary a => Int -> Array a -> Array a
cycle n arr = 
  updateAtIndices (((n-1) /\ (arr !! 0)) : ((\i -> i /\ (arr !! (i+1))) <$> (0..(n-2)))) arr
  
permutations :: forall a. Ord a => Arbitrary a => Array a -> Set (Array a)
permutations arr = fst $ proc n (empty /\ arr)
  where
    n = length arr
    proc 1 x = x
    proc k (acc /\ cur) =
      if next `member` acc
        then proc (k-1) (acc /\ next)
        else proc n (insert next acc /\ next)
      where
        next = cycle k cur

theFinalNumber :: Either String Number
theFinalNumber = note "There was no number" (Data.Array.last [1000.0, 2000.0, 1250.0])

-- along with using `liftAff` again, we're also using:
except :: forall e m a. Applicative m => Either e a -> ExceptT e m a

example_v2 :: String -> Aff (Either String Baz)
example_v2 str = runExceptT do
  foo <- ExceptT $ func1 str
  bar <- ExceptT $ func2 foo
  ms <- except theFinalNumber
  liftAff $ Aff.delay (Milliseconds ms)
  ExceptT $ func3 bar

date1 = 
  canonicalDate <$> toEnum 2024 <*> toEnum 10 <*> toEnum 31
  :: Maybe Date
date2 = 
  canonicalDate <$> toEnum 2024 <*> toEnum 11 <*> toEnum 2
  :: Maybe Date

seq :: Date -> Date -> Array Date
seq d1 d2 = 
  iterateN 
    (round $ 1.0 + nb)
    (fromMaybe <*> succ) d1
    where
        Days nb = diff d2 d1