Fix tests

Fix tests

module Test.Data.Map where

import Prelude
import Data.List.NonEmpty as NEL
import Data.Map as M
import Control.Alt ((<|>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Data.NonEmpty ((:|))
import Data.Foldable (foldl, for_, all)
import Data.Function (on)
import Data.List (List(Cons), groupBy, length, nubBy, singleton, sort, sortBy)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Test.QuickCheck ((<?>), (===), quickCheck, quickCheck')
import Test.QuickCheck.Gen (elements, oneOf)
import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary)

newtype TestMap k v = TestMap (M.Map k v)

instance arbTestMap :: (Eq k, Ord k, Arbitrary k, Arbitrary v) => Arbitrary (TestMap k v) where
  arbitrary = TestMap <<< (M.fromFoldable :: List (Tuple k v) -> M.Map k v) <$> arbitrary

data SmallKey = A | B | C | D | E | F | G | H | I | J
derive instance eqSmallKey :: Eq SmallKey
derive instance ordSmallKey :: Ord SmallKey

instance showSmallKey :: Show SmallKey where
  show A = "A"
  show B = "B"
  show C = "C"
  show D = "D"
  show E = "E"
  show F = "F"
  show G = "G"
  show H = "H"
  show I = "I"
  show J = "J"

instance arbSmallKey :: Arbitrary SmallKey where
  arbitrary = elements $ A :| [B, C, D, E, F, G, H, I, J]

data Instruction k v = Insert k v | Delete k

instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where
  show (Insert k v) = "Insert (" <> show k <> ") (" <> show v <> ")"
  show (Delete k) = "Delete (" <> show k <> ")"

instance arbInstruction :: (Arbitrary k, Arbitrary v) => Arbitrary (Instruction k v) where
  arbitrary = oneOf $ (Insert <$> arbitrary <*> arbitrary) :| [Delete <$> arbitrary]

runInstructions :: forall k v. Ord k => List (Instruction k v) -> M.Map k v -> M.Map k v
runInstructions instrs t0 = foldl step t0 instrs
  where
  step tree (Insert k v) = M.insert k v tree
  step tree (Delete k) = M.delete k tree

smallKey :: SmallKey -> SmallKey
smallKey k = k

number :: Int -> Int
number n = n

smallKeyToNumberMap :: M.Map SmallKey Int -> M.Map SmallKey Int
smallKeyToNumberMap m = m

mapTests :: forall eff. Eff (console :: CONSOLE, random :: RANDOM, exception :: EXCEPTION | eff) Unit
mapTests = do

  -- Data.Map

  log "Test inserting into empty tree"
  quickCheck $ \k v -> M.lookup (smallKey k) (M.insert k v M.empty) == Just (number v)
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Test inserting two values with same key"
  quickCheck $ \k v1 v2 ->
    M.lookup (smallKey k) (M.insert k v2 (M.insert k v1 M.empty)) == Just (number v2)

  log "Test delete after inserting"
  quickCheck $ \k v -> M.isEmpty (M.delete (smallKey k) (M.insert k (number v) M.empty))
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Test pop after inserting"
  quickCheck $ \k v -> M.pop (smallKey k) (M.insert k (number v) M.empty) == Just (Tuple v M.empty)
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Pop non-existent key"
  quickCheck $ \k1 k2 v -> k1 == k2 || M.pop (smallKey k2) (M.insert k1 (number v) M.empty) == Nothing
    <?> ("k1: " <> show k1 <> ", k2: " <> show k2 <> ", v: " <> show v)

  log "Insert two, lookup first"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v1
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, lookup second"
  quickCheck $ \k1 v1 k2 v2 -> M.lookup k2 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, delete one"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k2 (M.delete k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty))) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Check balance property"
  quickCheck' 1000 $ \instrs ->
    let
      tree :: M.Map SmallKey Int
      tree = runInstructions instrs M.empty
    in M.checkValid tree <?> ("Map not balanced:\n  " <> show tree <> "\nGenerated by:\n  " <> show instrs)

  log "Lookup from empty"
  quickCheck $ \k -> M.lookup k (M.empty :: M.Map SmallKey Int) == Nothing

  log "Lookup from singleton"
  quickCheck $ \k v -> M.lookup (k :: SmallKey) (M.singleton k (v :: Int)) == Just v

  log "Random lookup"
  quickCheck' 1000 $ \instrs k v ->
    let
      tree :: M.Map SmallKey Int
      tree = M.insert k v (runInstructions instrs M.empty)
    in M.lookup k tree == Just v <?> ("instrs:\n  " <> show instrs <> "\nk:\n  " <> show k <> "\nv:\n  " <> show v)

  log "Singleton to list"
  quickCheck $ \k v -> M.toUnfoldable (M.singleton k v :: M.Map SmallKey Int) == singleton (Tuple k v)

  log "fromFoldable [] = empty"
  quickCheck (M.fromFoldable [] == (M.empty :: M.Map Unit Unit)
    <?> "was not empty")

  log "fromFoldable & key collision"
  do
    let nums = M.fromFoldable [Tuple 0 "zero", Tuple 1 "what", Tuple 1 "one"]
    quickCheck (M.lookup 0 nums == Just "zero" <?> "invalid lookup - 0")
    quickCheck (M.lookup 1 nums == Just "one"  <?> "invalid lookup - 1")
    quickCheck (M.lookup 2 nums == Nothing     <?> "invalid lookup - 2")

  log "fromFoldableWith const [] = empty"
  quickCheck (M.fromFoldableWith const [] == (M.empty :: M.Map Unit Unit)
    <?> "was not empty")

  log "fromFoldableWith (+) & key collision"
  do
    let nums = M.fromFoldableWith (+) [Tuple 0 1, Tuple 1 1, Tuple 1 1]
    quickCheck (M.lookup 0 nums == Just 1  <?> "invalid lookup - 0")
    quickCheck (M.lookup 1 nums == Just 2  <?> "invalid lookup - 1")
    quickCheck (M.lookup 2 nums == Nothing <?> "invalid lookup - 2")

  log "sort . toUnfoldable . fromFoldable = sort (on lists without key-duplicates)"
  quickCheck $ \(list :: List (Tuple SmallKey Int)) ->
    let nubbedList = nubBy ((==) `on` fst) list
        f x = M.toUnfoldable (M.fromFoldable x)
    in sort (f nubbedList) == sort nubbedList <?> show nubbedList

  log "fromFoldable . toUnfoldable = id"
  quickCheck $ \(TestMap (m :: M.Map SmallKey Int)) ->
    let f m' = M.fromFoldable (M.toUnfoldable m' :: List (Tuple SmallKey Int))
    in f m == m <?> show m

  log "fromFoldableWith const = fromFoldable"
  quickCheck $ \arr ->
    M.fromFoldableWith const arr ==
    M.fromFoldable (arr :: List (Tuple SmallKey Int)) <?> show arr

  log "fromFoldableWith (<>) = fromFoldable . collapse with (<>) . group on fst"
  quickCheck $ \arr ->
    let combine (Tuple s a) (Tuple t b) = (Tuple s $ b <> a)
        foldl1 g = unsafePartial \(Cons x xs) -> foldl g x xs
        f = M.fromFoldable <<< map (foldl1 combine <<< NEL.toList) <<<
            groupBy ((==) `on` fst) <<< sortBy (compare `on` fst) in
    M.fromFoldableWith (<>) arr === f (arr :: List (Tuple String String))

  log "toAscUnfoldable is sorted version of toUnfoldable"
  quickCheck $ \(TestMap m) ->
    let list = M.toUnfoldable (m :: M.Map SmallKey Int)
        ascList = M.toAscUnfoldable m
    in ascList === sortBy (compare `on` fst) list

  log "Lookup from union"
  quickCheck $ \(TestMap m1) (TestMap m2) k ->
    M.lookup (smallKey k) (M.union m1 m2) == (case M.lookup k m1 of
      Nothing -> M.lookup k m2
      Just v -> Just (number v)) <?> ("m1: " <> show m1 <> ", m2: " <> show m2 <> ", k: " <> show k <> ", v1: " <> show (M.lookup k m1) <> ", v2: " <> show (M.lookup k m2) <> ", union: " <> show (M.union m1 m2))

  log "Union is idempotent"
  quickCheck $ \(TestMap m1) (TestMap m2) -> (m1 `M.union` m2) == ((m1 `M.union` m2) `M.union` (m2 :: M.Map SmallKey Int))

  log "Union prefers left"
  quickCheck $ \(TestMap m1) (TestMap m2) k -> M.lookup k (M.union m1 (m2 :: M.Map SmallKey Int)) == (M.lookup k m1 <|> M.lookup k m2)

  log "unionWith"
  for_ [Tuple (+) 0, Tuple (*) 1] $ \(Tuple op ident) ->
    quickCheck $ \(TestMap m1) (TestMap m2) k ->
      let u = M.unionWith op m1 m2 :: M.Map SmallKey Int
      in case M.lookup k u of
           Nothing -> not (M.member k m1 || M.member k m2)
           Just v -> v == op (fromMaybe ident (M.lookup k m1)) (fromMaybe ident (M.lookup k m2))

  log "unionWith argument order"
  quickCheck $ \(TestMap m1) (TestMap m2) k ->
    let u   = M.unionWith (-) m1 m2 :: M.Map SmallKey Int
        in1 = M.member k m1
        v1  = M.lookup k m1
        in2 = M.member k m2
        v2  = M.lookup k m2
    in case M.lookup k u of
          Just v | in1 && in2 -> Just v == ((-) <$> v1 <*> v2)
          Just v | in1        -> Just v == v1
          Just v              -> Just v == v2
          Nothing             -> not (in1 || in2)

  log "size"
  quickCheck $ \xs ->
    let xs' = nubBy ((==) `on` fst) xs
    in  M.size (M.fromFoldable xs') == length (xs' :: List (Tuple SmallKey Int))

  log "lookupLE result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupLE k (smallKeyToNumberMap m) of
    Nothing -> all (_ > k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k1 < k2 && k2 < k
      isLTwhenEQexists = k1 < k && M.member k m
      in   k1 <= k
        && all (not <<< isCloserKey) (M.keys m)
        && not isLTwhenEQexists
        && M.lookup k1 m == Just v

  log "lookupGE result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupGE k (smallKeyToNumberMap m) of
    Nothing -> all (_ < k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k < k2 && k2 < k1
      isGTwhenEQexists = k < k1 && M.member k m
      in   k1 >= k
        && all (not <<< isCloserKey) (M.keys m)
        && not isGTwhenEQexists
        && M.lookup k1 m == Just v

  log "lookupLT result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupLT k (smallKeyToNumberMap m) of
    Nothing -> all (_ >= k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k1 < k2 && k2 < k
      in   k1 < k
        && all (not <<< isCloserKey) (M.keys m)
        && M.lookup k1 m == Just v

  log "lookupGT result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupGT k (smallKeyToNumberMap m) of
    Nothing -> all (_ <= k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k < k2 && k2 < k1
      in   k1 > k
        && all (not <<< isCloserKey) (M.keys m)
        && M.lookup k1 m == Just v

  log "findMin result is correct"
  quickCheck $ \(TestMap m) -> case M.findMin (smallKeyToNumberMap m) of
    Nothing -> M.isEmpty m
    Just { key: k, value: v } -> M.lookup k m == Just v && all (_ >= k) (M.keys m)

  log "findMax result is correct"
  quickCheck $ \(TestMap m) -> case M.findMax (smallKeyToNumberMap m) of
    Nothing -> M.isEmpty m
    Just { key: k, value: v } -> M.lookup k m == Just v && all (_ <= k) (M.keys m)

  log "mapWithKey is correct"
  quickCheck $ \(TestMap m :: TestMap String Int) -> let
    f k v = k <> show v
    resultViaMapWithKey = m # M.mapWithKey f
    toList = M.toUnfoldable :: forall k v. M.Map k v -> List (Tuple k v)
    resultViaLists = m # toList # map (\(Tuple k v) → Tuple k (f k v)) # M.fromFoldable
    in resultViaMapWithKey === resultViaLists

module Test.Data.Map where

import Prelude
import Data.List.NonEmpty as NEL
import Data.Map as M
import Control.Alt ((<|>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Data.Foldable (foldl, for_, all)
import Data.Function (on)
import Data.List (List(Cons), groupBy, length, nubBy, singleton, sort, sortBy)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..), fst)
import Partial.Unsafe (unsafePartial)
import Test.QuickCheck ((<?>), (===), quickCheck, quickCheck')
import Test.QuickCheck.Gen (elements, oneOf)
import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary)

newtype TestMap k v = TestMap (M.Map k v)

instance arbTestMap :: (Eq k, Ord k, Arbitrary k, Arbitrary v) => Arbitrary (TestMap k v) where
  arbitrary = TestMap <<< (M.fromFoldable :: List (Tuple k v) -> M.Map k v) <$> arbitrary

data SmallKey = A | B | C | D | E | F | G | H | I | J
derive instance eqSmallKey :: Eq SmallKey
derive instance ordSmallKey :: Ord SmallKey

instance showSmallKey :: Show SmallKey where
  show A = "A"
  show B = "B"
  show C = "C"
  show D = "D"
  show E = "E"
  show F = "F"
  show G = "G"
  show H = "H"
  show I = "I"
  show J = "J"

instance arbSmallKey :: Arbitrary SmallKey where
  arbitrary = elements A [B, C, D, E, F, G, H, I, J]

data Instruction k v = Insert k v | Delete k

instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where
  show (Insert k v) = "Insert (" <> show k <> ") (" <> show v <> ")"
  show (Delete k) = "Delete (" <> show k <> ")"

instance arbInstruction :: (Arbitrary k, Arbitrary v) => Arbitrary (Instruction k v) where
  arbitrary = oneOf (Insert <$> arbitrary <*> arbitrary) [Delete <$> arbitrary]

runInstructions :: forall k v. Ord k => List (Instruction k v) -> M.Map k v -> M.Map k v
runInstructions instrs t0 = foldl step t0 instrs
  where
  step tree (Insert k v) = M.insert k v tree
  step tree (Delete k) = M.delete k tree

smallKey :: SmallKey -> SmallKey
smallKey k = k

number :: Int -> Int
number n = n

smallKeyToNumberMap :: M.Map SmallKey Int -> M.Map SmallKey Int
smallKeyToNumberMap m = m

mapTests :: forall eff. Eff (console :: CONSOLE, random :: RANDOM, exception :: EXCEPTION | eff) Unit
mapTests = do

  -- Data.Map

  log "Test inserting into empty tree"
  quickCheck $ \k v -> M.lookup (smallKey k) (M.insert k v M.empty) == Just (number v)
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Test inserting two values with same key"
  quickCheck $ \k v1 v2 ->
    M.lookup (smallKey k) (M.insert k v2 (M.insert k v1 M.empty)) == Just (number v2)

  log "Test delete after inserting"
  quickCheck $ \k v -> M.isEmpty (M.delete (smallKey k) (M.insert k (number v) M.empty))
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Test pop after inserting"
  quickCheck $ \k v -> M.pop (smallKey k) (M.insert k (number v) M.empty) == Just (Tuple v M.empty)
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Pop non-existent key"
  quickCheck $ \k1 k2 v -> k1 == k2 || M.pop (smallKey k2) (M.insert k1 (number v) M.empty) == Nothing
    <?> ("k1: " <> show k1 <> ", k2: " <> show k2 <> ", v: " <> show v)

  log "Insert two, lookup first"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v1
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, lookup second"
  quickCheck $ \k1 v1 k2 v2 -> M.lookup k2 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty)) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, delete one"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k2 (M.delete k1 (M.insert (smallKey k2) (number v2) (M.insert (smallKey k1) (number v1) M.empty))) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Check balance property"
  quickCheck' 1000 $ \instrs ->
    let
      tree :: M.Map SmallKey Int
      tree = runInstructions instrs M.empty
    in M.checkValid tree <?> ("Map not balanced:\n  " <> show tree <> "\nGenerated by:\n  " <> show instrs)

  log "Lookup from empty"
  quickCheck $ \k -> M.lookup k (M.empty :: M.Map SmallKey Int) == Nothing

  log "Lookup from singleton"
  quickCheck $ \k v -> M.lookup (k :: SmallKey) (M.singleton k (v :: Int)) == Just v

  log "Random lookup"
  quickCheck' 1000 $ \instrs k v ->
    let
      tree :: M.Map SmallKey Int
      tree = M.insert k v (runInstructions instrs M.empty)
    in M.lookup k tree == Just v <?> ("instrs:\n  " <> show instrs <> "\nk:\n  " <> show k <> "\nv:\n  " <> show v)

  log "Singleton to list"
  quickCheck $ \k v -> M.toUnfoldable (M.singleton k v :: M.Map SmallKey Int) == singleton (Tuple k v)

  log "fromFoldable [] = empty"
  quickCheck (M.fromFoldable [] == (M.empty :: M.Map Unit Unit)
    <?> "was not empty")

  log "fromFoldable & key collision"
  do
    let nums = M.fromFoldable [Tuple 0 "zero", Tuple 1 "what", Tuple 1 "one"]
    quickCheck (M.lookup 0 nums == Just "zero" <?> "invalid lookup - 0")
    quickCheck (M.lookup 1 nums == Just "one"  <?> "invalid lookup - 1")
    quickCheck (M.lookup 2 nums == Nothing     <?> "invalid lookup - 2")

  log "fromFoldableWith const [] = empty"
  quickCheck (M.fromFoldableWith const [] == (M.empty :: M.Map Unit Unit)
    <?> "was not empty")

  log "fromFoldableWith (+) & key collision"
  do
    let nums = M.fromFoldableWith (+) [Tuple 0 1, Tuple 1 1, Tuple 1 1]
    quickCheck (M.lookup 0 nums == Just 1  <?> "invalid lookup - 0")
    quickCheck (M.lookup 1 nums == Just 2  <?> "invalid lookup - 1")
    quickCheck (M.lookup 2 nums == Nothing <?> "invalid lookup - 2")

  log "sort . toUnfoldable . fromFoldable = sort (on lists without key-duplicates)"
  quickCheck $ \(list :: List (Tuple SmallKey Int)) ->
    let nubbedList = nubBy ((==) `on` fst) list
        f x = M.toUnfoldable (M.fromFoldable x)
    in sort (f nubbedList) == sort nubbedList <?> show nubbedList

  log "fromFoldable . toUnfoldable = id"
  quickCheck $ \(TestMap (m :: M.Map SmallKey Int)) ->
    let f m' = M.fromFoldable (M.toUnfoldable m' :: List (Tuple SmallKey Int))
    in f m == m <?> show m

  log "fromFoldableWith const = fromFoldable"
  quickCheck $ \arr ->
    M.fromFoldableWith const arr ==
    M.fromFoldable (arr :: List (Tuple SmallKey Int)) <?> show arr

  log "fromFoldableWith (<>) = fromFoldable . collapse with (<>) . group on fst"
  quickCheck $ \arr ->
    let combine (Tuple s a) (Tuple t b) = (Tuple s $ b <> a)
        foldl1 g = unsafePartial \(Cons x xs) -> foldl g x xs
        f = M.fromFoldable <<< map (foldl1 combine <<< NEL.toList) <<<
            groupBy ((==) `on` fst) <<< sortBy (compare `on` fst) in
    M.fromFoldableWith (<>) arr === f (arr :: List (Tuple String String))

  log "toAscUnfoldable is sorted version of toUnfoldable"
  quickCheck $ \(TestMap m) ->
    let list = M.toUnfoldable (m :: M.Map SmallKey Int)
        ascList = M.toAscUnfoldable m
    in ascList === sortBy (compare `on` fst) list

  log "Lookup from union"
  quickCheck $ \(TestMap m1) (TestMap m2) k ->
    M.lookup (smallKey k) (M.union m1 m2) == (case M.lookup k m1 of
      Nothing -> M.lookup k m2
      Just v -> Just (number v)) <?> ("m1: " <> show m1 <> ", m2: " <> show m2 <> ", k: " <> show k <> ", v1: " <> show (M.lookup k m1) <> ", v2: " <> show (M.lookup k m2) <> ", union: " <> show (M.union m1 m2))

  log "Union is idempotent"
  quickCheck $ \(TestMap m1) (TestMap m2) -> (m1 `M.union` m2) == ((m1 `M.union` m2) `M.union` (m2 :: M.Map SmallKey Int))

  log "Union prefers left"
  quickCheck $ \(TestMap m1) (TestMap m2) k -> M.lookup k (M.union m1 (m2 :: M.Map SmallKey Int)) == (M.lookup k m1 <|> M.lookup k m2)

  log "unionWith"
  for_ [Tuple (+) 0, Tuple (*) 1] $ \(Tuple op ident) ->
    quickCheck $ \(TestMap m1) (TestMap m2) k ->
      let u = M.unionWith op m1 m2 :: M.Map SmallKey Int
      in case M.lookup k u of
           Nothing -> not (M.member k m1 || M.member k m2)
           Just v -> v == op (fromMaybe ident (M.lookup k m1)) (fromMaybe ident (M.lookup k m2))

  log "unionWith argument order"
  quickCheck $ \(TestMap m1) (TestMap m2) k ->
    let u   = M.unionWith (-) m1 m2 :: M.Map SmallKey Int
        in1 = M.member k m1
        v1  = M.lookup k m1
        in2 = M.member k m2
        v2  = M.lookup k m2
    in case M.lookup k u of
          Just v | in1 && in2 -> Just v == ((-) <$> v1 <*> v2)
          Just v | in1        -> Just v == v1
          Just v              -> Just v == v2
          Nothing             -> not (in1 || in2)

  log "size"
  quickCheck $ \xs ->
    let xs' = nubBy ((==) `on` fst) xs
    in  M.size (M.fromFoldable xs') == length (xs' :: List (Tuple SmallKey Int))

  log "lookupLE result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupLE k (smallKeyToNumberMap m) of
    Nothing -> all (_ > k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k1 < k2 && k2 < k
      isLTwhenEQexists = k1 < k && M.member k m
      in   k1 <= k
        && all (not <<< isCloserKey) (M.keys m)
        && not isLTwhenEQexists
        && M.lookup k1 m == Just v

  log "lookupGE result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupGE k (smallKeyToNumberMap m) of
    Nothing -> all (_ < k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k < k2 && k2 < k1
      isGTwhenEQexists = k < k1 && M.member k m
      in   k1 >= k
        && all (not <<< isCloserKey) (M.keys m)
        && not isGTwhenEQexists
        && M.lookup k1 m == Just v

  log "lookupLT result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupLT k (smallKeyToNumberMap m) of
    Nothing -> all (_ >= k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k1 < k2 && k2 < k
      in   k1 < k
        && all (not <<< isCloserKey) (M.keys m)
        && M.lookup k1 m == Just v

  log "lookupGT result is correct"
  quickCheck $ \k (TestMap m) -> case M.lookupGT k (smallKeyToNumberMap m) of
    Nothing -> all (_ <= k) $ M.keys m
    Just { key: k1, value: v } -> let
      isCloserKey k2 = k < k2 && k2 < k1
      in   k1 > k
        && all (not <<< isCloserKey) (M.keys m)
        && M.lookup k1 m == Just v

  log "findMin result is correct"
  quickCheck $ \(TestMap m) -> case M.findMin (smallKeyToNumberMap m) of
    Nothing -> M.isEmpty m
    Just { key: k, value: v } -> M.lookup k m == Just v && all (_ >= k) (M.keys m)

  log "findMax result is correct"
  quickCheck $ \(TestMap m) -> case M.findMax (smallKeyToNumberMap m) of
    Nothing -> M.isEmpty m
    Just { key: k, value: v } -> M.lookup k m == Just v && all (_ <= k) (M.keys m)

  log "mapWithKey is correct"
  quickCheck $ \(TestMap m :: TestMap String Int) -> let
    f k v = k <> show v
    resultViaMapWithKey = m # M.mapWithKey f
    toList = M.toUnfoldable :: forall k v. M.Map k v -> List (Tuple k v)
    resultViaLists = m # toList # map (\(Tuple k v) → Tuple k (f k v)) # M.fromFoldable
    in resultViaMapWithKey === resultViaLists


BUG: Initialize with 0 seeds

BUG: Initialize with 0 seeds

module App.Board where

import App.FixedMatrix72 as FM
import App.FixedMatrix72 (Ref(Ref), Row(..))
import Data.Array ((..), (:))
import Data.Foldable
import Data.Maybe (Maybe(..))
import Prelude (bind, const, flip, pure, (#), ($), (*), (+), (-), (<), (<#>), (<$>), (==), (>=))
import Control.MonadZero (guard)

type Board =
  { cells :: FM.FixedMatrix72 Pit
  , blockedCells :: Array PitRef
  , storeA :: Int
  , storeB :: Int
  }

type Pit = Int
type PitRef = FM.Ref
type Player = FM.Row

initPit :: Pit
initPit = 5

cols :: Int
cols = 7

rowCount :: Int
rowCount = cols * initPit

init' :: Int -> Board
init' perPit =
  { cells: FM.init perPit
  , blockedCells: []
  , storeA: 0
  , storeB: 0
  }

init :: Board
init = init' initPit

initWith' :: Int -> Int -> Int -> Board
initWith' a b perPit =
  init' 0
  # store A a
  # store B b
  # refillPlayer A
  # refillPlayer B
    where refillPlayer player = flip (foldl $ refillPit player) (refs player)
          refillPit player board ref =
            case unstoreToPit ref player perPit board of
              Just board' -> board'
              Nothing -> blockPit ref board

initWith :: Int -> Int -> Board
initWith a b | a < initPit  = initWith' a b 1
             | b < initPit  = initWith' a b 1
             | true         = initWith' a b 5

refs :: Player -> Array PitRef
refs A = FM.makeRef A <$> (cols-1)..0
refs B = FM.makeRef B <$> 0..(cols-1)

opponentOf :: Player -> Player
opponentOf A = B
opponentOf B = A

nextRef :: PitRef -> PitRef
nextRef (Ref { row: A, idx: 0 })   = Ref { row: B, idx: 0 }
nextRef (Ref { row: A, idx: idx }) = Ref { row: A, idx: idx - 1 }
nextRef (Ref { row: B, idx: 6 })   = Ref { row: A, idx: 6 }
nextRef (Ref { row: B, idx: idx }) = Ref { row: B, idx: idx + 1 }

blockPit :: PitRef -> Board -> Board
blockPit ref board = board { blockedCells = ref : board.blockedCells }

lookup :: PitRef -> Board -> Pit
lookup ref board = FM.lookup ref board.cells

mapPit :: forall a. PitRef -> (Pit -> a) -> Board -> a
mapPit ref f board = f $ lookup ref board

mapPit2 :: forall a. PitRef -> (Pit -> Pit -> a) -> Board -> a
mapPit2 ref1 f board = mapPit ref1 g board
  where g pit1 = mapPit (nextRef ref1) (f pit1) board

mapPit3 :: forall a. PitRef -> (Pit -> Pit -> Pit -> a) -> Board -> a
mapPit3 ref1 f board = mapPit ref1 g board
  where g pit1 = mapPit2 (nextRef ref1) (f pit1) board

belongsTo :: PitRef -> Player -> Boolean
belongsTo (Ref { row, idx }) player = row == player

modifyPit :: PitRef -> (Pit -> Pit) -> Board -> Board
modifyPit ref f board = board { cells = cells' }
   where cells' = FM.modify ref f board.cells

clearPit :: PitRef -> Board -> Board
clearPit pitRef = modifyPit pitRef (const 0)

setPit :: PitRef -> Int -> Board -> Board
setPit ref v = modifyPit ref (const v)

-- Move some seeds from a player's store to this pit
unstoreToPit :: PitRef -> Player -> Int -> Board -> Maybe Board
unstoreToPit ref player count board
    = unstore player count board
  <#> setPit ref count

-- Move all seeds from a pit to this player's store
storeFromPit :: Player -> Board -> PitRef -> Board
storeFromPit player board ref =
  board
  # clearPit ref
  # store player seeds
    where seeds = lookup ref board

store :: Player -> Pit -> Board -> Board
store A seeds board = board { storeA = board.storeA + seeds }
store B seeds board = board { storeB = board.storeB + seeds }

unstore :: Player -> Int -> Board -> Maybe Board
unstore A count board = do
  guard $ board.storeA >= count
  pure $ board { storeA = board.storeA - count }
unstore B count board = do
  guard $ board.storeB >= count
  pure $ board { storeA = board.storeB - count }

getStore :: Player -> Board -> Pit
getStore A board = board.storeA
getStore B board = board.storeB

module App.Board where

import App.FixedMatrix72 as FM
import App.FixedMatrix72 (Ref(Ref), Row(..))
import Data.Array ((..), (:))
import Data.Foldable
import Data.Maybe (Maybe(..))
import Prelude (bind, const, flip, pure, (#), ($), (*), (+), (-), (<), (<#>), (<$>), (==), (>=))
import Control.MonadZero (guard)

type Board =
  { cells :: FM.FixedMatrix72 Pit
  , blockedCells :: Array PitRef
  , storeA :: Int
  , storeB :: Int
  }

type Pit = Int
type PitRef = FM.Ref
type Player = FM.Row

initPit :: Pit
initPit = 5

cols :: Int
cols = 7

rowCount :: Int
rowCount = cols * initPit

init :: Board
init =
  { cells: FM.init initPit
  , blockedCells: []
  , storeA: 0
  , storeB: 0
  }

initWith' :: Int -> Int -> Int -> Board
initWith' a b perPit =
  init
  # store A a
  # store B b
  # refillPlayer A
  # refillPlayer B
    where refillPlayer player = flip (foldl $ refillPit player) (refs player)
          refillPit player board ref =
            case unstoreToPit ref player perPit board of
              Just board' -> board'
              Nothing -> blockPit ref board

initWith :: Int -> Int -> Board
initWith a b | a < initPit  = initWith' a b 1
             | b < initPit  = initWith' a b 1
             | true         = initWith' a b 5

refs :: Player -> Array PitRef
refs A = FM.makeRef A <$> (cols-1)..0
refs B = FM.makeRef B <$> 0..(cols-1)

opponentOf :: Player -> Player
opponentOf A = B
opponentOf B = A

nextRef :: PitRef -> PitRef
nextRef (Ref { row: A, idx: 0 })   = Ref { row: B, idx: 0 }
nextRef (Ref { row: A, idx: idx }) = Ref { row: A, idx: idx - 1 }
nextRef (Ref { row: B, idx: 6 })   = Ref { row: A, idx: 6 }
nextRef (Ref { row: B, idx: idx }) = Ref { row: B, idx: idx + 1 }

blockPit :: PitRef -> Board -> Board
blockPit ref board = board { blockedCells = ref : board.blockedCells }

lookup :: PitRef -> Board -> Pit
lookup ref board = FM.lookup ref board.cells

mapPit :: forall a. PitRef -> (Pit -> a) -> Board -> a
mapPit ref f board = f $ lookup ref board

mapPit2 :: forall a. PitRef -> (Pit -> Pit -> a) -> Board -> a
mapPit2 ref1 f board = mapPit ref1 g board
  where g pit1 = mapPit (nextRef ref1) (f pit1) board

mapPit3 :: forall a. PitRef -> (Pit -> Pit -> Pit -> a) -> Board -> a
mapPit3 ref1 f board = mapPit ref1 g board
  where g pit1 = mapPit2 (nextRef ref1) (f pit1) board

belongsTo :: PitRef -> Player -> Boolean
belongsTo (Ref { row, idx }) player = row == player

modifyPit :: PitRef -> (Pit -> Pit) -> Board -> Board
modifyPit ref f board = board { cells = cells' }
   where cells' = FM.modify ref f board.cells

clearPit :: PitRef -> Board -> Board
clearPit pitRef = modifyPit pitRef (const 0)

setPit :: PitRef -> Int -> Board -> Board
setPit ref v = modifyPit ref (const v)

-- Move some seeds from a player's store to this pit
unstoreToPit :: PitRef -> Player -> Int -> Board -> Maybe Board
unstoreToPit ref player count board
    = unstore player count board
  <#> setPit ref count

-- Move all seeds from a pit to this player's store
storeFromPit :: Player -> Board -> PitRef -> Board
storeFromPit player board ref =
  board
  # clearPit ref
  # store player seeds
    where seeds = lookup ref board

store :: Player -> Pit -> Board -> Board
store A seeds board = board { storeA = board.storeA + seeds }
store B seeds board = board { storeB = board.storeB + seeds }

unstore :: Player -> Int -> Board -> Maybe Board
unstore A count board = do
  guard $ board.storeA >= count
  pure $ board { storeA = board.storeA - count }
unstore B count board = do
  guard $ board.storeB >= count
  pure $ board { storeA = board.storeB - count }

getStore :: Player -> Board -> Pit
getStore A board = board.storeA
getStore B board = board.storeB


Switch to setInnerHTML from simple-dom

Switch to setInnerHTML from simple-dom

Signed-off-by: Ricky Elrod <3de8762d49a778edd8b1aa9f381ea5a9ccb62944@elrod.me>

module Main where

import Control.Monad.Eff
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Encode
import Data.DOM.Simple.Events hiding (read)
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Either
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Debug.Trace
import DomHelpers hiding (setInnerHtml)
import GMaps.InfoWindow
import GMaps.LatLng
import GMaps.Map
import GMaps.MapOptions
import GMaps.Marker
import GMaps.MVCArray
import GMaps.Polyline
import MapViewWS
import MomentJS
import WebSocket

setDismissAnnouncement :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) Unit
setDismissAnnouncement doc = do
  -- TODO: Partial
  Just dismissButton <- getElementById "dismiss_announcement" doc
  Just announcement <- getElementById "announcement" doc
  y <- setDisplayFn announcement "none"
  setOnclick dismissButton y

setAnnouncement :: forall eff. HTMLDocument -> String -> String -> Eff (dom :: DOM | eff) Unit
setAnnouncement doc t c = do
  -- TODO: Partial
  Just announcement <- getElementById "announcement" doc
  Just text <- getElementById "announcement_text" doc
  setInnerHTML t text
  setClass announcement c
  setDisplay announcement "block"

foreign import getData
  "function getData(x) {\
  \  return function() {\
  \    return x.data;\
  \  };\
  \}" :: forall eff. Event -> Eff eff String

main = do
  doc <- document globalWindow
  setDismissAnnouncement doc
  Just mapE <- getElementById "map-canvas" doc
  startingPoint <- newLatLng 41.714754626155 (-73.726791873574)
  roadmap <- gMap mapE (MapOptions { zoom: 6, center: startingPoint, mapTypeId: "roadmap" })
  randomcoord <- newLatLng 41.714754626155 (-73.726791873574)
  panTo roadmap randomcoord

  mvcA <- newMVCArray :: forall eff. Eff eff (MVCArray LatLng)
  testcoord <- newLatLng 41.714754626155 (-73.726791873574)
  pushMVCArray mvcA testcoord
  pushMVCArray mvcA randomcoord

  polyline <- newPolyline (PolylineOptions { geodescic: true
                                           , strokeColor: "#ff0000"
                                           , strokeOpacity: 1.0
                                           , strokeWeight: 2
                                           , map: roadmap
                                           })
  setPolylinePath polyline mvcA

  marker <- newMarker (MarkerOptions { position: randomcoord, map: roadmap, title: "HABP Location" })
  iw <- newInfoWindow (InfoWindowOptions { content: "HABP Location" })
  openInfoWindow iw roadmap marker

  --let example = "{\"coordinates\":{\"latitude\":43.714754626155,\"longitude\":-64.726791873574},\"altitude\":300,\"time\":\"1234321\"}"
  socket <- newWebSocket "ws://127.0.0.1:9160/"
  addEventListenerWS socket "onmessage" $ (\x -> updateMap x mvcA polyline marker)
  --sendWS socket example

  nowMoment <- now
  let leet = momentConstructor "January 1, 0678"
  let leet' = createMoment leet
  Just lastupdate <- getElementById "lastupdate" doc
  let str = liftMoment2 momentFrom nowMoment <$> leet'
  let seven = fromMaybe "Unknown" str
  setInnerHTML seven lastupdate

  trace "hi"
  where
    updateMap e mvcA polyline marker = do
      trace "RX from websocket"
      msgData <- getData e
      case readJSON msgData :: F WSMessage of
        Left err -> trace $ "Error parsing JSON:\n" ++ show err
        Right (LocationBeacon result) -> do
          trace $ unsafeShowJSON result
          case result.coordinates of
            Coordinate coord -> do
              latestLatLng <- newLatLng coord.latitude coord.longitude
              pushMVCArray mvcA latestLatLng
              setPolylinePath polyline mvcA
              setMarkerPosition marker latestLatLng

module Main where

import Control.Monad.Eff
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Encode
import Data.DOM.Simple.Events hiding (read)
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Either
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Debug.Trace
import DomHelpers
import GMaps.InfoWindow
import GMaps.LatLng
import GMaps.Map
import GMaps.MapOptions
import GMaps.Marker
import GMaps.MVCArray
import GMaps.Polyline
import MapViewWS
import MomentJS
import WebSocket

setDismissAnnouncement :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) Unit
setDismissAnnouncement doc = do
  -- TODO: Partial
  Just dismissButton <- getElementById "dismiss_announcement" doc
  Just announcement <- getElementById "announcement" doc
  y <- setDisplayFn announcement "none"
  setOnclick dismissButton y

setAnnouncement :: forall eff. HTMLDocument -> String -> String -> Eff (dom :: DOM | eff) Unit
setAnnouncement doc t c = do
  -- TODO: Partial
  Just announcement <- getElementById "announcement" doc
  Just text <- getElementById "announcement_text" doc
  setInnerHtml text t
  setClass announcement c
  setDisplay announcement "block"

foreign import getData
  "function getData(x) {\
  \  return function() {\
  \    return x.data;\
  \  };\
  \}" :: forall eff. Event -> Eff eff String

main = do
  doc <- document globalWindow
  setDismissAnnouncement doc
  Just mapE <- getElementById "map-canvas" doc
  startingPoint <- newLatLng 41.714754626155 (-73.726791873574)
  roadmap <- gMap mapE (MapOptions { zoom: 6, center: startingPoint, mapTypeId: "roadmap" })
  randomcoord <- newLatLng 41.714754626155 (-73.726791873574)
  panTo roadmap randomcoord

  mvcA <- newMVCArray :: forall eff. Eff eff (MVCArray LatLng)
  testcoord <- newLatLng 41.714754626155 (-73.726791873574)
  pushMVCArray mvcA testcoord
  pushMVCArray mvcA randomcoord

  polyline <- newPolyline (PolylineOptions { geodescic: true
                                           , strokeColor: "#ff0000"
                                           , strokeOpacity: 1.0
                                           , strokeWeight: 2
                                           , map: roadmap
                                           })
  setPolylinePath polyline mvcA

  marker <- newMarker (MarkerOptions { position: randomcoord, map: roadmap, title: "HABP Location" })
  iw <- newInfoWindow (InfoWindowOptions { content: "HABP Location" })
  openInfoWindow iw roadmap marker

  --let example = "{\"coordinates\":{\"latitude\":43.714754626155,\"longitude\":-64.726791873574},\"altitude\":300,\"time\":\"1234321\"}"
  socket <- newWebSocket "ws://127.0.0.1:9160/"
  addEventListenerWS socket "onmessage" $ (\x -> updateMap x mvcA polyline marker)
  --sendWS socket example

  nowMoment <- now
  let leet = momentConstructor "January 1, 0678"
  let leet' = createMoment leet
  Just lastupdate <- getElementById "lastupdate" doc
  let str = liftMoment2 momentFrom nowMoment <$> leet'
  let seven = fromMaybe "Unknown" str
  setInnerHtml lastupdate seven

  trace "hi"
  where
    updateMap e mvcA polyline marker = do
      trace "RX from websocket"
      msgData <- getData e
      case readJSON msgData :: F WSMessage of
        Left err -> trace $ "Error parsing JSON:\n" ++ show err
        Right (LocationBeacon result) -> do
          trace $ unsafeShowJSON result
          case result.coordinates of
            Coordinate coord -> do
              latestLatLng <- newLatLng coord.latitude coord.longitude
              pushMVCArray mvcA latestLatLng
              setPolylinePath polyline mvcA
              setMarkerPosition marker latestLatLng


Final simplication for today!

Final simplication for today!

Original commit 82267ad1e5e1c9073f149e04136d67ce115063c6

module Main where

import Doc
import Prelude

import Control.Plus (empty)
import Data.Argonaut.Core (Json, foldJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either)
import Data.Foldable (for_)
import Data.List ((:))
import Data.List as L
import Data.List.Types (List(..))
import Data.StrMap as StrMap

type IRProperty = { name :: String, typ :: IRType }
type IRClassData = { name :: String, properties :: L.List IRProperty }

data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass IRClassData
    | IRUnion (Array IRType)

makeTypeFromJson :: String -> Json -> IRType
makeTypeFromJson name json = foldJson
    (const IRNull)
    (const IRBool)
    (const IRDouble)
    (const IRString)
    -- Convert from Array to List before we match to make things tidier (foldJson is pretty crude)
    (L.fromFoldable >>> case _ of
        Nil -> IRArray IRNothing
        Cons x _ -> IRArray $ makeTypeFromJson (singularize name) x)
    fromJObject
    json
    where
        fromJObject obj = IRClass { name, properties: StrMap.foldMap toProperty obj }
        toProperty name json = L.singleton { name, typ: makeTypeFromJson name json }

singularize :: String -> String
singularize s = "OneOf" <> s

gatherClassesFromType :: IRType -> L.List IRClassData
gatherClassesFromType = case _ of
    IRClass cls -> cls : L.concatMap (gatherClassesFromType <<< _.typ) cls.properties
    IRArray t -> gatherClassesFromType t
    _ -> empty

renderTypeToCSharp :: IRType -> String
renderTypeToCSharp = case _ of
    IRNothing -> "object"
    IRNull -> "object"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> renderTypeToCSharp a <> "[]"
    IRClass { name } -> name
    IRUnion _ -> "FIXME"

renderClassToCSharp :: IRClassData -> Doc Unit
renderClassToCSharp { name, properties } = do
    line $ words ["class", name]
    line "{"
    indent do
        for_ properties \p -> line do
            string "public "
            string $ renderTypeToCSharp p.typ
            words ["", p.name, "{ get; set; }"]
    line "}"

renderClassesToCSharp :: L.List IRClassData -> Doc Unit
renderClassesToCSharp classes = for_ classes \cls -> do
    renderClassToCSharp cls
    blank

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeTypeFromJson "TopLevel"
    <#> gatherClassesFromType
    <#> renderClassesToCSharp
    <#> render

module Main where

import Prelude

import Control.Plus (empty)
import Data.Argonaut.Core (Json, foldJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either)
import Data.Foldable (for_)

import Data.List as L
import Data.List ((:))
import Data.List.Types (List(..))

import Data.StrMap (StrMap, foldMap) as StrMap

import Doc

type IRProperty = { name :: String, typ :: IRType }
type IRClassData = { name :: String, properties :: L.List IRProperty }

data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass IRClassData
    | IRUnion (Array IRType)

makeTypeFromJson :: String -> Json -> IRType
makeTypeFromJson name json = foldJson
    (const IRNull)
    (const IRBool)
    (const IRDouble)
    (const IRString)
    -- Convert from Array to List before we match to make things tidier (foldJson is pretty crude)
    (L.fromFoldable >>> case _ of
        Nil -> IRArray IRNothing
        Cons x _ -> IRArray $ makeTypeFromJson (singularize name) x)
    fromJObject
    json
    where
        fromJObject obj = IRClass { name, properties: StrMap.foldMap toProperty obj }
        toProperty name json = L.singleton { name, typ: makeTypeFromJson name json }

singularize :: String -> String
singularize s = "OneOf" <> s

gatherClassesFromType :: IRType -> L.List IRClassData
gatherClassesFromType (IRClass cls) = cls : L.concatMap (gatherClassesFromType <<< _.typ) cls.properties
gatherClassesFromType (IRArray t) = gatherClassesFromType t
gatherClassesFromType _ = empty

renderTypeToCSharp :: IRType -> String
renderTypeToCSharp IRNothing = "object"
renderTypeToCSharp IRNull = "object"
renderTypeToCSharp IRInteger = "int"
renderTypeToCSharp IRDouble = "double"
renderTypeToCSharp IRBool = "bool"
renderTypeToCSharp IRString = "string"
renderTypeToCSharp (IRArray a) = renderTypeToCSharp a <> "[]"
renderTypeToCSharp (IRClass { name }) = name
renderTypeToCSharp (IRUnion _) = "FIXME"

renderClassToCSharp :: IRClassData -> Doc Unit
renderClassToCSharp { name, properties } = do
    line $ words ["class", name]
    line "{"
    indent do
        for_ properties \p -> line do
            string "public "
            string $ renderTypeToCSharp p.typ
            words ["", p.name, "{ get; set; }"]
    line "}"

renderClassesToCSharp :: L.List IRClassData -> Doc Unit
renderClassesToCSharp classes = for_ classes \cls -> do
    renderClassToCSharp cls
    blank

jsonToCSharp :: String -> Either String String
jsonToCSharp json =
    jsonParser json
    <#> makeTypeFromJson "TopLevel"
    <#> gatherClassesFromType
    <#> renderClassesToCSharp
    <#> render


Added character creation window

Added character creation window

module Main where

import Data.Char
import Data.String
import Data.Maybe
import Data.Tuple
import Data.Array (map, updateAt)
import Data.Foldable
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace

import Graphics.CanvasConsole
import GameData
import Utils
import Level

data GameState = Game { level :: Level, player :: Creature, npcs :: [Creature] }
               | MainMenu
               | CharCreation

initialState :: GameState
initialState = Game { level: stringToLevel testLevel, player: pl, npcs: [testGuard] }
    where
        pl :: Creature
        pl = { pos: {x: 3, y: 3}, ctype: Player, stats: defaultStats }

        testGuard = { pos: {x: 10, y: 4}, ctype: Guard, stats: defaultStats }

onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt st = do
    drawGame console st
    return st

drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console st@(Game state) = do
    clear console
    mapM_ (\p -> drawTile p (getTile state.level p)) (levelPoints state.level)
    mapM_ drawCreature state.npcs
    drawCreature state.player
    return st
    where
        drawCreature :: Creature -> ConsoleEff Unit
        drawCreature c = drawCreatureType c.pos c.ctype

        drawCreatureType :: Point -> CreatureType -> ConsoleEff Unit
        drawCreatureType p Player  = drawChar console "@" "FF0000" p.x p.y
        drawCreatureType p Guard   = drawChar console "G" "0000FF" p.x p.y
        drawCreatureType p Archer  = drawChar console "A" "00FF00" p.x p.y
        drawCreatureType p Peasant = drawChar console "P" "AAAAFF" p.x p.y
        drawCreatureType p _       = drawChar console "?" "FFFFFF" p.x p.y

        drawTile :: Point -> Maybe Tile -> ConsoleEff Unit
        drawTile p (Just Air)        = drawChar console "." "FFFFFF" p.x p.y
        drawTile p (Just Ground)     = drawChar console "#" "AAAAAA" p.x p.y
        drawTile p (Just Wall)       = drawChar console "#" "331A00" p.x p.y
        drawTile p (Just DoorLocked) = drawChar console "+" "331A00" p.x p.y
        drawTile p (Just DoorClosed) = drawChar console "+" "331A00" p.x p.y
        drawTile p (Just DoorOpen)   = drawChar console "|" "331A00" p.x p.y
        drawTile p _                 = drawChar console "?" "FFFFFF" p.x p.y
drawGame console MainMenu = do
    clear console
    drawString console "RobberyRL" "FFFFFF" 12 5
    drawString console "Press space to start" "AAAAAA" 6 12
    return MainMenu
drawGame console CharCreation = do
    clear console
    drawString console "Character Creation:" "FF0000" 2 2

    drawString console "This is a testline, press a to enter game." "FF0000" 2 20

    drawString console "a) Archer      ( +2 dex | +1 str | +2 SP ) (SP = skill point)" "336600" 3 4
    drawString console "b) Knight      ( +4 str | -1 dex | +2 SP )" "B8B8B8" 3 5
    drawString console "c) Monk        ( +2 int | +1 dex | +2 SP )" "E6AC00" 3 6
    drawString console "d) Ninja       ( +4 dex | -1 str | +2 SP )" "5C5C5C" 3 7
    drawString console "e) Peasant     ( -1 all |        | +1 SP )" "00B36B" 3 8
    drawString console "f) Rogue       ( +1 dex | +1 int | +5 SP )" "5C5C5C" 3 9
    drawString console "g) Scholar     ( +3 int | -1 str | +5 SP )" "3D00CC" 3 10
    drawString console "h) Skillmaster ( +1 int |        | +8 SP )" "00B336" 3 11
    drawString console "i) Soldier     ( +2 str | +1 dex | +2 SP )" "9E9E9E" 3 12

    --drawString console "Prefix:" "FF0000" 30 2
    --drawString console "A) Strong (+1 str)" "FF0000" 30 4
    --drawString console "B) Weak   (-1 str)" "FF0000" 30 5
    --drawString console "C) Agile  (+1 dex)" "FF0000" 30 6
    --drawString console "D) Clumsy (-1 dex)" "FF0000" 30 7
    --drawString console "E) Wise   (+1 int)" "FF0000" 30 8
    --drawString console "F) Dumb   (-1 int)" "FF0000" 30 9
    return CharCreation

updateCreatures :: GameState -> GameState
updateCreatures st@(Game state') = foldl updateCreature st (enumerate state'.npcs)
    where
        -- updateCreature is not allowed to remove creatures.
        -- Dead creatures will be cleaned up later.
        updateCreature :: GameState -> Tuple Number Creature -> GameState
        updateCreature (Game state) (Tuple i c) = Game $ state { npcs = updateAt i (c { pos = {x: c.pos.x, y: c.pos.y + 1 }}) state.npcs }

updateWorld :: GameState -> GameState
updateWorld = updateCreatures

isValidMove :: Level -> Point -> Boolean
isValidMove level = isTileSolid <<< fromMaybe Air <<< getTile level

movePlayer :: Tuple Number Number -> GameState -> GameState
movePlayer (Tuple dx dy) (Game state) | (isValidMove (state.level) ({ x: state.player.pos.x + dx, y: state.player.pos.y + dy })) == true = Game state
movePlayer (Tuple dx dy) (Game state) | otherwise = updateWorld $ Game $ state { player = state.player { pos = clampPos { x: state.player.pos.x + dx, y: state.player.pos.y + dy } } }
    where
        clamp x min max | x < min = min
        clamp x min max | x > max = max
        clamp x min max = x

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 79, y: clamp pos.y 0 24 }

movementkeys :: M.Map Number (Tuple Number Number)
movementkeys = M.fromList [numpad 8 // ( 0 // -1)
                          ,numpad 2 // ( 0 //  1)
                          ,numpad 4 // (-1 //  0)
                          ,numpad 6 // ( 1 //  0)]

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console st@(Game state) key =
    case M.lookup key movementkeys of
        Just delta -> drawGame console $ movePlayer delta st
        Nothing    -> return st
onKeyPress console MainMenu key     | key == 32 = return CharCreation
onKeyPress console CharCreation key | key == 97 = return initialState
onKeyPress _ st _ = return st

main = J.ready $ withConsole 80 25 MainMenu {onKeyPress: onKeyPress, onUpdate: onUpdate}

module Main where

import Data.Char
import Data.String
import Data.Maybe
import Data.Tuple
import Data.Array (map, updateAt)
import Data.Foldable
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace

import Graphics.CanvasConsole
import GameData
import Utils
import Level

data GameState = Game { level :: Level, player :: Creature, npcs :: [Creature] }
               | MainMenu
               | CharCreation

initialState :: GameState
initialState = Game { level: stringToLevel testLevel, player: pl, npcs: [testGuard] }
    where
        pl :: Creature
        pl = { pos: {x: 3, y: 3}, ctype: Player, stats: defaultStats }

        testGuard = { pos: {x: 10, y: 4}, ctype: Guard, stats: defaultStats }

onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt st = do
    drawGame console st
    return st

drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console st@(Game state) = do
    clear console
    mapM_ (\p -> drawTile p (getTile state.level p)) (levelPoints state.level)
    mapM_ drawCreature state.npcs
    drawCreature state.player
    return st
    where
        drawCreature :: Creature -> ConsoleEff Unit
        drawCreature c = drawCreatureType c.pos c.ctype

        drawCreatureType :: Point -> CreatureType -> ConsoleEff Unit
        drawCreatureType p Player  = drawChar console "@" "FF0000" p.x p.y
        drawCreatureType p Guard   = drawChar console "G" "0000FF" p.x p.y
        drawCreatureType p Archer  = drawChar console "A" "00FF00" p.x p.y
        drawCreatureType p Peasant = drawChar console "P" "AAAAFF" p.x p.y
        drawCreatureType p _       = drawChar console "?" "FFFFFF" p.x p.y

        drawTile :: Point -> Maybe Tile -> ConsoleEff Unit
        drawTile p (Just Air)        = drawChar console "." "FFFFFF" p.x p.y
        drawTile p (Just Ground)     = drawChar console "#" "AAAAAA" p.x p.y
        drawTile p (Just Wall)       = drawChar console "#" "331A00" p.x p.y
        drawTile p (Just DoorLocked) = drawChar console "+" "331A00" p.x p.y
        drawTile p (Just DoorClosed) = drawChar console "+" "331A00" p.x p.y
        drawTile p (Just DoorOpen)   = drawChar console "|" "331A00" p.x p.y
        drawTile p _                 = drawChar console "?" "FFFFFF" p.x p.y
drawGame console MainMenu = do
    clear console
    drawString console "RobberyRL" "FFFFFF" 12 5
    drawString console "Press space to start" "AAAAAA" 6 12
    return MainMenu

updateCreatures :: GameState -> GameState
updateCreatures st@(Game state') = foldl updateCreature st (enumerate state'.npcs)
    where
        -- updateCreature is not allowed to remove creatures.
        -- Dead creatures will be cleaned up later.
        updateCreature :: GameState -> Tuple Number Creature -> GameState
        updateCreature (Game state) (Tuple i c) = Game $ state { npcs = updateAt i (c { pos = {x: c.pos.x, y: c.pos.y + 1 }}) state.npcs }

updateWorld :: GameState -> GameState
updateWorld = updateCreatures

isValidMove :: Level -> Point -> Boolean
isValidMove level = isTileSolid <<< fromMaybe Air <<< getTile level

movePlayer :: Tuple Number Number -> GameState -> GameState
movePlayer (Tuple dx dy) (Game state) | (isValidMove (state.level) ({ x: state.player.pos.x + dx, y: state.player.pos.y + dy })) == true = Game state
movePlayer (Tuple dx dy) (Game state) | otherwise = updateWorld $ Game $ state { player = state.player { pos = clampPos { x: state.player.pos.x + dx, y: state.player.pos.y + dy } } }
    where
        clamp x min max | x < min = min
        clamp x min max | x > max = max
        clamp x min max = x

        clampPos :: Point -> Point
        clampPos pos = { x: clamp pos.x 0 79, y: clamp pos.y 0 24 }

movementkeys :: M.Map Number (Tuple Number Number)
movementkeys = M.fromList [numpad 8 // ( 0 // -1)
                          ,numpad 2 // ( 0 //  1)
                          ,numpad 4 // (-1 //  0)
                          ,numpad 6 // ( 1 //  0)]

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console st@(Game state) key =
    case M.lookup key movementkeys of
        Just delta -> drawGame console $ movePlayer delta st
        Nothing    -> return st
onKeyPress console MainMenu key | key == 32 = return initialState
onKeyPress _ st _ = return st

main = J.ready $ withConsole 80 25 MainMenu {onKeyPress: onKeyPress, onUpdate: onUpdate}


Highlight entire row when awaiting

Highlight entire row when awaiting

-- / Game round
module App.Round where

import App.TurnAnimation as TurnAnimation
import App.Board as Board
import App.Board (Board)
import App.Hand as Hand
import App.Turn as Turn
import App.Turn (Turn)
import App.BoardView as BoardView
import App.BoardView (class BoardView, getBoard, isPlaying, pitState)
import Data.Either (Either(..))
import Data.List (length)
import Data.Maybe (Maybe(Nothing, Just))
import Prelude (bind, pure, show, unit, (#), ($), (<>), (>), (>>>), (==))
import Pux (EffModel, noEffects, mapState, mapEffects)
import Pux.Html (Html, div, text)

type HandA = TurnAnimation.State Hand.State Turn
type Error = String

data State
  = Turning HandA
  | Awaiting (Maybe Error) Board.Player Board

instance boardViewRound :: BoardView State where
  getBoard (Turning handA) = getBoard handA.current
  getBoard (Awaiting _ _ board) = board

  isPlaying (Turning handA) player = isPlaying handA.current player
  isPlaying (Awaiting _ player _) player' = player == player'

  pitState (Turning handA) ref =
    go lastTurn nextTurn pitState'
      where lastTurn = handA.lastTurn
            nextTurn = TurnAnimation.nextTurn handA
            pitState' = pitState handA.current ref
            go _ _ BoardView.Normal = BoardView.Normal
            go Nothing _ ps = ps
            go (Just Turn.Capture) _ _ = BoardView.Captured
            go _ (Just Turn.Capture) _ = BoardView.Captured
            go (Just Turn.Lift) _ _ = BoardView.Lifted
            go _ (Just Turn.Lift) _ = BoardView.Lifted
            go (Just Turn.Sow) _ _ = BoardView.Sowed
            go (Just Turn.Advance) _ _ = BoardView.Sowed
  pitState (Awaiting _ player _) ref =
    if Board.belongsTo ref player
      then BoardView.Sowed
      else BoardView.Normal

data Action
  = TurnAnimationAction TurnAnimation.Action
  | PlayerSelect Board.PitRef

init :: Board.Player -> Board -> State
init player = Awaiting Nothing player

update :: forall eff. Action -> State -> EffModel State Action (eff)
update (TurnAnimationAction action) (Turning state) =
  case TurnAnimation.update action state of
    Nothing ->  -- Turn over
      awaitOpponent state.current
      # noEffects
    Just handA' ->
      handA'
      # wrapTurnAnimation

update (PlayerSelect pitRef) (Awaiting _ player board) =
  case beginTurn player pitRef board of
    Right handA ->
      handA
      # TurnAnimation.withAnimateEffect
      # wrapTurnAnimation
    Left error ->
      Awaiting (Just error) player board
      # noEffects

update _ state =
  -- TODO: make this state transition impossible.
  noEffects state

wrapTurnAnimation :: forall eff. EffModel HandA TurnAnimation.Action (eff)
                  -> EffModel State Action (eff)
wrapTurnAnimation = mapState Turning >>> mapEffects TurnAnimationAction

beginTurn :: Board.Player -> Board.PitRef -> Board -> Either Error HandA
beginTurn player pitRef board = do
  _ <- verifyPlayer
  _ <- verifyPit
  pure $ beginTurn' player pitRef board
    where verifyPlayer = if Board.belongsTo pitRef player
                            then Right unit
                            else Left "Cannot play opponent's pit"
          verifyPit = if Board.lookup pitRef board > 0
                        then Right unit
                        else Left "Cannot play from empty pit"

beginTurn' :: Board.Player -> Board.PitRef -> Board -> HandA
beginTurn' player pitRef board = TurnAnimation.init hand rest
  where hand = Hand.init player pitRef board
        rest = Turn.unfoldTurns hand

awaitOpponent :: Hand.State -> State
awaitOpponent hand = Awaiting Nothing (Hand.opponent hand) (getBoard hand)

-- View

view :: State -> Html Action
view state =
  div []
    [ heading state
    , BoardView.view PlayerSelect state
    , hand state
    , lastTurn state
    , errorDiv state
    ]
    where errorDiv (Awaiting (Just error) _ _) =
            div [] [ text $ "ERROR: " <> error ]
          errorDiv _ =
            div [] []
          heading (Turning handA) =
            div [] [ text $ "Sowing - " <> show (length handA.remainingTurns) <> " turns left"]
          heading (Awaiting _ player _) =
            div [] [ text $ "Awaiting turn by " <> show player ]
          hand (Turning handA) =
            Hand.view handA.current
          hand (Awaiting _ _ _) =
            div [] [ text "No hand" ]
          lastTurn (Turning handA) =
            case handA.lastTurn of
              Just t -> div [] [ text $ "Last turn: " <> show t ]
              Nothing -> div [] [ text "No last turn" ]
          lastTurn _ =
            div [] []

-- / Game round
module App.Round where

import App.TurnAnimation as TurnAnimation
import App.Board as Board
import App.Board (Board)
import App.Hand as Hand
import App.Turn as Turn
import App.Turn (Turn)
import App.BoardView as BoardView
import App.BoardView (class BoardView, getBoard, isPlaying, pitState)
import Data.Either (Either(..))
import Data.List (length)
import Data.Maybe (Maybe(Nothing, Just))
import Prelude (bind, pure, show, unit, (#), ($), (<>), (>), (>>>), (==))
import Pux (EffModel, noEffects, mapState, mapEffects)
import Pux.Html (Html, div, text)

type HandA = TurnAnimation.State Hand.State Turn
type Error = String

data State
  = Turning HandA
  | Awaiting (Maybe Error) Board.Player Board

instance boardViewRound :: BoardView State where
  getBoard (Turning handA) = getBoard handA.current
  getBoard (Awaiting _ _ board) = board

  isPlaying (Turning handA) player = isPlaying handA.current player
  isPlaying (Awaiting _ player _) player' = player == player'

  pitState (Turning handA) ref =
    go lastTurn nextTurn pitState'
      where lastTurn = handA.lastTurn
            nextTurn = TurnAnimation.nextTurn handA
            pitState' = pitState handA.current ref
            go _ _ BoardView.Normal = BoardView.Normal
            go Nothing _ ps = ps
            go (Just Turn.Capture) _ _ = BoardView.Captured
            go _ (Just Turn.Capture) _ = BoardView.Captured
            go (Just Turn.Lift) _ _ = BoardView.Lifted
            go _ (Just Turn.Lift) _ = BoardView.Lifted
            go (Just Turn.Sow) _ _ = BoardView.Sowed
            go (Just Turn.Advance) _ _ = BoardView.Sowed
  pitState (Awaiting _ _ _) _ = BoardView.Normal

data Action
  = TurnAnimationAction TurnAnimation.Action
  | PlayerSelect Board.PitRef

init :: Board.Player -> Board -> State
init player = Awaiting Nothing player

update :: forall eff. Action -> State -> EffModel State Action (eff)
update (TurnAnimationAction action) (Turning state) =
  case TurnAnimation.update action state of
    Nothing ->  -- Turn over
      awaitOpponent state.current
      # noEffects
    Just handA' ->
      handA'
      # wrapTurnAnimation

update (PlayerSelect pitRef) (Awaiting _ player board) =
  case beginTurn player pitRef board of
    Right handA ->
      handA
      # TurnAnimation.withAnimateEffect
      # wrapTurnAnimation
    Left error ->
      Awaiting (Just error) player board
      # noEffects

update _ state =
  -- TODO: make this state transition impossible.
  noEffects state

wrapTurnAnimation :: forall eff. EffModel HandA TurnAnimation.Action (eff)
                  -> EffModel State Action (eff)
wrapTurnAnimation = mapState Turning >>> mapEffects TurnAnimationAction

beginTurn :: Board.Player -> Board.PitRef -> Board -> Either Error HandA
beginTurn player pitRef board = do
  _ <- verifyPlayer
  _ <- verifyPit
  pure $ beginTurn' player pitRef board
    where verifyPlayer = if Board.belongsTo pitRef player
                            then Right unit
                            else Left "Cannot play opponent's pit"
          verifyPit = if Board.lookup pitRef board > 0
                        then Right unit
                        else Left "Cannot play from empty pit"

beginTurn' :: Board.Player -> Board.PitRef -> Board -> HandA
beginTurn' player pitRef board = TurnAnimation.init hand rest
  where hand = Hand.init player pitRef board
        rest = Turn.unfoldTurns hand

awaitOpponent :: Hand.State -> State
awaitOpponent hand = Awaiting Nothing (Hand.opponent hand) (getBoard hand)

-- View

view :: State -> Html Action
view state =
  div []
    [ heading state
    , errorDiv state
    , BoardView.view PlayerSelect state
    , hand state
    , lastTurn state
    ]
    where errorDiv (Awaiting (Just error) _ _) =
            div [] [ text $ "ERROR: " <> error ]
          errorDiv _ =
            div [] []
          heading (Turning handA) =
            div [] [ text $ "Sowing - " <> show (length handA.remainingTurns) <> " turns left"]
          heading (Awaiting _ player _) =
            div [] [ text $ "Awaiting turn by " <> show player ]
          hand (Turning handA) =
            Hand.view handA.current
          hand (Awaiting _ _ _) =
            div [] [ text "No hand" ]
          lastTurn (Turning handA) =
            case handA.lastTurn of
              Just t -> div [] [ text $ "Last turn: " <> show t ]
              Nothing -> div [] [ text "No last turn" ]
          lastTurn _ =
            div [] []


Remove unused $

Remove unused $

module Web.Firebase
( EventType(..)
, child
, key
, newFirebase
, offSimple
, on
, once
, push
, pushA
, pushE
, set
, setE
, setA
, toString
)
where

import Prelude (class Show, class Eq, class Ord, Unit, (<$>), (<<<), compare, map)
import Control.Monad.Eff (Eff())
import Data.Foreign (Foreign())
import Data.Function.Uncurried (Fn1(), Fn2(), Fn3(), Fn4(), runFn1, runFn2, runFn3, runFn4)
import Data.Maybe (Maybe)
import Data.Nullable (toMaybe, toNullable, Nullable())
import Web.Firebase.Types (Firebase(), FirebaseEff(), FirebaseErr(), DataSnapshot(), Key())
import Web.Firebase.Unsafe (unsafeEvalEff)

foreign import newFirebaseImpl :: forall eff. Fn1 String (Eff (firebase :: FirebaseEff | eff) Firebase)

-- Data.URI would introduce too many dependencies for this single use
-- if you want URI's checked, import Data.URI in your projects, and use printURI to convert
-- We assume an application sets up a newFirebase just once,
-- and if the URI is wrong, that it is a programming error
type FirebaseURI = String

newFirebase :: forall eff. FirebaseURI -> Eff (firebase :: FirebaseEff | eff) Firebase
newFirebase u = runFn1 newFirebaseImpl u

-- | Gets a Firebase reference for the location at the specified relative path.
-- https://www.firebase.com/docs/web/api/firebase/child.html
-- Firebase documentation does not specify what happens when the child does not exist
-- Probably nothing happens when the path does not exist, since references don't involve IO, they are just data about paths in the DB that
-- may or may not exist.
-- Existence can be checked by getting the value, and DataSnapshot.exists - https://www.firebase.com/docs/web/api/datasnapshot/exists.html

foreign import childImpl :: forall eff. Fn2 String Firebase (Eff (firebase :: FirebaseEff | eff) Firebase)

child :: forall eff. String -> Firebase -> Eff (firebase :: FirebaseEff | eff) Firebase
child = runFn2 childImpl

-- | Gets the key of the reference - https://www.firebase.com/docs/web/api/firebase/key.html
-- Nothing on the root ref (following the behaviour in the Firebase API)
foreign import _key :: forall eff. Fn1 Firebase (Eff (firebase :: FirebaseEff | eff) (Nullable Key))

key :: forall eff. Firebase -> Eff (firebase :: FirebaseEff | eff) (Maybe Key)
key ds = map toMaybe (runFn1 _key ds)

data EventType = Value
               | ChildAdded
               | ChildChanged
               | ChildRemoved
               | ChildMoved

-- | Boilerplate, but we have data instead of newtype
-- so generics don't work here
instance eqEventType :: Eq EventType where
  eq Value        Value = true
  eq ChildAdded   ChildAdded = true
  eq ChildChanged ChildChanged = true
  eq ChildRemoved ChildRemoved = true
  eq ChildMoved   ChildMoved = true
  eq _            _     = false

-- | Boilerplate, but we have data instead of newtype
-- so generics don't work here
-- provided so we can make a set of EventTypes
instance ordEventType :: Ord EventType where
  compare ev1 ev2 = compare (numValue ev1) (numValue ev2)
		where
			numValue Value = 0
			numValue ChildAdded = 1
			numValue ChildChanged = 2
			numValue ChildRemoved = 3
			numValue ChildMoved = 4

showEventType :: EventType -> String
showEventType t = case t of
                       Value -> "value"
                       ChildAdded -> "child_added"
                       ChildChanged -> "child_changed"
                       ChildRemoved -> "child_removed"
                       ChildMoved -> "child_moved"

instance show4EventType :: Show EventType where
  show = showEventType

-- | Listens for data changes at a particular location
-- https://www.firebase.com/docs/web/api/query/on.html
-- Error callback in this FFI is not optional, see onWithoutCancelCallbackImpl why.
foreign import onImpl :: forall eff. Fn4
                   String
                   (DataSnapshot -> Eff (firebase :: FirebaseEff | eff) Unit)
                   (FirebaseErr -> Eff (firebase :: FirebaseEff | eff) Unit)
                   Firebase
                   (Eff (firebase :: FirebaseEff | eff) Unit)

on :: forall eff.
      EventType ->
      (DataSnapshot -> Eff (firebase :: FirebaseEff | eff) Unit) ->
      (FirebaseErr -> Eff (firebase :: FirebaseEff | eff) Unit) ->
      Firebase ->
      Eff (firebase :: FirebaseEff | eff) Unit
on etype ds canceler fb = runFn4 onImpl (showEventType etype) ds canceler fb

-- | this function is only present for documentation purposes
-- so you can see why we error callbacks are not optional in this FFI.
--- The documentation mentions the Cancel callback is optional.
-- It does not mention that your program will halt with a Javascript error.
-- When an error occurs while no callback is passed to on,  or when null is passed, it throws a javascript exception:
--  FIREBASE WARNING: Exception was thrown by user callback. TypeError: errorCallback is not a function.
foreign import onWithoutCancelCallbackImpl :: forall eff. Fn3
                   String
                   (DataSnapshot -> Eff (firebase :: FirebaseEff | eff) Unit)
                   Firebase
                   (Eff (firebase :: FirebaseEff | eff) Unit)

-- | unsubscribes from a location
-- optionally for a specific callback or type. We don't need that in our application right now, so not going to bother with Maybes just now. just take the ref
-- and add the other parameters later.
-- https://www.firebase.com/docs/web/api/query/off.html
foreign import _offSimple :: forall eff. Fn1
                Firebase
                (Eff (firebase :: FirebaseEff | eff) Unit)

offSimple :: forall eff. Firebase -> Eff (firebase :: FirebaseEff | eff) Unit
offSimple ref = runFn1 _offSimple ref

-- implementation of off with more parameters goes here. we can then rewrite offSimple in terms of off.

-- | Listens for one change at a particular location
-- Takes a success and an error callback.
-- Error callback is not optional in this implementation, see onWithoutCancleCallbackImpl for why.
foreign import onceImpl :: forall eff. Fn4
        String
        (DataSnapshot -> Eff (firebase :: FirebaseEff | eff) Unit)
        (FirebaseErr -> Eff (firebase :: FirebaseEff | eff) Unit)
        Firebase
        (Eff (firebase :: FirebaseEff | eff) Unit)

once :: forall eff.
        EventType ->
        (DataSnapshot -> Eff (firebase :: FirebaseEff | eff) Unit) ->
        (FirebaseErr -> Eff (firebase :: FirebaseEff | eff) Unit) ->
        Firebase ->
        Eff (firebase :: FirebaseEff | eff) Unit
once etype ds cb fb = runFn4 onceImpl (showEventType etype) (unsafeEvalEff <<< ds) (cb) fb

-- | sets a value in the firebase https://www.firebase.com/docs/web/api/firebase/set.html
-- this implementation is also broken, FirebaseErr can be null. if you implement a callback it will fail
-- fixing setImplE first, purescript semantics make more sense: if you don't want to handle errors,
-- you can allways pass a callback that ignores its input: noop _ = pure Unit
-- Also, push hang when an error would occur and Nothing was passed. Not sure how that happens. This probably behaves similarly.
foreign import setImpl :: forall eff. Fn3
                   Foreign
                   (Nullable (Nullable (FirebaseErr -> Eff eff Unit)))
                   Firebase
                   (Eff (firebase :: FirebaseEff | eff) Unit)

set :: forall eff.
       Foreign ->
       Maybe (Maybe (FirebaseErr -> Eff eff Unit)) ->
       Firebase ->
       Eff (firebase :: FirebaseEff | eff) Unit
set value cb fb = runFn3 setImpl value (toNullable (toNullable <$> cb)) fb

-- | an extra implementation of set() that forces you to provide an error callback, even if it is a noop (see set in the example above)
-- FirebaseErr can be null, so we wrap it in a Maybe
foreign import setEImpl :: forall eff. Fn3
                   Foreign
                   ((Nullable FirebaseErr) -> Eff eff Unit)
                   Firebase
                   (Eff (firebase :: FirebaseEff | eff) Unit)

setE :: forall eff.
       Foreign ->
       ((Maybe FirebaseErr) -> Eff eff Unit) ->
       Firebase ->
       Eff (firebase :: FirebaseEff | eff) Unit
setE value cb fb = runFn3 setEImpl value (callBackReceivesNull cb) fb

-- | set with success and error callback, for easy Aff conversion with makeAff
-- explicit parameter is easier and communicates better than messing with Maybes and nullables.
foreign import _setA :: forall eff eff1 eff2. Fn4
                   Foreign
                   (Unit -> Eff eff1 Unit)
                   (FirebaseErr -> Eff eff2 Unit)
                   Firebase
                   (Eff (firebase :: FirebaseEff | eff) Unit)

setA :: forall eff eff1 eff2.
        Foreign ->
        (Unit -> Eff eff1 Unit) ->
        (FirebaseErr -> Eff eff2 Unit) ->
        Firebase ->
        Eff (firebase :: FirebaseEff | eff) Unit
setA = runFn4 _setA

-- | this one is broken. hangs with Nothing passed for callback (so undefined actually might not work)
-- also hangs when Just (Just callback) is passed, even when calling the effect.
foreign import pushImpl :: forall eff. Fn3
                   Foreign
                   (Nullable (Nullable (FirebaseErr -> Eff eff Unit)))
                   Firebase
                   (Eff (firebase :: FirebaseEff | eff) Firebase)

push :: forall eff.
        Foreign ->
        Maybe (Maybe (FirebaseErr -> Eff eff Unit)) ->
        Firebase ->
        Eff (firebase :: FirebaseEff | eff) Firebase
push value cb fb = runFn3 pushImpl value (toNullable (toNullable <$> cb)) fb

-- | push with FirebaseErr error callback
-- explicit parameter is easier and communicates better than messing with Maybes and nullables.
foreign import pushEImpl :: forall eff. Fn3
                   Foreign
                   ((Nullable FirebaseErr) -> Eff eff Unit)
                   Firebase
                   (Eff (firebase :: FirebaseEff | eff) Firebase)

pushE :: forall eff.
        Foreign ->
        ((Maybe FirebaseErr) -> Eff eff Unit) ->
        Firebase ->
        Eff (firebase :: FirebaseEff | eff) Firebase
pushE value cb fb = runFn3 pushEImpl value (callBackReceivesNull cb) fb

-- | push with success and error callback, for easy Aff conversion with makeAff
-- explicit parameter is easier and communicates better than messing with Maybes and nullables.
foreign import _pushA :: forall eff eff1 eff2. Fn4
                   Foreign
                   (Firebase -> Eff eff1 Unit)
                   (FirebaseErr -> Eff eff2 Unit)
                   Firebase
                   (Eff (firebase :: FirebaseEff | eff) Unit)

pushA :: forall eff eff1 eff2.
        Foreign ->
        (Firebase -> Eff eff1 Unit) ->
        (FirebaseErr -> Eff eff2 Unit) ->
        Firebase ->
        Eff (firebase :: FirebaseEff | eff) Unit
pushA = runFn4 _pushA

-- Callback receives Maybe on the outside, Nullable on the inside
callBackReceivesNull :: forall a b. (Maybe a -> b) -> (Nullable a -> b)
callBackReceivesNull cb = nab
  where nab nullValue = cb (toMaybe nullValue)

-- | Get the absolute URL for this location -  https://firebase.google.com/docs/reference/js/firebase.database.Reference#toString
foreign import _toString :: forall eff. Fn1 Firebase (Eff (firebase :: FirebaseEff | eff) String)

toString :: forall eff. Firebase -> Eff (firebase :: FirebaseEff | eff) String
toString ds = runFn1 _toString ds

module Web.Firebase
( EventType(..)
, child
, key
, newFirebase
, offSimple
, on
, once
, push
, pushA
, pushE
, set
, setE
, setA
, toString
)
where

import Prelude (class Show, class Eq, class Ord, Unit, (<$>), (<<<), compare, map, ($))
import Control.Monad.Eff (Eff())
import Data.Foreign (Foreign())
import Data.Function.Uncurried (Fn1(), Fn2(), Fn3(), Fn4(), runFn1, runFn2, runFn3, runFn4)
import Data.Maybe (Maybe)
import Data.Nullable (toMaybe, toNullable, Nullable())
import Web.Firebase.Types (Firebase(), FirebaseEff(), FirebaseErr(), DataSnapshot(), Key())
import Web.Firebase.Unsafe (unsafeEvalEff)

foreign import newFirebaseImpl :: forall eff. Fn1 String (Eff (firebase :: FirebaseEff | eff) Firebase)

-- Data.URI would introduce too many dependencies for this single use
-- if you want URI's checked, import Data.URI in your projects, and use printURI to convert
-- We assume an application sets up a newFirebase just once,
-- and if the URI is wrong, that it is a programming error
type FirebaseURI = String

newFirebase :: forall eff. FirebaseURI -> Eff (firebase :: FirebaseEff | eff) Firebase
newFirebase u = runFn1 newFirebaseImpl u

-- | Gets a Firebase reference for the location at the specified relative path.
-- https://www.firebase.com/docs/web/api/firebase/child.html
-- Firebase documentation does not specify what happens when the child does not exist
-- Probably nothing happens when the path does not exist, since references don't involve IO, they are just data about paths in the DB that
-- may or may not exist.
-- Existence can be checked by getting the value, and DataSnapshot.exists - https://www.firebase.com/docs/web/api/datasnapshot/exists.html

foreign import childImpl :: forall eff. Fn2 String Firebase (Eff (firebase :: FirebaseEff | eff) Firebase)

child :: forall eff. String -> Firebase -> Eff (firebase :: FirebaseEff | eff) Firebase
child = runFn2 childImpl

-- | Gets the key of the reference - https://www.firebase.com/docs/web/api/firebase/key.html
-- Nothing on the root ref (following the behaviour in the Firebase API)
foreign import _key :: forall eff. Fn1 Firebase (Eff (firebase :: FirebaseEff | eff) (Nullable Key))

key :: forall eff. Firebase -> Eff (firebase :: FirebaseEff | eff) (Maybe Key)
key ds = map toMaybe (runFn1 _key ds)

data EventType = Value
               | ChildAdded
               | ChildChanged
               | ChildRemoved
               | ChildMoved

-- | Boilerplate, but we have data instead of newtype
-- so generics don't work here
instance eqEventType :: Eq EventType where
  eq Value        Value = true
  eq ChildAdded   ChildAdded = true
  eq ChildChanged ChildChanged = true
  eq ChildRemoved ChildRemoved = true
  eq ChildMoved   ChildMoved = true
  eq _            _     = false

-- | Boilerplate, but we have data instead of newtype
-- so generics don't work here
-- provided so we can make a set of EventTypes
instance ordEventType :: Ord EventType where
  compare ev1 ev2 = compare (numValue ev1) (numValue ev2)
		where
			numValue Value = 0
			numValue ChildAdded = 1
			numValue ChildChanged = 2
			numValue ChildRemoved = 3
			numValue ChildMoved = 4

showEventType :: EventType -> String
showEventType t = case t of
                       Value -> "value"
                       ChildAdded -> "child_added"
                       ChildChanged -> "child_changed"
                       ChildRemoved -> "child_removed"
                       ChildMoved -> "child_moved"

instance show4EventType :: Show EventType where
  show = showEventType

-- | Listens for data changes at a particular location
-- https://www.firebase.com/docs/web/api/query/on.html
-- Error callback in this FFI is not optional, see onWithoutCancelCallbackImpl why.
foreign import onImpl :: forall eff. Fn4
                   String
                   (DataSnapshot -> Eff (firebase :: FirebaseEff | eff) Unit)
                   (FirebaseErr -> Eff (firebase :: FirebaseEff | eff) Unit)
                   Firebase
                   (Eff (firebase :: FirebaseEff | eff) Unit)

on :: forall eff.
      EventType ->
      (DataSnapshot -> Eff (firebase :: FirebaseEff | eff) Unit) ->
      (FirebaseErr -> Eff (firebase :: FirebaseEff | eff) Unit) ->
      Firebase ->
      Eff (firebase :: FirebaseEff | eff) Unit
on etype ds canceler fb = runFn4 onImpl (showEventType etype) ds canceler fb

-- | this function is only present for documentation purposes
-- so you can see why we error callbacks are not optional in this FFI.
--- The documentation mentions the Cancel callback is optional.
-- It does not mention that your program will halt with a Javascript error.
-- When an error occurs while no callback is passed to on,  or when null is passed, it throws a javascript exception:
--  FIREBASE WARNING: Exception was thrown by user callback. TypeError: errorCallback is not a function.
foreign import onWithoutCancelCallbackImpl :: forall eff. Fn3
                   String
                   (DataSnapshot -> Eff (firebase :: FirebaseEff | eff) Unit)
                   Firebase
                   (Eff (firebase :: FirebaseEff | eff) Unit)

-- | unsubscribes from a location
-- optionally for a specific callback or type. We don't need that in our application right now, so not going to bother with Maybes just now. just take the ref
-- and add the other parameters later.
-- https://www.firebase.com/docs/web/api/query/off.html
foreign import _offSimple :: forall eff. Fn1
                Firebase
                (Eff (firebase :: FirebaseEff | eff) Unit)

offSimple :: forall eff. Firebase -> Eff (firebase :: FirebaseEff | eff) Unit
offSimple ref = runFn1 _offSimple ref

-- implementation of off with more parameters goes here. we can then rewrite offSimple in terms of off.

-- | Listens for one change at a particular location
-- Takes a success and an error callback.
-- Error callback is not optional in this implementation, see onWithoutCancleCallbackImpl for why.
foreign import onceImpl :: forall eff. Fn4
        String
        (DataSnapshot -> Eff (firebase :: FirebaseEff | eff) Unit)
        (FirebaseErr -> Eff (firebase :: FirebaseEff | eff) Unit)
        Firebase
        (Eff (firebase :: FirebaseEff | eff) Unit)

once :: forall eff.
        EventType ->
        (DataSnapshot -> Eff (firebase :: FirebaseEff | eff) Unit) ->
        (FirebaseErr -> Eff (firebase :: FirebaseEff | eff) Unit) ->
        Firebase ->
        Eff (firebase :: FirebaseEff | eff) Unit
once etype ds cb fb = runFn4 onceImpl (showEventType etype) (unsafeEvalEff <<< ds) (cb) fb

-- | sets a value in the firebase https://www.firebase.com/docs/web/api/firebase/set.html
-- this implementation is also broken, FirebaseErr can be null. if you implement a callback it will fail
-- fixing setImplE first, purescript semantics make more sense: if you don't want to handle errors,
-- you can allways pass a callback that ignores its input: noop _ = pure Unit
-- Also, push hang when an error would occur and Nothing was passed. Not sure how that happens. This probably behaves similarly.
foreign import setImpl :: forall eff. Fn3
                   Foreign
                   (Nullable (Nullable (FirebaseErr -> Eff eff Unit)))
                   Firebase
                   (Eff (firebase :: FirebaseEff | eff) Unit)

set :: forall eff.
       Foreign ->
       Maybe (Maybe (FirebaseErr -> Eff eff Unit)) ->
       Firebase ->
       Eff (firebase :: FirebaseEff | eff) Unit
set value cb fb = runFn3 setImpl value (toNullable (toNullable <$> cb)) fb

-- | an extra implementation of set() that forces you to provide an error callback, even if it is a noop (see set in the example above)
-- FirebaseErr can be null, so we wrap it in a Maybe
foreign import setEImpl :: forall eff. Fn3
                   Foreign
                   ((Nullable FirebaseErr) -> Eff eff Unit)
                   Firebase
                   (Eff (firebase :: FirebaseEff | eff) Unit)

setE :: forall eff.
       Foreign ->
       ((Maybe FirebaseErr) -> Eff eff Unit) ->
       Firebase ->
       Eff (firebase :: FirebaseEff | eff) Unit
setE value cb fb = runFn3 setEImpl value (callBackReceivesNull cb) fb

-- | set with success and error callback, for easy Aff conversion with makeAff
-- explicit parameter is easier and communicates better than messing with Maybes and nullables.
foreign import _setA :: forall eff eff1 eff2. Fn4
                   Foreign
                   (Unit -> Eff eff1 Unit)
                   (FirebaseErr -> Eff eff2 Unit)
                   Firebase
                   (Eff (firebase :: FirebaseEff | eff) Unit)

setA :: forall eff eff1 eff2.
        Foreign ->
        (Unit -> Eff eff1 Unit) ->
        (FirebaseErr -> Eff eff2 Unit) ->
        Firebase ->
        Eff (firebase :: FirebaseEff | eff) Unit
setA = runFn4 _setA

-- | this one is broken. hangs with Nothing passed for callback (so undefined actually might not work)
-- also hangs when Just (Just callback) is passed, even when calling the effect.
foreign import pushImpl :: forall eff. Fn3
                   Foreign
                   (Nullable (Nullable (FirebaseErr -> Eff eff Unit)))
                   Firebase
                   (Eff (firebase :: FirebaseEff | eff) Firebase)

push :: forall eff.
        Foreign ->
        Maybe (Maybe (FirebaseErr -> Eff eff Unit)) ->
        Firebase ->
        Eff (firebase :: FirebaseEff | eff) Firebase
push value cb fb = runFn3 pushImpl value (toNullable (toNullable <$> cb)) fb

-- | push with FirebaseErr error callback
-- explicit parameter is easier and communicates better than messing with Maybes and nullables.
foreign import pushEImpl :: forall eff. Fn3
                   Foreign
                   ((Nullable FirebaseErr) -> Eff eff Unit)
                   Firebase
                   (Eff (firebase :: FirebaseEff | eff) Firebase)

pushE :: forall eff.
        Foreign ->
        ((Maybe FirebaseErr) -> Eff eff Unit) ->
        Firebase ->
        Eff (firebase :: FirebaseEff | eff) Firebase
pushE value cb fb = runFn3 pushEImpl value (callBackReceivesNull cb) fb

-- | push with success and error callback, for easy Aff conversion with makeAff
-- explicit parameter is easier and communicates better than messing with Maybes and nullables.
foreign import _pushA :: forall eff eff1 eff2. Fn4
                   Foreign
                   (Firebase -> Eff eff1 Unit)
                   (FirebaseErr -> Eff eff2 Unit)
                   Firebase
                   (Eff (firebase :: FirebaseEff | eff) Unit)

pushA :: forall eff eff1 eff2.
        Foreign ->
        (Firebase -> Eff eff1 Unit) ->
        (FirebaseErr -> Eff eff2 Unit) ->
        Firebase ->
        Eff (firebase :: FirebaseEff | eff) Unit
pushA = runFn4 _pushA

-- Callback receives Maybe on the outside, Nullable on the inside
callBackReceivesNull :: forall a b. (Maybe a -> b) -> (Nullable a -> b)
callBackReceivesNull cb = nab
  where nab nullValue = cb (toMaybe nullValue)

-- | Get the absolute URL for this location -  https://firebase.google.com/docs/reference/js/firebase.database.Reference#toString
foreign import _toString :: forall eff. Fn1 Firebase (Eff (firebase :: FirebaseEff | eff) String)

toString :: forall eff. Firebase -> Eff (firebase :: FirebaseEff | eff) String
toString ds = runFn1 _toString ds


cleanup

cleanup


Typo

Typo

(nothing more :))

module Data.Monoid.Disj where

import Prelude

import Data.Eq (class Eq1)
import Data.HeytingAlgebra (ff, tt)
import Data.Ord (class Ord1)

-- | Monoid and semigroup for disjunction.
-- |
-- | ``` purescript
-- | Disj x <> Disj y == Disj (x || y)
-- | mempty :: Disj _ == Disj bottom
-- | ```
newtype Disj a = Disj a

derive newtype instance eqDisj :: Eq a => Eq (Disj a)
derive instance eq1Disj :: Eq1 Disj

derive newtype instance ordDisj :: Ord a => Ord (Disj a)
derive instance ord1Disj :: Ord1 Disj

derive newtype instance boundedDisj :: Bounded a => Bounded (Disj a)

instance showDisj :: Show a => Show (Disj a) where
  show (Disj a) = "(Disj " <> show a <> ")"

derive instance functorDisj :: Functor Disj

instance applyDisj :: Apply Disj where
  apply (Disj f) (Disj x) = Disj (f x)

instance applicativeDisj :: Applicative Disj where
  pure = Disj

instance bindDisj :: Bind Disj where
  bind (Disj x) f = f x

instance monadDisj :: Monad Disj

instance semigroupDisj :: HeytingAlgebra a => Semigroup (Disj a) where
  append (Disj a) (Disj b) = Disj (disj a b)

instance monoidDisj :: HeytingAlgebra a => Monoid (Disj a) where
  mempty = Disj ff

instance semiringDisj :: HeytingAlgebra a => Semiring (Disj a) where
  zero = Disj ff
  one = Disj tt
  add (Disj a) (Disj b) = Disj (disj a b)
  mul (Disj a) (Disj b) = Disj (conj a b)

module Data.Monoid.Disj where

import Prelude

import Data.Eq (class Eq1)
import Data.HeytingAlgebra (ff, tt)
import Data.Ord (class Ord1)

-- | Monoid and semigroup for disjuntion.
-- |
-- | ``` purescript
-- | Disj x <> Disj y == Disj (x || y)
-- | mempty :: Disj _ == Disj bottom
-- | ```
newtype Disj a = Disj a

derive newtype instance eqDisj :: Eq a => Eq (Disj a)
derive instance eq1Disj :: Eq1 Disj

derive newtype instance ordDisj :: Ord a => Ord (Disj a)
derive instance ord1Disj :: Ord1 Disj

derive newtype instance boundedDisj :: Bounded a => Bounded (Disj a)

instance showDisj :: Show a => Show (Disj a) where
  show (Disj a) = "(Disj " <> show a <> ")"

derive instance functorDisj :: Functor Disj

instance applyDisj :: Apply Disj where
  apply (Disj f) (Disj x) = Disj (f x)

instance applicativeDisj :: Applicative Disj where
  pure = Disj

instance bindDisj :: Bind Disj where
  bind (Disj x) f = f x

instance monadDisj :: Monad Disj

instance semigroupDisj :: HeytingAlgebra a => Semigroup (Disj a) where
  append (Disj a) (Disj b) = Disj (disj a b)

instance monoidDisj :: HeytingAlgebra a => Monoid (Disj a) where
  mempty = Disj ff

instance semiringDisj :: HeytingAlgebra a => Semiring (Disj a) where
  zero = Disj ff
  one = Disj tt
  add (Disj a) (Disj b) = Disj (disj a b)
  mul (Disj a) (Disj b) = Disj (conj a b)


Use appendTo in appendToBody

Use appendTo in appendToBody

module Halogen.Util
  ( appendTo
  , appendToBody
  ) where

import Prelude

import Control.Bind ((<=<), (=<<))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (MonadEff, liftEff)

import Data.Maybe (Maybe(..))
import Data.Nullable (toMaybe)

import DOM (DOM())
import DOM.Event.EventTarget (eventListener, addEventListener)
import DOM.Event.EventTypes (load)
import DOM.Event.Types (Event())
import DOM.HTML (window)
import DOM.HTML.Document (body)
import DOM.HTML.Types (HTMLElement(), htmlElementToNode, windowToEventTarget, htmlDocumentToParentNode)
import DOM.HTML.Window (document)
import DOM.Node.Node (appendChild)
import DOM.Node.ParentNode (querySelector)
import DOM.Node.Types (elementToNode)

-- | A utility for appending an `HTMLElement` to the element selected using querySelector
-- | element once the document has loaded.
appendTo :: forall m eff. (MonadEff (dom :: DOM | eff) m)  => String -> HTMLElement -> m Unit
appendTo query e = onLoad $ \_ -> do
    b <- toMaybe <$> ((querySelector query <<< htmlDocumentToParentNode <=< document) =<< window)
    case b of
      Nothing -> pure unit
      Just b' -> void $ appendChild (htmlElementToNode e) (elementToNode b')

-- | A utility for appending an `HTMLElement` to the current document's `body`
-- | element once the document has loaded.
appendToBody :: forall m eff. (MonadEff (dom :: DOM | eff) m) => HTMLElement -> m Unit
appendToBody = appendTo "body"

onLoad :: forall m eff. (MonadEff (dom :: DOM | eff) m)
       => (Event -> Eff (dom :: DOM | eff) Unit) -> m Unit
onLoad callback = liftEff $ do
  addEventListener load (eventListener callback) false <<< windowToEventTarget =<< window

module Halogen.Util
  ( appendTo
  , appendToBody
  ) where

import Prelude

import Control.Bind ((<=<), (=<<))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (MonadEff, liftEff)

import Data.Maybe (Maybe(..))
import Data.Nullable (toMaybe)

import DOM (DOM())
import DOM.Event.EventTarget (eventListener, addEventListener)
import DOM.Event.EventTypes (load)
import DOM.Event.Types (Event())
import DOM.HTML (window)
import DOM.HTML.Document (body)
import DOM.HTML.Types (HTMLElement(), htmlElementToNode, windowToEventTarget, htmlDocumentToParentNode)
import DOM.HTML.Window (document)
import DOM.Node.Node (appendChild)
import DOM.Node.ParentNode (querySelector)
import DOM.Node.Types (elementToNode)

-- | A utility for appending an `HTMLElement` to the element selected using querySelector
-- | element once the document has loaded.
appendTo :: forall m eff. (MonadEff (dom :: DOM | eff) m)  => String -> HTMLElement -> m Unit
appendTo query e = onLoad $ \_ -> do
    b <- toMaybe <$> ((querySelector query <<< htmlDocumentToParentNode <=< document) =<< window)
    case b of
      Nothing -> pure unit
      Just b' -> void $ appendChild (htmlElementToNode e) (elementToNode b')

-- | A utility for appending an `HTMLElement` to the current document's `body`
-- | element once the document has loaded.
appendToBody :: forall m eff. (MonadEff (dom :: DOM | eff) m) => HTMLElement -> m Unit
appendToBody e = onLoad $ \_ -> do
    b <- toMaybe <$> ((body <=< document) =<< window)
    case b of
      Nothing -> pure unit
      Just b' -> void $ appendChild (htmlElementToNode e) (htmlElementToNode b')

onLoad :: forall m eff. (MonadEff (dom :: DOM | eff) m)
       => (Event -> Eff (dom :: DOM | eff) Unit) -> m Unit
onLoad callback = liftEff $ do
  addEventListener load (eventListener callback) false <<< windowToEventTarget =<< window


More button examples

More button examples

module Test.Main where

import Prelude hiding (div)

import Control.Monad.Eff
import Control.Monad.Eff.Console

import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe (fromJust)
import Data.Nullable (toMaybe)

import DOM (DOM())
import DOM.HTML (window)
import DOM.HTML.Document (body)
import DOM.HTML.Types (htmlElementToElement)
import DOM.HTML.Window (document)

import DOM.Node.Types (Element())

import React
import React.DOM (div, div', text)
import React.Bootstrap

import qualified React.DOM.Props as RP

main = body' >>= render ui
  where
  buttonPair props1 props2 txt =
    [ button (props1 buttonDefaults) [ text txt ]
    , button (props2 buttonDefaults) [ text txt ]
    ]
  sizeButtonToolbar size txt =
    buttonToolbar_ $ buttonPair _{ bsStyle = Primary, bsSize = size } _{ bsSize = size } txt

  ui :: ReactElement
  ui = div'
       [ buttonToolbar_
         [ button_ [ text "Default" ]
         , button (buttonDefaults { bsStyle = Primary }) [ text "Primary" ]
         , button (buttonDefaults { bsStyle = Success }) [ text "Success" ]
         , button (buttonDefaults { bsStyle = Info }) [ text "Info" ]
         , button (buttonDefaults { bsStyle = Warning }) [ text "Warning" ]
         , button (buttonDefaults { bsStyle = Danger }) [ text "Danger" ]
         , button (buttonDefaults { bsStyle = Link, href = "http://react-bootstrap.github.io/" }) [ text "Link" ]
         ]
       , div'
         [ sizeButtonToolbar (Just Large) "Large button"
         , sizeButtonToolbar Nothing "Default button"
         , sizeButtonToolbar (Just Small) "Small button"
         , sizeButtonToolbar (Just XSmall) "Extra small button"
         ]
       , div [ RP.className "well", RP.style { maxWidth: 400, margin: "0 auto 10px" }]
         [ button (buttonDefaults { bsStyle = Primary, bsSize= Just Large, block = true }) [ text "Block level button"]
         , button (buttonDefaults { bsSize = Just Large, block = true }) [ text "Block level button" ]
         ]
       , div'
         [ buttonToolbar_
           [ button (buttonDefaults { bsStyle = Primary, bsSize = Just Large, active = true}) [ text "Primary button" ]
           , button (buttonDefaults { bsSize = Just Large, active = true}) [ text "Primary button" ]
           ]
         ]
       , div'
         [ buttonToolbar_ $ buttonPair _{ bsStyle = Primary, bsSize = Just Large, disabled = true } _{ bsSize = Just Large, disabled = true } "Primary button"
         ]
       , div'
         [ button (buttonDefaults { href = "#"}) [ text "Link" ]
         , button_ [ text "Button" ]
         ]
       ]

  body' :: forall eff. Eff (dom :: DOM | eff) Element
  body' = do
    win <- window
    doc <- document win
    elm <- fromJust <$> toMaybe <$> body doc
    return $ htmlElementToElement elm

module Test.Main where

import Prelude

import Control.Monad.Eff
import Control.Monad.Eff.Console

import Data.Maybe (Maybe(..))
import Data.Maybe.Unsafe (fromJust)
import Data.Nullable (toMaybe)

import DOM (DOM())
import DOM.HTML (window)
import DOM.HTML.Document (body)
import DOM.HTML.Types (htmlElementToElement)
import DOM.HTML.Window (document)

import DOM.Node.Types (Element())

import React

import qualified React.DOM as RD
import qualified React.DOM.Props as RP
import qualified React.Bootstrap as RB

  -- <ButtonToolbar>
  --   {/* Standard button */}
  --   <Button>Default</Button>

  --   {/* Provides extra visual weight and identifies the primary action in a set of buttons */}
  --   <Button bsStyle='primary'>Primary</Button>

  --   {/* Indicates a successful or positive action */}
  --   <Button bsStyle='success'>Success</Button>

  --   {/* Contextual button for informational alert messages */}
  --   <Button bsStyle='info'>Info</Button>

  --   {/* Indicates caution should be taken with this action */}
  --   <Button bsStyle='warning'>Warning</Button>

  --   {/* Indicates a dangerous or potentially negative action */}
  --   <Button bsStyle='danger'>Danger</Button>

  --   {/* Deemphasize a button by making it look like a link while maintaining button behavior */}
  --   <Button bsStyle='link'>Link</Button>
  -- </ButtonToolbar>

main = body' >>= render ui
  where
  ui :: ReactElement
  ui = RB.buttonToolbar_
       [ RB.button_ [ RD.text "Default" ]
       , RB.button (RB.buttonDefaults { bsStyle = RB.Primary }) [ RD.text "Primary" ]
       , RB.button (RB.buttonDefaults { bsStyle = RB.Success }) [ RD.text "Warning" ]
       , RB.button (RB.buttonDefaults { bsStyle = RB.Info }) [ RD.text "Info" ]
       , RB.button (RB.buttonDefaults { bsStyle = RB.Danger }) [ RD.text "Danger" ]
       , RB.button (RB.buttonDefaults { bsStyle = RB.Link, href = "http://react-bootstrap.github.io/" }) [ RD.text "Link" ]
       ]

  body' :: forall eff. Eff (dom :: DOM | eff) Element
  body' = do
    win <- window
    doc <- document win
    elm <- fromJust <$> toMaybe <$> body doc
    return $ htmlElementToElement elm