Add show instance for Array to prelude

Add show instance for Array to prelude

module Prelude where

  flip :: forall a b c. (a -> b -> c) -> b -> a -> c
  flip f b a = f a b

  const :: forall a b. a -> b -> a
  const a _ = a

  on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
  on f g x y = g x `f` g y

  asTypeOf :: forall a. a -> a -> a
  asTypeOf x _ = x

  infixr 9 >>>
  infixr 9 <<<

  class Semigroupoid a where
    (<<<) :: forall b c d. a c d -> a b c -> a b d

  instance semigroupoidArr :: Semigroupoid (->) where
    (<<<) f g x = f (g x)

  (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
  (>>>) f g = g <<< f

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

  instance categoryArr :: Category (->) where
    id x = x

  infixr 0 $
  infixl 0 #

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

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

  infixr 6 :

  (:) :: forall a. a -> [a] -> [a]
  (:) = cons

  foreign import cons
    "function cons(e) {\
    \  return function (l) {\
    \    return [e].concat(l);\
    \  };\
    \}" :: forall a. a -> [a] -> [a]

  class Show a where
    show :: a -> String

  foreign import showStringImpl
    "function showStringImpl(s) {\
    \  return JSON.stringify(s);\
    \}" :: String -> String

  instance showString :: Show String where
    show = showStringImpl

  instance showBoolean :: Show Boolean where
    show true = "true"
    show false = "false"

  foreign import showNumberImpl "function showNumberImpl(n) {\
                                \  return n.toString();\
                                \}" :: Number -> String

  instance showNumber :: Show Number where
    show = showNumberImpl

  foreign import showArrayImpl
    "function showArrayImpl (f) {\
    \  return function (xs) {\
    \    var ss = [];\
    \    for (var i = 0, l = xs.length; i < l; i++) {\
    \      ss[i] = f(xs[i]);\
    \    }\
    \    return '[' + ss.join(',') + ']';\
    \  };\
    \}" :: forall a. (a -> String) -> [a] -> String

  instance showArray :: (Show a) => Show [a] where
    show = showArrayImpl show

  infixl 4 <$>

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

  infixl 4 <*>

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

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

  liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
  liftA1 f a = pure f <*> a

  infixl 3 <|>

  class Alternative f where
    empty :: forall a. f a
    (<|>) :: forall a. f a -> f a -> f a

  infixl 1 >>=

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

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

  return :: forall m a. (Monad m) => a -> m a
  return = pure

  liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
  liftM1 f a = do
    a' <- a
    return (f a')

  ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
  ap f a = do
    f' <- f
    a' <- a
    return (f' a')

  infixl 7 *
  infixl 7 /
  infixl 7 %

  infixl 6 -
  infixl 6 +

  class Num a where
    (+) :: a -> a -> a
    (-) :: a -> a -> a
    (*) :: a -> a -> a
    (/) :: a -> a -> a
    (%) :: a -> a -> a
    negate :: a -> a

  foreign import numAdd "function numAdd(n1) {\
                        \  return function(n2) {\
                        \    return n1 + n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numSub "function numSub(n1) {\
                        \  return function(n2) {\
                        \    return n1 - n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMul "function numMul(n1) {\
                        \  return function(n2) {\
                        \    return n1 * n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numDiv "function numDiv(n1) {\
                        \  return function(n2) {\
                        \    return n1 / n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMod "function numMod(n1) {\
                        \  return function(n2) {\
                        \    return n1 % n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numNegate "function numNegate(n) {\
                           \  return -n;\
                           \}" :: Number -> Number

  instance numNumber :: Num Number where
    (+) = numAdd
    (-) = numSub
    (*) = numMul
    (/) = numDiv
    (%) = numMod
    negate = numNegate

  infix 4 ==
  infix 4 /=

  class Eq a where
    (==) :: a -> a -> Boolean
    (/=) :: a -> a -> Boolean

  foreign import refEq
    "function refEq(r1) {\
    \  return function(r2) {\
    \    return r1 === r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  foreign import refIneq
    "function refIneq(r1) {\
    \  return function(r2) {\
    \    return r1 !== r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  instance eqString :: Eq String where
    (==) = refEq
    (/=) = refIneq

  instance eqNumber :: Eq Number where
    (==) = refEq
    (/=) = refIneq

  instance eqBoolean :: Eq Boolean where
    (==) = refEq
    (/=) = refIneq

  instance eqArray :: (Eq a) => Eq [a] where
    (==) [] [] = true
    (==) (x:xs) (y:ys) = x == y && xs == ys
    (==) _ _ = false
    (/=) xs ys = not (xs == ys)

  data Ordering = LT | GT | EQ

  instance eqOrdering :: Eq Ordering where
    (==) LT LT = true
    (==) GT GT = true
    (==) EQ EQ = true
    (==) _  _  = false
    (/=) x y = not (x == y)

  instance showOrdering :: Show Ordering where
    show LT = "LT"
    show GT = "GT"
    show EQ = "EQ"

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

  infixl 4 <

  (<) :: forall a. (Ord a) => a -> a -> Boolean
  (<) a1 a2 = case a1 `compare` a2 of
    LT -> true
    _ -> false

  infixl 4 >

  (>) :: forall a. (Ord a) => a -> a -> Boolean
  (>) a1 a2 = case a1 `compare` a2 of
    GT -> true
    _ -> false

  infixl 4 <=

  (<=) :: forall a. (Ord a) => a -> a -> Boolean
  (<=) a1 a2 = case a1 `compare` a2 of
    GT -> false
    _ -> true

  infixl 4 >=

  (>=) :: forall a. (Ord a) => a -> a -> Boolean
  (>=) a1 a2 = case a1 `compare` a2 of
    LT -> false
    _ -> true

  foreign import numCompare
    "function numCompare(n1) {\
    \  return function(n2) {\
    \    return n1 < n2 ? module.LT : n1 > n2 ? module.GT : module.EQ;\
    \  };\
    \}" :: Number -> Number -> Ordering

  instance ordNumber :: Ord Number where
    compare = numCompare

  infixl 10 &
  infixl 10 |
  infixl 10 ^

  class Bits b where
    (&) :: b -> b -> b
    (|) :: b -> b -> b
    (^) :: b -> b -> b
    shl :: b -> Number -> b
    shr :: b -> Number -> b
    zshr :: b -> Number -> b
    complement :: b -> b

  foreign import numShl "function numShl(n1) {\
                        \  return function(n2) {\
                        \    return n1 << n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numShr "function numShr(n1) {\
                        \  return function(n2) {\
                        \    return n1 >> n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numZshr "function numZshr(n1) {\
                          \  return function(n2) {\
                          \    return n1 >>> n2;\
                          \  };\
                          \}" :: Number -> Number -> Number

  foreign import numAnd "function numAnd(n1) {\
                        \  return function(n2) {\
                        \    return n1 & n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numOr "function numOr(n1) {\
                       \  return function(n2) {\
                       \    return n1 | n2;\
                       \  };\
                       \}" :: Number -> Number -> Number

  foreign import numXor "function numXor(n1) {\
                        \  return function(n2) {\
                        \    return n1 ^ n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numComplement "function numComplement(n) {\
                               \  return ~n;\
                               \}" :: Number -> Number

  instance bitsNumber :: Bits Number where
    (&) = numAnd
    (|) = numOr
    (^) = numXor
    shl = numShl
    shr = numShr
    zshr = numZshr
    complement = numComplement

  infixr 2 ||
  infixr 3 &&

  class BoolLike b where
    (&&) :: b -> b -> b
    (||) :: b -> b -> b
    not :: b -> b

  foreign import boolAnd "function boolAnd(b1) {\
                         \  return function(b2) {\
                         \    return b1 && b2;\
                         \  };\
                         \}"  :: Boolean -> Boolean -> Boolean

  foreign import boolOr "function boolOr(b1) {\
                        \  return function(b2) {\
                        \    return b1 || b2;\
                        \  };\
                        \}" :: Boolean -> Boolean -> Boolean

  foreign import boolNot "function boolNot(b) {\
                         \  return !b;\
                         \}" :: Boolean -> Boolean

  instance boolLikeBoolean :: BoolLike Boolean where
    (&&) = boolAnd
    (||) = boolOr
    not = boolNot

  infixr 5 <>

  class Semigroup a where
    (<>) :: a -> a -> a

  foreign import concatString
    "function concatString(s1) {\
    \  return function(s2) {\
    \    return s1 + s2;\
    \  };\
    \}" :: String -> String -> String

  instance semigroupString :: Semigroup String where
    (<>) = concatString

  infixr 5 ++

  (++) :: forall s. (Semigroup s) => s -> s -> s
  (++) = (<>)

module Data.Eq where

  data Ref a = Ref a

  liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
  liftRef f (Ref x) (Ref y) = f x y

  instance eqRef :: Eq (Ref a) where
    (==) = liftRef refEq
    (/=) = liftRef refIneq

module Prelude.Unsafe where

  foreign import unsafeIndex
    "function unsafeIndex(xs) {\
    \  return function(n) {\
    \    return xs[n];\
    \  };\
    \}" :: forall a. [a] -> Number -> a

module Control.Monad.Eff where

  foreign import data Eff :: # ! -> * -> *

  foreign import returnE "function returnE(a) {\
                         \  return function() {\
                         \    return a;\
                         \  };\
                         \}" :: forall e a. a -> Eff e a

  foreign import bindE "function bindE(a) {\
                       \  return function(f) {\
                       \    return function() {\
                       \      return f(a())();\
                       \    };\
                       \  };\
                       \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

  type Pure a = forall e. Eff e a

  foreign import runPure "function runPure(f) {\
                         \  return f();\
                         \}" :: forall a. Pure a -> a

  instance functorEff :: Functor (Eff e) where
    (<$>) = liftA1

  instance applyEff :: Apply (Eff e) where
    (<*>) = ap

  instance applicativeEff :: Applicative (Eff e) where
    pure = returnE

  instance bindEff :: Bind (Eff e) where
    (>>=) = bindE

  instance monadEff :: Monad (Eff e)

  foreign import untilE "function untilE(f) {\
                        \  return function() {\
                        \    while (!f()) { }\
                        \    return {};\
                        \  };\
                        \}" :: forall e. Eff e Boolean -> Eff e {}

  foreign import whileE "function whileE(f) {\
                        \  return function(a) {\
                        \    return function() {\
                        \      while (f()) {\
                        \        a();\
                        \      }\
                        \      return {};\
                        \    };\
                        \  };\
                        \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e {}

  foreign import forE "function forE(lo) {\
                      \  return function(hi) {\
                      \    return function(f) {\
                      \      return function() {\
                      \        for (var i = lo; i < hi; i++) {\
                      \          f(i)();\
                      \        }\
                      \      };\
                      \    };\
                      \  };\
                      \}" :: forall e. Number -> Number -> (Number -> Eff e {}) -> Eff e {}

  foreign import foreachE "function foreachE(as) {\
                          \  return function(f) {\
                          \    for (var i = 0; i < as.length; i++) {\
                          \      f(as[i])();\
                          \    }\
                          \  };\
                          \}" :: forall e a. [a] -> (a -> Eff e {}) -> Eff e {}

module Control.Monad.Eff.Unsafe where

  import Control.Monad.Eff

  foreign import unsafeInterleaveEff
    "function unsafeInterleaveEff(f) {\
    \  return f;\
    \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a

module Debug.Trace where

  import Control.Monad.Eff

  foreign import data Trace :: !

  foreign import trace "function trace(s) {\
                       \  return function() {\
                       \    console.log(s);\
                       \    return {};\
                       \  };\
                       \}" :: forall r. String -> Eff (trace :: Trace | r) {}

  print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) {}
  print o = trace (show o)

module Control.Monad.ST where

  import Control.Monad.Eff

  foreign import data ST :: * -> !

  foreign import data STRef :: * -> * -> *

  foreign import data STArray :: * -> * -> *

  foreign import newSTRef "function newSTRef(val) {\
                          \  return function () {\
                          \    return { value: val };\
                          \  };\
                          \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

  foreign import readSTRef "function readSTRef(ref) {\
                           \  return function() {\
                           \    return ref.value;\
                           \  };\
                           \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

  foreign import modifySTRef "function modifySTRef(ref) {\
                             \  return function(f) {\
                             \    return function() {\
                             \      return ref.value = f(ref.value);\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

  foreign import writeSTRef "function writeSTRef(ref) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      return ref.value = a;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

  foreign import newSTArray "function newSTArray(len) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      var arr = [];\
                            \      for (var i = 0; i < len; i++) {\
                            \        arr[i] = a;\
                            \      };\
                            \      return arr;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)

  foreign import peekSTArray "function peekSTArray(arr) {\
                             \  return function(i) {\
                             \    return function() {\
                             \      return arr[i];\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Eff (st :: ST h | r) a

  foreign import pokeSTArray "function pokeSTArray(arr) {\
                             \  return function(i) {\
                             \    return function(a) {\
                             \      return function() {\
                             \        return arr[i] = a;\
                             \      };\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a

  foreign import runST "function runST(f) {\
                       \  return f;\
                       \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

  foreign import runSTArray "function runSTArray(f) {\
                            \  return f;\
                            \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]

module Prelude where

  flip :: forall a b c. (a -> b -> c) -> b -> a -> c
  flip f b a = f a b

  const :: forall a b. a -> b -> a
  const a _ = a

  on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
  on f g x y = g x `f` g y

  asTypeOf :: forall a. a -> a -> a
  asTypeOf x _ = x

  infixr 9 >>>
  infixr 9 <<<

  class Semigroupoid a where
    (<<<) :: forall b c d. a c d -> a b c -> a b d

  instance semigroupoidArr :: Semigroupoid (->) where
    (<<<) f g x = f (g x)

  (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
  (>>>) f g = g <<< f

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

  instance categoryArr :: Category (->) where
    id x = x

  infixr 0 $
  infixl 0 #

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

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

  infixr 6 :

  (:) :: forall a. a -> [a] -> [a]
  (:) = cons

  foreign import cons
    "function cons(e) {\
    \  return function (l) {\
    \    return [e].concat(l);\
    \  };\
    \}" :: forall a. a -> [a] -> [a]

  class Show a where
    show :: a -> String

  foreign import showStringImpl
    "function showStringImpl(s) {\
    \  return JSON.stringify(s);\
    \}" :: String -> String

  instance showString :: Show String where
    show = showStringImpl

  instance showBoolean :: Show Boolean where
    show true = "true"
    show false = "false"

  foreign import showNumberImpl "function showNumberImpl(n) {\
                                \  return n.toString();\
                                \}" :: Number -> String

  instance showNumber :: Show Number where
    show = showNumberImpl

  infixl 4 <$>

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

  infixl 4 <*>

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

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

  liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
  liftA1 f a = pure f <*> a

  infixl 3 <|>

  class Alternative f where
    empty :: forall a. f a
    (<|>) :: forall a. f a -> f a -> f a

  infixl 1 >>=

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

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

  return :: forall m a. (Monad m) => a -> m a
  return = pure

  liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
  liftM1 f a = do
    a' <- a
    return (f a')

  ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
  ap f a = do
    f' <- f
    a' <- a
    return (f' a')

  infixl 7 *
  infixl 7 /
  infixl 7 %

  infixl 6 -
  infixl 6 +

  class Num a where
    (+) :: a -> a -> a
    (-) :: a -> a -> a
    (*) :: a -> a -> a
    (/) :: a -> a -> a
    (%) :: a -> a -> a
    negate :: a -> a

  foreign import numAdd "function numAdd(n1) {\
                        \  return function(n2) {\
                        \    return n1 + n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numSub "function numSub(n1) {\
                        \  return function(n2) {\
                        \    return n1 - n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMul "function numMul(n1) {\
                        \  return function(n2) {\
                        \    return n1 * n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numDiv "function numDiv(n1) {\
                        \  return function(n2) {\
                        \    return n1 / n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numMod "function numMod(n1) {\
                        \  return function(n2) {\
                        \    return n1 % n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numNegate "function numNegate(n) {\
                           \  return -n;\
                           \}" :: Number -> Number

  instance numNumber :: Num Number where
    (+) = numAdd
    (-) = numSub
    (*) = numMul
    (/) = numDiv
    (%) = numMod
    negate = numNegate

  infix 4 ==
  infix 4 /=

  class Eq a where
    (==) :: a -> a -> Boolean
    (/=) :: a -> a -> Boolean

  foreign import refEq
    "function refEq(r1) {\
    \  return function(r2) {\
    \    return r1 === r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  foreign import refIneq
    "function refIneq(r1) {\
    \  return function(r2) {\
    \    return r1 !== r2;\
    \  };\
    \}" :: forall a. a -> a -> Boolean

  instance eqString :: Eq String where
    (==) = refEq
    (/=) = refIneq

  instance eqNumber :: Eq Number where
    (==) = refEq
    (/=) = refIneq

  instance eqBoolean :: Eq Boolean where
    (==) = refEq
    (/=) = refIneq

  instance eqArray :: (Eq a) => Eq [a] where
    (==) [] [] = true
    (==) (x:xs) (y:ys) = x == y && xs == ys
    (==) _ _ = false
    (/=) xs ys = not (xs == ys)

  data Ordering = LT | GT | EQ

  instance eqOrdering :: Eq Ordering where
    (==) LT LT = true
    (==) GT GT = true
    (==) EQ EQ = true
    (==) _  _  = false
    (/=) x y = not (x == y)

  instance showOrdering :: Show Ordering where
    show LT = "LT"
    show GT = "GT"
    show EQ = "EQ"

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

  infixl 4 <

  (<) :: forall a. (Ord a) => a -> a -> Boolean
  (<) a1 a2 = case a1 `compare` a2 of
    LT -> true
    _ -> false

  infixl 4 >

  (>) :: forall a. (Ord a) => a -> a -> Boolean
  (>) a1 a2 = case a1 `compare` a2 of
    GT -> true
    _ -> false

  infixl 4 <=

  (<=) :: forall a. (Ord a) => a -> a -> Boolean
  (<=) a1 a2 = case a1 `compare` a2 of
    GT -> false
    _ -> true

  infixl 4 >=

  (>=) :: forall a. (Ord a) => a -> a -> Boolean
  (>=) a1 a2 = case a1 `compare` a2 of
    LT -> false
    _ -> true

  foreign import numCompare
    "function numCompare(n1) {\
    \  return function(n2) {\
    \    return n1 < n2 ? module.LT : n1 > n2 ? module.GT : module.EQ;\
    \  };\
    \}" :: Number -> Number -> Ordering

  instance ordNumber :: Ord Number where
    compare = numCompare

  infixl 10 &
  infixl 10 |
  infixl 10 ^

  class Bits b where
    (&) :: b -> b -> b
    (|) :: b -> b -> b
    (^) :: b -> b -> b
    shl :: b -> Number -> b
    shr :: b -> Number -> b
    zshr :: b -> Number -> b
    complement :: b -> b

  foreign import numShl "function numShl(n1) {\
                        \  return function(n2) {\
                        \    return n1 << n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numShr "function numShr(n1) {\
                        \  return function(n2) {\
                        \    return n1 >> n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numZshr "function numZshr(n1) {\
                          \  return function(n2) {\
                          \    return n1 >>> n2;\
                          \  };\
                          \}" :: Number -> Number -> Number

  foreign import numAnd "function numAnd(n1) {\
                        \  return function(n2) {\
                        \    return n1 & n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numOr "function numOr(n1) {\
                       \  return function(n2) {\
                       \    return n1 | n2;\
                       \  };\
                       \}" :: Number -> Number -> Number

  foreign import numXor "function numXor(n1) {\
                        \  return function(n2) {\
                        \    return n1 ^ n2;\
                        \  };\
                        \}" :: Number -> Number -> Number

  foreign import numComplement "function numComplement(n) {\
                               \  return ~n;\
                               \}" :: Number -> Number

  instance bitsNumber :: Bits Number where
    (&) = numAnd
    (|) = numOr
    (^) = numXor
    shl = numShl
    shr = numShr
    zshr = numZshr
    complement = numComplement

  infixr 2 ||
  infixr 3 &&

  class BoolLike b where
    (&&) :: b -> b -> b
    (||) :: b -> b -> b
    not :: b -> b

  foreign import boolAnd "function boolAnd(b1) {\
                         \  return function(b2) {\
                         \    return b1 && b2;\
                         \  };\
                         \}"  :: Boolean -> Boolean -> Boolean

  foreign import boolOr "function boolOr(b1) {\
                        \  return function(b2) {\
                        \    return b1 || b2;\
                        \  };\
                        \}" :: Boolean -> Boolean -> Boolean

  foreign import boolNot "function boolNot(b) {\
                         \  return !b;\
                         \}" :: Boolean -> Boolean

  instance boolLikeBoolean :: BoolLike Boolean where
    (&&) = boolAnd
    (||) = boolOr
    not = boolNot

  infixr 5 <>

  class Semigroup a where
    (<>) :: a -> a -> a

  foreign import concatString
    "function concatString(s1) {\
    \  return function(s2) {\
    \    return s1 + s2;\
    \  };\
    \}" :: String -> String -> String

  instance semigroupString :: Semigroup String where
    (<>) = concatString

  infixr 5 ++

  (++) :: forall s. (Semigroup s) => s -> s -> s
  (++) = (<>)

module Data.Eq where

  data Ref a = Ref a

  liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
  liftRef f (Ref x) (Ref y) = f x y

  instance eqRef :: Eq (Ref a) where
    (==) = liftRef refEq
    (/=) = liftRef refIneq

module Prelude.Unsafe where

  foreign import unsafeIndex
    "function unsafeIndex(xs) {\
    \  return function(n) {\
    \    return xs[n];\
    \  };\
    \}" :: forall a. [a] -> Number -> a

module Control.Monad.Eff where

  foreign import data Eff :: # ! -> * -> *

  foreign import returnE "function returnE(a) {\
                         \  return function() {\
                         \    return a;\
                         \  };\
                         \}" :: forall e a. a -> Eff e a

  foreign import bindE "function bindE(a) {\
                       \  return function(f) {\
                       \    return function() {\
                       \      return f(a())();\
                       \    };\
                       \  };\
                       \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

  type Pure a = forall e. Eff e a

  foreign import runPure "function runPure(f) {\
                         \  return f();\
                         \}" :: forall a. Pure a -> a

  instance functorEff :: Functor (Eff e) where
    (<$>) = liftA1

  instance applyEff :: Apply (Eff e) where
    (<*>) = ap

  instance applicativeEff :: Applicative (Eff e) where
    pure = returnE

  instance bindEff :: Bind (Eff e) where
    (>>=) = bindE

  instance monadEff :: Monad (Eff e)

  foreign import untilE "function untilE(f) {\
                        \  return function() {\
                        \    while (!f()) { }\
                        \    return {};\
                        \  };\
                        \}" :: forall e. Eff e Boolean -> Eff e {}

  foreign import whileE "function whileE(f) {\
                        \  return function(a) {\
                        \    return function() {\
                        \      while (f()) {\
                        \        a();\
                        \      }\
                        \      return {};\
                        \    };\
                        \  };\
                        \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e {}

  foreign import forE "function forE(lo) {\
                      \  return function(hi) {\
                      \    return function(f) {\
                      \      return function() {\
                      \        for (var i = lo; i < hi; i++) {\
                      \          f(i)();\
                      \        }\
                      \      };\
                      \    };\
                      \  };\
                      \}" :: forall e. Number -> Number -> (Number -> Eff e {}) -> Eff e {}

  foreign import foreachE "function foreachE(as) {\
                          \  return function(f) {\
                          \    for (var i = 0; i < as.length; i++) {\
                          \      f(as[i])();\
                          \    }\
                          \  };\
                          \}" :: forall e a. [a] -> (a -> Eff e {}) -> Eff e {}

module Control.Monad.Eff.Unsafe where

  import Control.Monad.Eff

  foreign import unsafeInterleaveEff
    "function unsafeInterleaveEff(f) {\
    \  return f;\
    \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a

module Debug.Trace where

  import Control.Monad.Eff

  foreign import data Trace :: !

  foreign import trace "function trace(s) {\
                       \  return function() {\
                       \    console.log(s);\
                       \    return {};\
                       \  };\
                       \}" :: forall r. String -> Eff (trace :: Trace | r) {}

  print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) {}
  print o = trace (show o)

module Control.Monad.ST where

  import Control.Monad.Eff

  foreign import data ST :: * -> !

  foreign import data STRef :: * -> * -> *

  foreign import data STArray :: * -> * -> *

  foreign import newSTRef "function newSTRef(val) {\
                          \  return function () {\
                          \    return { value: val };\
                          \  };\
                          \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

  foreign import readSTRef "function readSTRef(ref) {\
                           \  return function() {\
                           \    return ref.value;\
                           \  };\
                           \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

  foreign import modifySTRef "function modifySTRef(ref) {\
                             \  return function(f) {\
                             \    return function() {\
                             \      return ref.value = f(ref.value);\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

  foreign import writeSTRef "function writeSTRef(ref) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      return ref.value = a;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

  foreign import newSTArray "function newSTArray(len) {\
                            \  return function(a) {\
                            \    return function() {\
                            \      var arr = [];\
                            \      for (var i = 0; i < len; i++) {\
                            \        arr[i] = a;\
                            \      };\
                            \      return arr;\
                            \    };\
                            \  };\
                            \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)

  foreign import peekSTArray "function peekSTArray(arr) {\
                             \  return function(i) {\
                             \    return function() {\
                             \      return arr[i];\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Eff (st :: ST h | r) a

  foreign import pokeSTArray "function pokeSTArray(arr) {\
                             \  return function(i) {\
                             \    return function(a) {\
                             \      return function() {\
                             \        return arr[i] = a;\
                             \      };\
                             \    };\
                             \  };\
                             \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a

  foreign import runST "function runST(f) {\
                       \  return f;\
                       \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

  foreign import runSTArray "function runSTArray(f) {\
                            \  return f;\
                            \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]


renamed module

renamed module

module Blueprint.Component.Callout where

import Prelude

import React (ReactElement)
import React.DOM as RD
import React.DOM.Props as RP

newtype CalloutModifier = CalloutModifier String

-- DISCUSS: record access? or direct primary? using Enum ClassTypes?
calloutModifier ::
  { primary  :: CalloutModifier
  , success  :: CalloutModifier
  , warning  :: CalloutModifier
  , danger   :: CalloutModifier
  , withIcon :: CalloutModifier
  }
calloutModifier =
  { primary  :  CalloutModifier "pt-intent-primary"
  , success  :  CalloutModifier "pt-intent-success"
  , warning  :  CalloutModifier "pt-intent-warning"
  , danger   :  CalloutModifier "pt-intent-danger"
  , withIcon :  CalloutModifier "pt-icon-info-sign"
  }

callout :: CalloutModifier -> Array ReactElement -> ReactElement
callout (CalloutModifier m) c =
  RD.div [ RP.className $ "pt-callout " <> m ] c

module Blueprint.Component.Callouts where

import Prelude

import React (ReactElement)
import React.DOM as RD
import React.DOM.Props as RP

newtype CalloutModifier = CalloutModifier String

-- DISCUSS: record access? or direct primary? using Enum ClassTypes?
calloutModifier ::
  { primary  :: CalloutModifier
  , success  :: CalloutModifier
  , warning  :: CalloutModifier
  , danger   :: CalloutModifier
  , withIcon :: CalloutModifier
  }
calloutModifier =
  { primary  :  CalloutModifier "pt-intent-primary"
  , success  :  CalloutModifier "pt-intent-success"
  , warning  :  CalloutModifier "pt-intent-warning"
  , danger   :  CalloutModifier "pt-intent-danger"
  , withIcon :  CalloutModifier "pt-icon-info-sign"
  }

callout :: CalloutModifier -> Array ReactElement -> ReactElement
callout (CalloutModifier m) c =
  RD.div [ RP.className $ "pt-callout " <> m ] c


Fix type of exists

Fix type of exists

module Node.FS.Async
  ( Callback (..)
  , rename
  , truncate
  , chown
  , chmod
  , stat
  , link
  , symlink
  , readlink
  , realpath
  , realpath'
  , unlink
  , rmdir
  , mkdir
  , mkdir'
  , readdir
  , utimes
  , readFile
  , readTextFile
  , writeFile
  , writeTextFile
  , appendFile
  , appendTextFile
  , exists
  ) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)
import Control.Monad.Eff.Exception
import Data.Date
import Data.Time
import Data.Either
import Data.Function
import Data.Maybe
import Data.Maybe.Unsafe(fromJust)
import Node.Buffer (Buffer(..))
import Node.Encoding
import Node.FS
import Node.FS.Stats
import Node.Path (FilePath())
import Node.FS.Perms
import Node.FS.Internal

foreign import data Nullable :: * -> *

type JSCallback a = Fn2 (Nullable Error) a Unit

foreign import handleCallbackImpl ::
  forall eff a. Fn3 (Error -> Either Error a)
                    (a -> Either Error a)
                    (Callback eff a)
                    (JSCallback a)

handleCallback :: forall eff a b. (Callback eff a) -> JSCallback a
handleCallback cb = runFn3 handleCallbackImpl Left Right cb

foreign import fs ::
  { rename :: Fn3 FilePath FilePath (JSCallback Unit) Unit
  , truncate :: Fn3 FilePath Number (JSCallback Unit) Unit
  , chown :: Fn4 FilePath Number Number (JSCallback Unit) Unit
  , chmod :: Fn3 FilePath String (JSCallback Unit) Unit
  , stat :: Fn2 FilePath (JSCallback StatsObj) Unit
  , link :: Fn3 FilePath FilePath (JSCallback Unit) Unit
  , symlink :: Fn4 FilePath FilePath String (JSCallback Unit) Unit
  , readlink :: Fn2 FilePath (JSCallback FilePath) Unit
  , realpath :: forall cache. Fn3 FilePath { | cache } (JSCallback FilePath) Unit
  , unlink :: Fn2 FilePath (JSCallback Unit) Unit
  , rmdir :: Fn2 FilePath (JSCallback Unit) Unit
  , mkdir :: Fn3 FilePath String (JSCallback Unit) Unit
  , readdir :: Fn2 FilePath (JSCallback (Array FilePath)) Unit
  , utimes :: Fn4 FilePath Int Int (JSCallback Unit) Unit
  , readFile :: forall a opts. Fn3 FilePath { | opts } (JSCallback a) Unit
  , writeFile :: forall a opts. Fn4 FilePath a { | opts } (JSCallback Unit) Unit
  , appendFile :: forall a opts. Fn4 FilePath a { | opts } (JSCallback Unit) Unit
  , exists :: forall a. Fn2 FilePath (Boolean -> a) Unit
  }

-- |
-- Type synonym for callback functions.
--
type Callback eff a = Either Error a -> Eff (fs :: FS | eff) Unit

-- |
-- Renames a file.
--
rename :: forall eff. FilePath
                   -> FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit
rename oldFile newFile cb = mkEff $ \_ -> runFn3
  fs.rename oldFile newFile (handleCallback cb)

-- |
-- Truncates a file to the specified length.
--
truncate :: forall eff. FilePath
                     -> Number
                     -> Callback eff Unit
                     -> Eff (fs :: FS | eff) Unit

truncate file len cb = mkEff $ \_ -> runFn3
  fs.truncate file len (handleCallback cb)

-- |
-- Changes the ownership of a file.
--
chown :: forall eff. FilePath
                  -> Number
                  -> Number
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

chown file uid gid cb = mkEff $ \_ -> runFn4
  fs.chown file uid gid (handleCallback cb)

-- |
-- Changes the permissions of a file.
--
chmod :: forall eff. FilePath
                  -> Perms
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

chmod file perms cb = mkEff $ \_ -> runFn3
  fs.chmod file (permsToString perms) (handleCallback cb)

-- |
-- Gets file statistics.
--
stat :: forall eff. FilePath
                 -> Callback eff Stats
                 -> Eff (fs :: FS | eff) Unit

stat file cb = mkEff $ \_ -> runFn2
  fs.stat file (handleCallback $ cb <<< (<$>) Stats)

-- |
-- Creates a link to an existing file.
--
link :: forall eff. FilePath
                 -> FilePath
                 -> Callback eff Unit
                 -> Eff (fs :: FS | eff) Unit

link src dst cb = mkEff $ \_ -> runFn3
  fs.link src dst (handleCallback cb)

-- |
-- Creates a symlink.
--
symlink :: forall eff. FilePath
                    -> FilePath
                    -> SymlinkType
                    -> Callback eff Unit
                    -> Eff (fs :: FS | eff) Unit

symlink src dest ty cb = mkEff $ \_ -> runFn4
  fs.symlink src dest (show ty) (handleCallback cb)

-- |
-- Reads the value of a symlink.
--
readlink :: forall eff. FilePath
                     -> Callback eff FilePath
                     -> Eff (fs :: FS | eff) Unit

readlink path cb = mkEff $ \_ -> runFn2
  fs.readlink path (handleCallback cb)

-- |
-- Find the canonicalized absolute location for a path.
--
realpath :: forall eff. FilePath
                     -> Callback eff FilePath
                     -> Eff (fs :: FS | eff) Unit

realpath path cb = mkEff $ \_ -> runFn3
  fs.realpath path {} (handleCallback cb)

-- |
-- Find the canonicalized absolute location for a path using a cache object for
-- already resolved paths.
--
realpath' :: forall eff cache. FilePath
                            -> { | cache }
                            -> Callback eff FilePath
                            -> Eff (fs :: FS | eff) Unit

realpath' path cache cb = mkEff $ \_ -> runFn3
  fs.realpath path cache (handleCallback cb)

-- |
-- Deletes a file.
--
unlink :: forall eff. FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

unlink file cb = mkEff $ \_ -> runFn2
  fs.unlink file (handleCallback cb)

-- |
-- Deletes a directory.
--
rmdir :: forall eff. FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

rmdir file cb = mkEff $ \_ -> runFn2
  fs.rmdir file (handleCallback cb)

-- |
-- Makes a new directory.
--
mkdir :: forall eff. FilePath
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

mkdir = flip mkdir' $ mkPerms all all all

-- |
-- Makes a new directory with the specified permissions.
--
mkdir' :: forall eff. FilePath
                   -> Perms
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

mkdir' file perms cb = mkEff $ \_ -> runFn3
  fs.mkdir file (permsToString perms) (handleCallback cb)

-- |
-- Reads the contents of a directory.
--
readdir :: forall eff. FilePath
                    -> Callback eff (Array FilePath)
                    -> Eff (fs :: FS | eff) Unit

readdir file cb = mkEff $ \_ -> runFn2
  fs.readdir file (handleCallback cb)

-- |
-- Sets the accessed and modified times for the specified file.
--
utimes :: forall eff. FilePath
                   -> Date
                   -> Date
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

utimes file atime mtime cb = mkEff $ \_ -> runFn4
  fs.utimes file
            (ms (toEpochMilliseconds atime) / 1000)
            (ms (toEpochMilliseconds mtime) / 1000)
            (handleCallback cb)
  where
  ms (Milliseconds n) = n

-- |
-- Reads the entire contents of a file returning the result as a raw buffer.
--
readFile :: forall eff. FilePath
                     -> Callback eff Buffer
                     -> Eff (fs :: FS | eff) Unit

readFile file cb = mkEff $ \_ -> runFn3
  fs.readFile file {} (handleCallback cb)

-- |
-- Reads the entire contents of a text file with the specified encoding.
--
readTextFile :: forall eff. Encoding
                         -> FilePath
                         -> Callback eff String
                         -> Eff (fs :: FS | eff) Unit

readTextFile encoding file cb = mkEff $ \_ -> runFn3
  fs.readFile file { encoding: show encoding } (handleCallback cb)

-- |
-- Writes a buffer to a file.
--
writeFile :: forall eff. FilePath
                      -> Buffer
                      -> Callback eff Unit
                      -> Eff (fs :: FS | eff) Unit

writeFile file buff cb = mkEff $ \_ -> runFn4
  fs.writeFile file buff {} (handleCallback cb)

-- |
-- Writes text to a file using the specified encoding.
--
writeTextFile :: forall eff. Encoding
                          -> FilePath
                          -> String
                          -> Callback eff Unit
                          -> Eff (fs :: FS | eff) Unit

writeTextFile encoding file buff cb = mkEff $ \_ -> runFn4
  fs.writeFile file buff { encoding: show encoding } (handleCallback cb)

-- |
-- Appends the contents of a buffer to a file.
--
appendFile :: forall eff. FilePath
                       -> Buffer
                       -> Callback eff Unit
                       -> Eff (fs :: FS | eff) Unit

appendFile file buff cb = mkEff $ \_ -> runFn4
  fs.appendFile file buff {} (handleCallback cb)

-- |
-- Appends text to a file using the specified encoding.
--
appendTextFile :: forall eff. Encoding
                           -> FilePath
                           -> String
                           -> Callback eff Unit
                           -> Eff (fs :: FS | eff) Unit

appendTextFile encoding file buff cb = mkEff $ \_ -> runFn4
  fs.appendFile file buff { encoding: show encoding } (handleCallback cb)

-- |
-- Check if the path exists.
--
exists :: forall eff. FilePath
                   -> (Boolean -> Eff (fs :: FS | eff) Unit)
                   -> Eff (fs :: FS | eff) Unit
exists file cb = mkEff $ \_ -> runFn2
  fs.exists file $ \b -> runPure (unsafeInterleaveEff (cb b))

module Node.FS.Async
  ( Callback (..)
  , rename
  , truncate
  , chown
  , chmod
  , stat
  , link
  , symlink
  , readlink
  , realpath
  , realpath'
  , unlink
  , rmdir
  , mkdir
  , mkdir'
  , readdir
  , utimes
  , readFile
  , readTextFile
  , writeFile
  , writeTextFile
  , appendFile
  , appendTextFile
  , exists
  ) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)
import Control.Monad.Eff.Exception
import Data.Date
import Data.Time
import Data.Either
import Data.Function
import Data.Maybe
import Data.Maybe.Unsafe(fromJust)
import Node.Buffer (Buffer(..))
import Node.Encoding
import Node.FS
import Node.FS.Stats
import Node.Path (FilePath())
import Node.FS.Perms
import Node.FS.Internal

foreign import data Nullable :: * -> *

type JSCallback a = Fn2 (Nullable Error) a Unit

foreign import handleCallbackImpl ::
  forall eff a. Fn3 (Error -> Either Error a)
                    (a -> Either Error a)
                    (Callback eff a)
                    (JSCallback a)

handleCallback :: forall eff a b. (Callback eff a) -> JSCallback a
handleCallback cb = runFn3 handleCallbackImpl Left Right cb

foreign import fs ::
  { rename :: Fn3 FilePath FilePath (JSCallback Unit) Unit
  , truncate :: Fn3 FilePath Number (JSCallback Unit) Unit
  , chown :: Fn4 FilePath Number Number (JSCallback Unit) Unit
  , chmod :: Fn3 FilePath String (JSCallback Unit) Unit
  , stat :: Fn2 FilePath (JSCallback StatsObj) Unit
  , link :: Fn3 FilePath FilePath (JSCallback Unit) Unit
  , symlink :: Fn4 FilePath FilePath String (JSCallback Unit) Unit
  , readlink :: Fn2 FilePath (JSCallback FilePath) Unit
  , realpath :: forall cache. Fn3 FilePath { | cache } (JSCallback FilePath) Unit
  , unlink :: Fn2 FilePath (JSCallback Unit) Unit
  , rmdir :: Fn2 FilePath (JSCallback Unit) Unit
  , mkdir :: Fn3 FilePath String (JSCallback Unit) Unit
  , readdir :: Fn2 FilePath (JSCallback (Array FilePath)) Unit
  , utimes :: Fn4 FilePath Int Int (JSCallback Unit) Unit
  , readFile :: forall a opts. Fn3 FilePath { | opts } (JSCallback a) Unit
  , writeFile :: forall a opts. Fn4 FilePath a { | opts } (JSCallback Unit) Unit
  , appendFile :: forall a opts. Fn4 FilePath a { | opts } (JSCallback Unit) Unit
  , exists :: forall a. Fn2 FilePath (Boolean -> a) Unit
  }

-- |
-- Type synonym for callback functions.
--
type Callback eff a = Either Error a -> Eff (fs :: FS | eff) Unit

-- |
-- Renames a file.
--
rename :: forall eff. FilePath
                   -> FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit
rename oldFile newFile cb = mkEff $ \_ -> runFn3
  fs.rename oldFile newFile (handleCallback cb)

-- |
-- Truncates a file to the specified length.
--
truncate :: forall eff. FilePath
                     -> Number
                     -> Callback eff Unit
                     -> Eff (fs :: FS | eff) Unit

truncate file len cb = mkEff $ \_ -> runFn3
  fs.truncate file len (handleCallback cb)

-- |
-- Changes the ownership of a file.
--
chown :: forall eff. FilePath
                  -> Number
                  -> Number
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

chown file uid gid cb = mkEff $ \_ -> runFn4
  fs.chown file uid gid (handleCallback cb)

-- |
-- Changes the permissions of a file.
--
chmod :: forall eff. FilePath
                  -> Perms
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

chmod file perms cb = mkEff $ \_ -> runFn3
  fs.chmod file (permsToString perms) (handleCallback cb)

-- |
-- Gets file statistics.
--
stat :: forall eff. FilePath
                 -> Callback eff Stats
                 -> Eff (fs :: FS | eff) Unit

stat file cb = mkEff $ \_ -> runFn2
  fs.stat file (handleCallback $ cb <<< (<$>) Stats)

-- |
-- Creates a link to an existing file.
--
link :: forall eff. FilePath
                 -> FilePath
                 -> Callback eff Unit
                 -> Eff (fs :: FS | eff) Unit

link src dst cb = mkEff $ \_ -> runFn3
  fs.link src dst (handleCallback cb)

-- |
-- Creates a symlink.
--
symlink :: forall eff. FilePath
                    -> FilePath
                    -> SymlinkType
                    -> Callback eff Unit
                    -> Eff (fs :: FS | eff) Unit

symlink src dest ty cb = mkEff $ \_ -> runFn4
  fs.symlink src dest (show ty) (handleCallback cb)

-- |
-- Reads the value of a symlink.
--
readlink :: forall eff. FilePath
                     -> Callback eff FilePath
                     -> Eff (fs :: FS | eff) Unit

readlink path cb = mkEff $ \_ -> runFn2
  fs.readlink path (handleCallback cb)

-- |
-- Find the canonicalized absolute location for a path.
--
realpath :: forall eff. FilePath
                     -> Callback eff FilePath
                     -> Eff (fs :: FS | eff) Unit

realpath path cb = mkEff $ \_ -> runFn3
  fs.realpath path {} (handleCallback cb)

-- |
-- Find the canonicalized absolute location for a path using a cache object for
-- already resolved paths.
--
realpath' :: forall eff cache. FilePath
                            -> { | cache }
                            -> Callback eff FilePath
                            -> Eff (fs :: FS | eff) Unit

realpath' path cache cb = mkEff $ \_ -> runFn3
  fs.realpath path cache (handleCallback cb)

-- |
-- Deletes a file.
--
unlink :: forall eff. FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

unlink file cb = mkEff $ \_ -> runFn2
  fs.unlink file (handleCallback cb)

-- |
-- Deletes a directory.
--
rmdir :: forall eff. FilePath
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

rmdir file cb = mkEff $ \_ -> runFn2
  fs.rmdir file (handleCallback cb)

-- |
-- Makes a new directory.
--
mkdir :: forall eff. FilePath
                  -> Callback eff Unit
                  -> Eff (fs :: FS | eff) Unit

mkdir = flip mkdir' $ mkPerms all all all

-- |
-- Makes a new directory with the specified permissions.
--
mkdir' :: forall eff. FilePath
                   -> Perms
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

mkdir' file perms cb = mkEff $ \_ -> runFn3
  fs.mkdir file (permsToString perms) (handleCallback cb)

-- |
-- Reads the contents of a directory.
--
readdir :: forall eff. FilePath
                    -> Callback eff (Array FilePath)
                    -> Eff (fs :: FS | eff) Unit

readdir file cb = mkEff $ \_ -> runFn2
  fs.readdir file (handleCallback cb)

-- |
-- Sets the accessed and modified times for the specified file.
--
utimes :: forall eff. FilePath
                   -> Date
                   -> Date
                   -> Callback eff Unit
                   -> Eff (fs :: FS | eff) Unit

utimes file atime mtime cb = mkEff $ \_ -> runFn4
  fs.utimes file
            (ms (toEpochMilliseconds atime) / 1000)
            (ms (toEpochMilliseconds mtime) / 1000)
            (handleCallback cb)
  where
  ms (Milliseconds n) = n

-- |
-- Reads the entire contents of a file returning the result as a raw buffer.
--
readFile :: forall eff. FilePath
                     -> Callback eff Buffer
                     -> Eff (fs :: FS | eff) Unit

readFile file cb = mkEff $ \_ -> runFn3
  fs.readFile file {} (handleCallback cb)

-- |
-- Reads the entire contents of a text file with the specified encoding.
--
readTextFile :: forall eff. Encoding
                         -> FilePath
                         -> Callback eff String
                         -> Eff (fs :: FS | eff) Unit

readTextFile encoding file cb = mkEff $ \_ -> runFn3
  fs.readFile file { encoding: show encoding } (handleCallback cb)

-- |
-- Writes a buffer to a file.
--
writeFile :: forall eff. FilePath
                      -> Buffer
                      -> Callback eff Unit
                      -> Eff (fs :: FS | eff) Unit

writeFile file buff cb = mkEff $ \_ -> runFn4
  fs.writeFile file buff {} (handleCallback cb)

-- |
-- Writes text to a file using the specified encoding.
--
writeTextFile :: forall eff. Encoding
                          -> FilePath
                          -> String
                          -> Callback eff Unit
                          -> Eff (fs :: FS | eff) Unit

writeTextFile encoding file buff cb = mkEff $ \_ -> runFn4
  fs.writeFile file buff { encoding: show encoding } (handleCallback cb)

-- |
-- Appends the contents of a buffer to a file.
--
appendFile :: forall eff. FilePath
                       -> Buffer
                       -> Callback eff Unit
                       -> Eff (fs :: FS | eff) Unit

appendFile file buff cb = mkEff $ \_ -> runFn4
  fs.appendFile file buff {} (handleCallback cb)

-- |
-- Appends text to a file using the specified encoding.
--
appendTextFile :: forall eff. Encoding
                           -> FilePath
                           -> String
                           -> Callback eff Unit
                           -> Eff (fs :: FS | eff) Unit

appendTextFile encoding file buff cb = mkEff $ \_ -> runFn4
  fs.appendFile file buff { encoding: show encoding } (handleCallback cb)

-- |
-- Check if the path exists.
--
exists :: forall eff. FilePath
                   -> (Boolean -> Eff eff Unit)
                   -> Eff (fs :: FS | eff) Unit
exists file cb = mkEff $ \_ -> runFn2
  fs.exists file $ \b -> runPure (unsafeInterleaveEff (cb b))


Add Semigroup ClassName instance

Add Semigroup ClassName instance

Fixes #451.

module Halogen.HTML.Core
  ( HTML(..)
  , slot
  , text
  , element
  , keyed
  , prop
  , attr
  , handler
  , ref
  , class IsProp
  , toPropValue
  , PropName(..)
  , AttrName(..)
  , ClassName(..)
  , module Exports
  ) where

import Prelude

import Data.Bifunctor (class Bifunctor, bimap, rmap)
import Data.Generic (class Generic)
import Data.Maybe (Maybe(..))
import Data.MediaType (MediaType)
import Data.Newtype (class Newtype, unwrap)
import Data.Tuple (Tuple)

import DOM.Node.Types (Element)
import DOM.Event.Types (Event, EventType)
import DOM.HTML.Indexed.ButtonType (ButtonType, renderButtonType)
import DOM.HTML.Indexed.CrossOriginValue (CrossOriginValue, renderCrossOriginValue)
import DOM.HTML.Indexed.DirValue (DirValue, renderDirValue)
import DOM.HTML.Indexed.FormMethod (FormMethod, renderFormMethod)
import DOM.HTML.Indexed.InputType (InputType, renderInputType)
import DOM.HTML.Indexed.KindValue (KindValue, renderKindValue)
import DOM.HTML.Indexed.MenuitemType (MenuitemType, renderMenuitemType)
import DOM.HTML.Indexed.MenuType (MenuType, renderMenuType)
import DOM.HTML.Indexed.OnOff (OnOff, renderOnOff)
import DOM.HTML.Indexed.OrderedListType (OrderedListType, renderOrderedListType)
import DOM.HTML.Indexed.PreloadValue (PreloadValue, renderPreloadValue)
import DOM.HTML.Indexed.ScopeValue (ScopeValue, renderScopeValue)
import DOM.HTML.Indexed.StepValue (StepValue, renderStepValue)
import DOM.HTML.Indexed.WrapValue (WrapValue, renderWrapValue)

import Halogen.Query.InputF (InputF)
import Halogen.VDom as VDom
import Halogen.VDom.DOM.Prop (ElemRef(..), Prop(..), PropValue, propFromBoolean, propFromInt, propFromNumber, propFromString)

import Unsafe.Coerce (unsafeCoerce)

import Halogen.VDom (ElemName(..), Namespace(..)) as Exports
import Halogen.VDom.DOM.Prop (Prop(..), PropValue) as Exports

newtype HTML p i = HTML (VDom.VDom (Array (Prop (InputF Unit i))) p)

derive instance newtypeHTML :: Newtype (HTML p i) _

instance bifunctorHTML :: Bifunctor HTML where
  bimap f g (HTML vdom) = HTML (bimap (map (map (map g))) f vdom)

instance functorHTML :: Functor (HTML p) where
  map = rmap

-- | A smart constructor for widget slots in the HTML.
slot :: forall p q. p -> HTML p q
slot = HTML <<< VDom.Widget

-- | Constructs a text node `HTML` value.
text :: forall p i. String -> HTML p i
text = HTML <<< VDom.Text

-- | A smart constructor for HTML elements.
element :: forall p i. Maybe VDom.Namespace -> VDom.ElemName -> Array (Prop i) -> Array (HTML p i) -> HTML p i
element ns =
  coe (\name props children -> VDom.Elem (VDom.ElemSpec ns name props) children)
  where
  coe
    :: (VDom.ElemName -> Array (Prop i) -> Array (VDom.VDom (Array (Prop i)) p) -> VDom.VDom (Array (Prop i)) p)
    -> VDom.ElemName -> Array (Prop i) -> Array (HTML p i) -> HTML p i
  coe = unsafeCoerce

-- | A smart constructor for HTML elements with keyed children.
keyed :: forall p i. Maybe VDom.Namespace -> VDom.ElemName -> Array (Prop i) -> Array (Tuple String (HTML p i)) -> HTML p i
keyed ns = coe (\name props children -> VDom.Keyed (VDom.ElemSpec ns name props) children)
  where
  coe
    :: (VDom.ElemName -> Array (Prop i) -> Array (Tuple String (VDom.VDom (Array (Prop i)) p)) -> VDom.VDom (Array (Prop i)) p)
    -> VDom.ElemName -> Array (Prop i) -> Array (Tuple String (HTML p i)) -> HTML p i
  coe = unsafeCoerce

-- | Create a HTML property.
prop :: forall value i. IsProp value => PropName value -> value -> Prop i
prop (PropName name) = Property name <<< toPropValue

-- | Create a HTML attribute.
attr :: forall i. Maybe VDom.Namespace -> AttrName -> String -> Prop i
attr ns (AttrName name) = Attribute ns name

-- | Create an event handler.
handler :: forall i. EventType -> (Event -> Maybe i) -> Prop i
handler = Handler

ref :: forall i. (Maybe Element -> Maybe i) -> Prop i
ref f = Ref $ f <<< case _ of
  Created x -> Just x
  Removed _ -> Nothing

class IsProp a where
  toPropValue :: a -> PropValue

instance stringIsProp :: IsProp String where
  toPropValue = propFromString

instance intIsProp :: IsProp Int where
  toPropValue = propFromInt

instance numberIsProp :: IsProp Number where
  toPropValue = propFromNumber

instance booleanIsProp :: IsProp Boolean where
  toPropValue = propFromBoolean

instance mediaTypeIsProp :: IsProp MediaType where
  toPropValue = propFromString <<< unwrap

instance buttonTypeIsProp :: IsProp ButtonType where
  toPropValue = propFromString <<< renderButtonType

instance crossOriginValueIsProp :: IsProp CrossOriginValue where
  toPropValue = propFromString <<< renderCrossOriginValue

instance dirValueIsProp :: IsProp DirValue where
  toPropValue = propFromString <<< renderDirValue

instance formMethodIsProp :: IsProp FormMethod where
  toPropValue = propFromString <<< renderFormMethod

instance inputTypeIsProp :: IsProp InputType where
  toPropValue = propFromString <<< renderInputType

instance kindValueIsProp :: IsProp KindValue where
  toPropValue = propFromString <<< renderKindValue

instance menuitemTypeIsProp :: IsProp MenuitemType where
  toPropValue = propFromString <<< renderMenuitemType

instance menuTypeIsProp :: IsProp MenuType where
  toPropValue = propFromString <<< renderMenuType

instance onOffIsProp :: IsProp OnOff where
  toPropValue = propFromString <<< renderOnOff

instance orderedListTypeIsProp :: IsProp OrderedListType where
  toPropValue = propFromString <<< renderOrderedListType

instance preloadValueIsProp :: IsProp PreloadValue where
  toPropValue = propFromString <<< renderPreloadValue

instance scopeValueIsProp :: IsProp ScopeValue where
  toPropValue = propFromString <<< renderScopeValue

instance stepValueIsProp :: IsProp StepValue where
  toPropValue = propFromString <<< renderStepValue

instance wrapValueIsProp :: IsProp WrapValue where
  toPropValue = propFromString <<< renderWrapValue

-- | A type-safe wrapper for property names.
-- |
-- | The phantom type `value` describes the type of value which this property
-- | requires.
newtype PropName value = PropName String

derive instance newtypePropName :: Newtype (PropName value) _
derive newtype instance eqPropName :: Eq (PropName value)
derive newtype instance ordPropName :: Ord (PropName value)
derive instance genericPropName :: Generic (PropName value)

-- | A type-safe wrapper for attribute names.
newtype AttrName = AttrName String

derive instance newtypeAttrName :: Newtype AttrName _
derive newtype instance eqAttrName :: Eq AttrName
derive newtype instance ordAttrName :: Ord AttrName
derive instance genericAttrName :: Generic AttrName

-- | A wrapper for strings which are used as CSS classes.
newtype ClassName = ClassName String

derive instance newtypeClassName :: Newtype ClassName _
derive newtype instance eqClassName :: Eq ClassName
derive newtype instance ordClassName :: Ord ClassName
derive newtype instance semigroupClassName :: Semigroup ClassName
derive instance genericClassName :: Generic ClassName

module Halogen.HTML.Core
  ( HTML(..)
  , slot
  , text
  , element
  , keyed
  , prop
  , attr
  , handler
  , ref
  , class IsProp
  , toPropValue
  , PropName(..)
  , AttrName(..)
  , ClassName(..)
  , module Exports
  ) where

import Prelude

import Data.Bifunctor (class Bifunctor, bimap, rmap)
import Data.Generic (class Generic)
import Data.Maybe (Maybe(..))
import Data.MediaType (MediaType)
import Data.Newtype (class Newtype, unwrap)
import Data.Tuple (Tuple)

import DOM.Node.Types (Element)
import DOM.Event.Types (Event, EventType)
import DOM.HTML.Indexed.ButtonType (ButtonType, renderButtonType)
import DOM.HTML.Indexed.CrossOriginValue (CrossOriginValue, renderCrossOriginValue)
import DOM.HTML.Indexed.DirValue (DirValue, renderDirValue)
import DOM.HTML.Indexed.FormMethod (FormMethod, renderFormMethod)
import DOM.HTML.Indexed.InputType (InputType, renderInputType)
import DOM.HTML.Indexed.KindValue (KindValue, renderKindValue)
import DOM.HTML.Indexed.MenuitemType (MenuitemType, renderMenuitemType)
import DOM.HTML.Indexed.MenuType (MenuType, renderMenuType)
import DOM.HTML.Indexed.OnOff (OnOff, renderOnOff)
import DOM.HTML.Indexed.OrderedListType (OrderedListType, renderOrderedListType)
import DOM.HTML.Indexed.PreloadValue (PreloadValue, renderPreloadValue)
import DOM.HTML.Indexed.ScopeValue (ScopeValue, renderScopeValue)
import DOM.HTML.Indexed.StepValue (StepValue, renderStepValue)
import DOM.HTML.Indexed.WrapValue (WrapValue, renderWrapValue)

import Halogen.Query.InputF (InputF)
import Halogen.VDom as VDom
import Halogen.VDom.DOM.Prop (ElemRef(..), Prop(..), PropValue, propFromBoolean, propFromInt, propFromNumber, propFromString)

import Unsafe.Coerce (unsafeCoerce)

import Halogen.VDom (ElemName(..), Namespace(..)) as Exports
import Halogen.VDom.DOM.Prop (Prop(..), PropValue) as Exports

newtype HTML p i = HTML (VDom.VDom (Array (Prop (InputF Unit i))) p)

derive instance newtypeHTML :: Newtype (HTML p i) _

instance bifunctorHTML :: Bifunctor HTML where
  bimap f g (HTML vdom) = HTML (bimap (map (map (map g))) f vdom)

instance functorHTML :: Functor (HTML p) where
  map = rmap

-- | A smart constructor for widget slots in the HTML.
slot :: forall p q. p -> HTML p q
slot = HTML <<< VDom.Widget

-- | Constructs a text node `HTML` value.
text :: forall p i. String -> HTML p i
text = HTML <<< VDom.Text

-- | A smart constructor for HTML elements.
element :: forall p i. Maybe VDom.Namespace -> VDom.ElemName -> Array (Prop i) -> Array (HTML p i) -> HTML p i
element ns =
  coe (\name props children -> VDom.Elem (VDom.ElemSpec ns name props) children)
  where
  coe
    :: (VDom.ElemName -> Array (Prop i) -> Array (VDom.VDom (Array (Prop i)) p) -> VDom.VDom (Array (Prop i)) p)
    -> VDom.ElemName -> Array (Prop i) -> Array (HTML p i) -> HTML p i
  coe = unsafeCoerce

-- | A smart constructor for HTML elements with keyed children.
keyed :: forall p i. Maybe VDom.Namespace -> VDom.ElemName -> Array (Prop i) -> Array (Tuple String (HTML p i)) -> HTML p i
keyed ns = coe (\name props children -> VDom.Keyed (VDom.ElemSpec ns name props) children)
  where
  coe
    :: (VDom.ElemName -> Array (Prop i) -> Array (Tuple String (VDom.VDom (Array (Prop i)) p)) -> VDom.VDom (Array (Prop i)) p)
    -> VDom.ElemName -> Array (Prop i) -> Array (Tuple String (HTML p i)) -> HTML p i
  coe = unsafeCoerce

-- | Create a HTML property.
prop :: forall value i. IsProp value => PropName value -> value -> Prop i
prop (PropName name) = Property name <<< toPropValue

-- | Create a HTML attribute.
attr :: forall i. Maybe VDom.Namespace -> AttrName -> String -> Prop i
attr ns (AttrName name) = Attribute ns name

-- | Create an event handler.
handler :: forall i. EventType -> (Event -> Maybe i) -> Prop i
handler = Handler

ref :: forall i. (Maybe Element -> Maybe i) -> Prop i
ref f = Ref $ f <<< case _ of
  Created x -> Just x
  Removed _ -> Nothing

class IsProp a where
  toPropValue :: a -> PropValue

instance stringIsProp :: IsProp String where
  toPropValue = propFromString

instance intIsProp :: IsProp Int where
  toPropValue = propFromInt

instance numberIsProp :: IsProp Number where
  toPropValue = propFromNumber

instance booleanIsProp :: IsProp Boolean where
  toPropValue = propFromBoolean

instance mediaTypeIsProp :: IsProp MediaType where
  toPropValue = propFromString <<< unwrap

instance buttonTypeIsProp :: IsProp ButtonType where
  toPropValue = propFromString <<< renderButtonType

instance crossOriginValueIsProp :: IsProp CrossOriginValue where
  toPropValue = propFromString <<< renderCrossOriginValue

instance dirValueIsProp :: IsProp DirValue where
  toPropValue = propFromString <<< renderDirValue

instance formMethodIsProp :: IsProp FormMethod where
  toPropValue = propFromString <<< renderFormMethod

instance inputTypeIsProp :: IsProp InputType where
  toPropValue = propFromString <<< renderInputType

instance kindValueIsProp :: IsProp KindValue where
  toPropValue = propFromString <<< renderKindValue

instance menuitemTypeIsProp :: IsProp MenuitemType where
  toPropValue = propFromString <<< renderMenuitemType

instance menuTypeIsProp :: IsProp MenuType where
  toPropValue = propFromString <<< renderMenuType

instance onOffIsProp :: IsProp OnOff where
  toPropValue = propFromString <<< renderOnOff

instance orderedListTypeIsProp :: IsProp OrderedListType where
  toPropValue = propFromString <<< renderOrderedListType

instance preloadValueIsProp :: IsProp PreloadValue where
  toPropValue = propFromString <<< renderPreloadValue

instance scopeValueIsProp :: IsProp ScopeValue where
  toPropValue = propFromString <<< renderScopeValue

instance stepValueIsProp :: IsProp StepValue where
  toPropValue = propFromString <<< renderStepValue

instance wrapValueIsProp :: IsProp WrapValue where
  toPropValue = propFromString <<< renderWrapValue

-- | A type-safe wrapper for property names.
-- |
-- | The phantom type `value` describes the type of value which this property
-- | requires.
newtype PropName value = PropName String

derive instance newtypePropName :: Newtype (PropName value) _
derive newtype instance eqPropName :: Eq (PropName value)
derive newtype instance ordPropName :: Ord (PropName value)
derive instance genericPropName :: Generic (PropName value)

-- | A type-safe wrapper for attribute names.
newtype AttrName = AttrName String

derive instance newtypeAttrName :: Newtype AttrName _
derive newtype instance eqAttrName :: Eq AttrName
derive newtype instance ordAttrName :: Ord AttrName
derive instance genericAttrName :: Generic AttrName

-- | A wrapper for strings which are used as CSS classes.
newtype ClassName = ClassName String

derive instance newtypeClassName :: Newtype ClassName _
derive newtype instance eqClassName :: Eq ClassName
derive newtype instance ordClassName :: Ord ClassName
derive instance genericClassName :: Generic ClassName


Split up views and resources

Split up views and resources

module Main where

import Prelude
import Control.Alternative ((<|>))
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.MediaType.Common (textHTML)
import Hyper.Core (HeadersOpen, class ResponseWriter, ResponseEnded, Conn, Middleware, closeHeaders, Port(Port))
import Hyper.HTML.DSL (linkTo, h1, p, text, html)
import Hyper.Method (Method)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Response (contentType, notFound)
import Hyper.Router (notSupported, resource, fallbackTo, handler)
import Node.HTTP (HTTP)

app :: forall m req res rw c.
       (Monad m, ResponseWriter rw m) =>
       Middleware
       m
       (Conn { url :: String, method :: Method | req }
             { writer :: rw HeadersOpen | res }
             c)
       (Conn { url :: String, method :: Method | req }
             { writer :: rw ResponseEnded | res }
             c)
app =
  fallbackTo
  -- Not Found:
  (contentType textHTML >=> closeHeaders >=> notFound)
  -- Resources:
  (resource home <|> resource about)
    where
      homeView =
        html do
          h1 [] (text "Welcome!")
          p [] do
            text "Read more at "
            -- Type-safe routing:
            linkTo about (text "About")
            text "."

      home = { path: []
             , "GET":
               handler (contentType textHTML
                        >=> closeHeaders
                        >=> homeView)
             , "POST": notSupported
             }

      aboutView = html do
        h1 [] (text "About")
        p [] (text "OK, about this example...")

      about = { path: ["about"]
              , "GET": handler (contentType textHTML
                                >=> closeHeaders
                                >=> aboutView)
              , "POST": notSupported
              }

main :: forall e. Eff (http :: HTTP, console :: CONSOLE, err :: EXCEPTION, avar :: AVAR | e) Unit
main =
  let
    -- Some nice console printing when the server starts, and if a request
    -- fails (in this case when the request body is unreadable for some reason).
    onListening (Port port) = log ("Listening on http://localhost:" <> show port)
    onRequestError err = log ("Request failed: " <> show err)

  -- Let's run it.
  in runServer defaultOptions onListening onRequestError app

module Main where

import Prelude
import Control.Alternative ((<|>))
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.MediaType.Common (textHTML)
import Hyper.Core (HeadersOpen, class ResponseWriter, ResponseEnded, Conn, Middleware, closeHeaders, Port(Port))
import Hyper.HTML.DSL (linkTo, h1, p, text, html)
import Hyper.Method (Method)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Response (contentType, notFound)
import Hyper.Router (notSupported, resource, fallbackTo, handler)
import Node.HTTP (HTTP)

app :: forall m req res rw c.
       (Monad m, ResponseWriter rw m) =>
       Middleware
       m
       (Conn { url :: String, method :: Method | req }
             { writer :: rw HeadersOpen | res }
             c)
       (Conn { url :: String, method :: Method | req }
             { writer :: rw ResponseEnded | res }
             c)
app =
  fallbackTo
  -- Not Found:
  (contentType textHTML >=> closeHeaders >=> notFound)
  -- Resources:
  (resource home <|> resource about)
    where
      home = { path: []
             , "GET":
               handler
               (contentType textHTML
                >=> closeHeaders
                >=> html do
                  h1 (text "Welcome!")
                  p do
                    text "Read more at "
                    -- Type-safe routing:
                    linkTo about (text "About")
                    text "."
               )
             , "POST": notSupported
             }
      about = { path: ["about"]
              , "GET": handler
                (contentType textHTML
                 >=> closeHeaders
                 >=> html do
                   h1 (text "About")
                   p (text "OK, about this example..."))
              , "POST": notSupported
              }

main :: forall e. Eff (http :: HTTP, console :: CONSOLE, err :: EXCEPTION, avar :: AVAR | e) Unit
main =
  let
    -- Some nice console printing when the server starts, and if a request
    -- fails (in this case when the request body is unreadable for some reason).
    onListening (Port port) = log ("Listening on http://localhost:" <> show port)
    onRequestError err = log ("Request failed: " <> show err)

  -- Let's run it.
  in runServer defaultOptions onListening onRequestError app


Tidy up example

Tidy up example

module Example.Ajax where

import Data.Void
import Data.Tuple
import Data.Maybe
import Data.Either
import Data.Foldable (foldMap)

import qualified Data.String as S

import qualified Data.StrMap as StrMap

import Control.Functor (($>))
import Control.Monad.Eff

import DOM

import Halogen
import Halogen.Signal

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as A
import qualified Halogen.HTML.Events.Forms as A
import qualified Halogen.HTML.Events.Handler as E

import qualified Halogen.Themes.Bootstrap3 as B

foreign import data HTTP :: !

exampleCode :: String
exampleCode = S.joinWith "\n"
  [ "module Main where"
  , ""
  , "fact :: Number -> Number"
  , "fact 0 = 1"
  , "fact n = n * fact (n - 1)"
  ]

foreign import appendToBody
  "function appendToBody(node) {\
  \  return function() {\
  \    document.body.appendChild(node);\
  \  };\
  \}" :: forall eff. Node -> Eff (dom :: DOM | eff) Node

foreign import compile
  "function compile(code) {\
  \  return function(k) {\
  \    return function() {\
  \      var xhr = new XMLHttpRequest();\
  \      xhr.onreadystatechange = function(){\
  \        if (xhr.readyState === 4) {\
  \          k(xhr.responseText)();\
  \        }\
  \      };\
  \      xhr.open('POST', 'http://try.purescript.org/compile/text', true);\
  \      xhr.send(code);\
  \    };\
  \  };\
  \}" :: forall eff. String -> (String -> Eff (http :: HTTP | eff) Unit) -> Eff (http :: HTTP | eff) Unit

-- | The state of the application
data State = State Boolean String (Maybe String)

-- | Inputs to the state machine
data Input
  = SetBusy
  | SetCode String
  | SetResult String

-- | Requests to external services
data Request = CompileRequest String

ui :: forall eff a. SF1 Input (H.HTML a (Either Input Request))
ui = view <$> stateful (State false exampleCode Nothing) update
  where
  view :: State -> H.HTML a (Either Input Request)
  view (State busy code result) =
    H.div (A.class_ B.container) $
          [ H.h1 (A.id_ "header") [ H.text "ajax example" ]
          , H.h2_ [ H.text "purescript code" ]
          , H.p_ [ H.textarea (A.class_ B.formControl
                               <> A.value code
                               <> A.onInput (pure <<< Left <<< SetCode)
                               <> A.style (StrMap.fromList [ Tuple "font-family" "monospace"
                                                           , Tuple "height" "200px"
                                                           ])
                              ) [] ]
          , H.p_ [ H.button (A.classes [B.btn, B.btnPrimary] <> A.disabled busy <> A.onclick (\_ -> pure (Right (CompileRequest code)))) [ H.text "Compile" ] ]
          , H.p_ [ H.text (if busy then "Working..." else "") ]
          ] ++ flip foldMap result \js ->
          [ H.h2_ [ H.text "compiled javascript" ]
          , H.pre_ [ H.code_ [ H.text js ] ]
          ]

  update :: State -> Input -> State
  update (State _ code rslt) SetBusy = State true code rslt
  update (State busy _ _) (SetCode code) = State busy code Nothing
  update (State busy code _) (SetResult rslt) = State false code (Just rslt)

-- | Handle a request to an external service
handleRequest :: forall eff. Handler Request Input (http :: HTTP | eff)
handleRequest (CompileRequest code) k = do
  k SetBusy
  compile code \response -> do
    k (SetResult response)

main = do
  Tuple node driver <- runUIEff ui absurd handleRequest
  appendToBody node

module Example.Ajax where

import Data.Void
import Data.Tuple
import Data.Maybe
import Data.Either

import Control.Functor (($>))
import Control.Monad.Eff

import DOM

import Halogen
import Halogen.Signal

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as A
import qualified Halogen.HTML.Events.Forms as A
import qualified Halogen.HTML.Events.Handler as E

import qualified Halogen.Themes.Bootstrap3 as B

foreign import data HTTP :: !

foreign import appendToBody
  "function appendToBody(node) {\
  \  return function() {\
  \    document.body.appendChild(node);\
  \  };\
  \}" :: forall eff. Node -> Eff (dom :: DOM | eff) Node

foreign import compile
  "function compile(code) {\
  \  return function(k) {\
  \    return function() {\
  \      var xhr = new XMLHttpRequest();\
  \      xhr.onreadystatechange = function(){\
  \        if (xhr.readyState === 4 && xhr.status === 200) {\
  \          k(xhr.responseText)();\
  \        }\
  \      };\
  \      xhr.open('POST', 'http://try.purescript.org/compile/text', true);\
  \      xhr.send(code);\
  \    };\
  \  };\
  \}" :: forall eff. String -> (String -> Eff (http :: HTTP | eff) Unit) -> Eff (http :: HTTP | eff) Unit

-- | The state of the application
data State = State Boolean String String

-- | Inputs to the state machine
data Input
  = SetBusy
  | SetCode String
  | SetResult String

-- | Requests to external services
data Request = CompileRequest String

ui :: forall eff a. SF1 Input (H.HTML a (Either Input Request))
ui = view <$> stateful (State false "" "") update
  where
  view :: State -> H.HTML a (Either Input Request)
  view (State busy code result) =
    H.div (A.class_ B.container)
          [ H.h1 (A.id_ "header") [ H.text "ajax example" ]
          , H.h2_ [ H.text "purescript code" ]
          , H.p_ [ H.textarea (A.class_ B.formControl <> A.value code <> A.onInput (pure <<< Left <<< SetCode)) [] ]
          , H.p_ [ H.button (A.classes [B.btn, B.btnPrimary] <> A.disabled busy <> A.onclick (\_ -> pure (Right (CompileRequest code)))) [ H.text "Compile" ] ]
          , H.p_ [ H.text (if busy then "Working..." else "") ]
          , H.h2_ [ H.text "compiled javascript" ]
          , H.pre_ [ H.code_ [ H.text result ] ]
          ]

  update :: State -> Input -> State
  update (State _ code rslt) SetBusy = State true code rslt
  update (State busy _ rslt) (SetCode code) = State busy code rslt
  update (State busy code _) (SetResult rslt) = State false code rslt

-- | Handle a request to an external service
handleRequest :: forall eff. Handler Request Input (http :: HTTP | eff)
handleRequest (CompileRequest code) k = do
  k SetBusy
  compile code \response -> do
    k (SetResult response)

main = do
  Tuple node driver <- runUIEff ui absurd handleRequest
  appendToBody node


Use ReaderT to illustrate custom monads

Use ReaderT to illustrate custom monads

module Main where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (ExceptT)
import Control.Monad.Reader (ReaderT, ask)
import Control.Monad.Reader.Trans (runReaderT)
import Data.Argonaut (class EncodeJson, Json, jsonEmptyObject, (:=), (~>))
import Data.Array (find, (..))
import Data.Generic (class Generic)
import Data.Maybe (Maybe(..), maybe)
import Data.MediaType.Common (textHTML)
import Hyper.Core (Port(Port), closeHeaders, writeStatus)
import Hyper.HTML (HTML, asString, element_, h1, li, linkTo, p, text, ul)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Response (contentType, respond)
import Hyper.Routing.ContentType (class MimeRender)
import Hyper.Routing.TypeLevelRouter (type (:/), type (:<|>), type (:>), Capture, RoutingError(..), linksTo, router, (:<|>))
import Hyper.Routing.TypeLevelRouter.Method (Get)
import Hyper.Status (statusNotFound)
import Node.Buffer (BUFFER)
import Node.HTTP (HTTP)
import Type.Proxy (Proxy(..))

type PostID = Int

newtype Post = Post { id :: PostID
                    , title :: String
                    }

derive instance genericPost :: Generic Post

instance encodePost :: EncodeJson Post where
  encodeJson (Post { id, title }) =
    "id" := id
    ~> "title" := title
    ~> jsonEmptyObject

instance mimeRenderPost :: MimeRender Post HTML String where
  mimeRender _ (Post { id: postId, title}) =
    case linksTo site of
      allPostsUri :<|> _ :<|> _ ->
        asString $
        element_ "section" [ h1 [] [ text title ]
                           , p [] [ text "Contents..." ]
                           , element_ "nav" [ linkTo allPostsUri [ text "All Posts" ]]
                           ]

newtype PostsView = PostsView (Array Post)

instance mimeRenderPostsView :: MimeRender PostsView HTML String where
  mimeRender _ (PostsView posts) =
    case linksTo site of
      _ :<|> getPostUri :<|> postsJsonUri ->
        let postLink (Post { id: postId, title }) =
              li [] [linkTo (getPostUri postId) [ text title ]]
        in asString $
           element_ "section" [ h1 [] [ text "Posts" ]
                              , ul [] (map postLink posts)
                              , p [] [ text "Get posts as "
                                     , linkTo postsJsonUri [ text "JSON" ]
                                     ]
                              ]

type Site = Get HTML PostsView
            :<|> "posts" :/ Capture "id" PostID :> Get HTML Post
            :<|> "posts.json" :/ Get Json (Array Post)

site :: Proxy Site
site = Proxy

-- Simple handlers that can access available posts in
-- the Reader monad (would likely be a database query in
-- a real app):

type AppM e a = ExceptT RoutingError (ReaderT (Array Post) (Aff e)) a

allPosts :: forall e. AppM e (Array Post)
allPosts = ask

postsView :: forall e. AppM e PostsView
postsView = PostsView <$> ask

viewPost :: forall e. PostID -> AppM e Post
viewPost postId =
  find (\(Post p) -> p.id == postId) <$> ask >>=
  case _ of
    Just post -> pure post
    -- You can throw 404 Not Found in here as well.
    Nothing -> throwError (HTTPError { status: statusNotFound
                                     , message: Just "Post not found."
                                     })

main :: forall e. Eff (http :: HTTP, console :: CONSOLE, err :: EXCEPTION, avar :: AVAR, buffer :: BUFFER | e) Unit
main =
  runServer defaultOptions onListening onRequestError {} (siteRouter >>> flip runReaderT posts)
  where
    posts = (map (\i -> Post { id: i, title: "Post #" <> show i }) (1..10))

    siteRouter = router site (postsView :<|> viewPost :<|> allPosts) onRoutingError

    onListening (Port port) = log ("Listening on http://localhost:" <> show port)
    onRequestError err = log ("Request failed: " <> show err)

    onRoutingError status msg =
      writeStatus status
      >=> contentType textHTML
      >=> closeHeaders
      >=> respond (maybe "" id msg)

module Main where

import Prelude
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Except (ExceptT)
import Data.Argonaut (class EncodeJson, Json, jsonEmptyObject, (:=), (~>))
import Data.Array (find, (..))
import Data.Generic (class Generic)
import Data.Maybe (Maybe(..), maybe)
import Data.MediaType.Common (textHTML)
import Hyper.Core (Port(Port), closeHeaders, writeStatus)
import Hyper.HTML (HTML, asString, element_, h1, li, linkTo, p, text, ul)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Response (contentType, respond)
import Hyper.Routing.ContentType (class MimeRender)
import Hyper.Routing.TypeLevelRouter (type (:/), type (:<|>), type (:>), Capture, RoutingError(..), linksTo, router, (:<|>))
import Hyper.Routing.TypeLevelRouter.Method (Get)
import Hyper.Status (statusNotFound)
import Node.Buffer (BUFFER)
import Node.HTTP (HTTP)
import Type.Proxy (Proxy(..))

type PostID = Int

newtype Post = Post { id :: PostID
                    , title :: String
                    }

derive instance genericPost :: Generic Post

instance encodePost :: EncodeJson Post where
  encodeJson (Post { id, title }) =
    "id" := id
    ~> "title" := title
    ~> jsonEmptyObject

instance mimeRenderPost :: MimeRender Post HTML String where
  mimeRender _ (Post { id: postId, title}) =
    case linksTo site of
      allPostsUri :<|> _ :<|> _ ->
        asString $
        element_ "section" [ h1 [] [ text title ]
                           , p [] [ text "Contents..." ]
                           , element_ "nav" [ linkTo allPostsUri [ text "All Posts" ]]
                           ]

newtype PostsView = PostsView (Array Post)

instance mimeRenderPostsView :: MimeRender PostsView HTML String where
  mimeRender _ (PostsView posts) =
    case linksTo site of
      _ :<|> getPostUri :<|> postsJsonUri ->
        let postLink (Post { id: postId, title }) =
              li [] [linkTo (getPostUri postId) [ text title ]]
        in asString $
           element_ "section" [ h1 [] [ text "Posts" ]
                              , ul [] (map postLink posts)
                              , p [] [ text "Get posts as "
                                     , linkTo postsJsonUri [ text "JSON" ]
                                     ]
                              ]

type Site = Get HTML PostsView
            :<|> "posts" :/ Capture "id" PostID :> Get HTML Post
            :<|> "posts.json" :/ Get Json (Array Post)

site :: Proxy Site
site = Proxy

-- Simple handlers that are given all available posts
-- (would be a database in a real app):

allPosts :: forall m. Monad m =>
            Array Post
         -> ExceptT RoutingError m (Array Post)
allPosts = pure

postsView :: forall m. Monad m =>
             Array Post
          -> ExceptT RoutingError m PostsView
postsView = pure <<< PostsView

viewPost :: forall m. Monad m =>
            Array Post
         -> PostID
         -> ExceptT RoutingError m Post
viewPost posts postId = do
  case find (\(Post p) -> p.id == postId) posts of
    Just post -> pure post
    -- You can throw 404 Not Found in here as well.
    Nothing -> throwError (HTTPError { status: statusNotFound
                                     , message: Just "Post not found."
                                     })

main :: forall e. Eff (http :: HTTP, console :: CONSOLE, err :: EXCEPTION, avar :: AVAR, buffer :: BUFFER | e) Unit
main =
  runServer defaultOptions onListening onRequestError {} siteRouter
  where
    posts = (map (\i -> Post { id: i, title: "Post #" <> show i }) (1..10))

    siteRouter = router site (postsView posts :<|> viewPost posts :<|> allPosts posts) onRoutingError

    onListening (Port port) = log ("Listening on http://localhost:" <> show port)
    onRequestError err = log ("Request failed: " <> show err)

    onRoutingError status msg =
      writeStatus status
      >=> contentType textHTML
      >=> closeHeaders
      >=> respond (maybe "" id msg)