Better pattern sharing for perf.

Better pattern sharing for perf.

-- | This module defines a type of maps as balanced 2-3 trees, based on
-- | <http://www.cs.princeton.edu/~dpw/courses/cos326-12/ass/2-3-trees.pdf>

module Data.Map
  ( Map()
  , showTree
  , empty
  , isEmpty
  , singleton
  , checkValid
  , insert
  , lookup
  , fromFoldable
  , fromFoldableWith
  , toList
  , fromList
  , fromListWith
  , delete
  , member
  , alter
  , update
  , keys
  , values
  , union
  , unionWith
  , unions
  , size
  ) where

import Prelude

import Data.Foldable (foldl, foldMap, foldr, Foldable)
import Data.List (List(..), length, nub)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Maybe.Unsafe (unsafeThrow)
import Data.Monoid (Monoid)
import Data.Traversable (traverse, Traversable)
import Data.Tuple (Tuple(..), uncurry)

-- | `Map k v` represents maps from keys of type `k` to values of type `v`.
data Map k v
  = Leaf
  | Two (Map k v) k v (Map k v)
  | Three (Map k v) k v (Map k v) k v (Map k v)

instance eqMap :: (Eq k, Eq v) => Eq (Map k v) where
  eq m1 m2 = toList m1 == toList m2

instance showMap :: (Show k, Show v) => Show (Map k v) where
  show m = "fromList " ++ show (toList m)

instance ordMap :: (Ord k, Ord v) => Ord (Map k v) where
  compare m1 m2 = compare (toList m1) (toList m2)

instance semigroupMap :: (Ord k) => Semigroup (Map k v) where
  append = union

instance monoidMap :: (Ord k) => Monoid (Map k v) where
  mempty = empty

instance functorMap :: Functor (Map k) where
  map _ Leaf = Leaf
  map f (Two left k v right) = Two (map f left) k (f v) (map f right)
  map f (Three left k1 v1 mid k2 v2 right) = Three (map f left) k1 (f v1) (map f mid) k2 (f v2) (map f right)

instance foldableMap :: Foldable (Map k) where
  foldl   f z m = foldl   f z (values m)
  foldr   f z m = foldr   f z (values m)
  foldMap f   m = foldMap f   (values m)

instance traversableMap :: (Ord k) => Traversable (Map k) where
  traverse f ms = foldr (\x acc -> union <$> x <*> acc) (pure empty) (((<$>) (uncurry singleton)) <$> (traverse f <$> toList ms))
  sequence = traverse id

-- | Render a `Map` as a `String`
showTree :: forall k v. (Show k, Show v) => Map k v -> String
showTree Leaf = "Leaf"
showTree (Two left k v right) =
  "Two (" ++ showTree left ++
  ") (" ++ show k ++
  ") (" ++ show v ++
  ") (" ++ showTree right ++ ")"
showTree (Three left k1 v1 mid k2 v2 right) =
  "Three (" ++ showTree left ++
  ") (" ++ show k1 ++
  ") (" ++ show v1 ++
  ") (" ++ showTree mid ++
  ") (" ++ show k2 ++
  ") (" ++ show v2 ++
  ") (" ++ showTree right ++ ")"

-- | An empty map
empty :: forall k v. Map k v
empty = Leaf

-- | Test if a map is empty
isEmpty :: forall k v. Map k v -> Boolean
isEmpty Leaf = true
isEmpty _ = false

-- | Create a map with one key/value pair
singleton :: forall k v. k -> v -> Map k v
singleton k v = Two Leaf k v Leaf

-- | Check whether the underlying tree satisfies the 2-3 invariant
-- |
-- | This function is provided for internal use.
checkValid :: forall k v. Map k v -> Boolean
checkValid tree = length (nub (allHeights tree)) == one
  where
  allHeights :: Map k v -> List Int
  allHeights Leaf = pure zero
  allHeights (Two left _ _ right) = map (\n -> n + one) (allHeights left ++ allHeights right)
  allHeights (Three left _ _ mid _ _ right) = map (\n -> n + one) (allHeights left ++ allHeights mid ++ allHeights right)

-- | Lookup a value for the specified key
lookup :: forall k v. (Ord k) => k -> Map k v -> Maybe v
lookup _ Leaf = Nothing
lookup k tree =
  let comp :: k -> k -> Ordering
      comp = compare
  in case tree of
    Two left k1 v right ->
      case comp k k1 of
        EQ -> Just v
        LT -> lookup k left
        _  -> lookup k right
    Three left k1 v1 mid k2 v2 right ->
      case comp k k1 of
        EQ -> Just v1
        c1 ->
          case c1, comp k k2 of
            _ , EQ -> Just v2
            LT, _  -> lookup k left
            _ , GT -> lookup k right
            _ , _  -> lookup k mid

-- | Test if a key is a member of a map
member :: forall k v. (Ord k) => k -> Map k v -> Boolean
member k m = isJust (k `lookup` m)

data TreeContext k v
  = TwoLeft k v (Map k v)
  | TwoRight (Map k v) k v
  | ThreeLeft k v (Map k v) k v (Map k v)
  | ThreeMiddle (Map k v) k v k v (Map k v)
  | ThreeRight (Map k v) k v (Map k v) k v

fromZipper :: forall k v. (Ord k) => List (TreeContext k v) -> Map k v -> Map k v
fromZipper Nil tree = tree
fromZipper (Cons x ctx) tree =
  case x of
    TwoLeft k1 v1 right -> fromZipper ctx (Two tree k1 v1 right)
    TwoRight left k1 v1 -> fromZipper ctx (Two left k1 v1 tree)
    ThreeLeft k1 v1 mid k2 v2 right -> fromZipper ctx (Three tree k1 v1 mid k2 v2 right)
    ThreeMiddle left k1 v1 k2 v2 right -> fromZipper ctx (Three left k1 v1 tree k2 v2 right)
    ThreeRight left k1 v1 mid k2 v2 -> fromZipper ctx (Three left k1 v1 mid k2 v2 tree)

data KickUp k v = KickUp (Map k v) k v (Map k v)

-- | Insert a key/value pair into a map
insert :: forall k v. (Ord k) => k -> v -> Map k v -> Map k v
insert = down Nil
  where
  comp :: k -> k -> Ordering
  comp = compare

  down :: List (TreeContext k v) -> k -> v -> Map k v -> Map k v
  down ctx k v Leaf = up ctx (KickUp Leaf k v Leaf)
  down ctx k v (Two left k1 v1 right) =
    case comp k k1 of
      EQ -> fromZipper ctx (Two left k v right)
      LT -> down (Cons (TwoLeft k1 v1 right) ctx) k v left
      _  -> down (Cons (TwoRight left k1 v1) ctx) k v right
  down ctx k v (Three left k1 v1 mid k2 v2 right) =
    case comp k k1 of
      EQ -> fromZipper ctx (Three left k v mid k2 v2 right)
      c1 ->
        case c1, comp k k2 of
          _ , EQ -> fromZipper ctx (Three left k1 v1 mid k v right)
          LT, _  -> down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) k v left
          GT, LT -> down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) k v mid
          _ , _  -> down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) k v right

  up :: List (TreeContext k v) -> KickUp k v -> Map k v
  up Nil (KickUp left k v right) = Two left k v right
  up (Cons x ctx) kup =
    case x, kup of
      TwoLeft k1 v1 right, KickUp left k v mid -> fromZipper ctx (Three left k v mid k1 v1 right)
      TwoRight left k1 v1, KickUp mid k v right -> fromZipper ctx (Three left k1 v1 mid k v right)
      ThreeLeft k1 v1 c k2 v2 d, KickUp a k v b -> up ctx (KickUp (Two a k v b) k1 v1 (Two c k2 v2 d))
      ThreeMiddle a k1 v1 k2 v2 d, KickUp b k v c -> up ctx (KickUp (Two a k1 v1 b) k v (Two c k2 v2 d))
      ThreeRight a k1 v1 b k2 v2, KickUp c k v d -> up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k v d))

-- | Delete a key and its corresponding value from a map
delete :: forall k v. (Ord k) => k -> Map k v -> Map k v
delete = down Nil
  where
  comp :: k -> k -> Ordering
  comp = compare

  down :: List (TreeContext k v) -> k -> Map k v -> Map k v
  down ctx _ Leaf = fromZipper ctx Leaf
  down ctx k (Two left k1 v1 right) =
    case right, comp k k1 of
      Leaf, EQ -> up ctx Leaf
      _   , EQ -> let max = maxNode left
                   in removeMaxNode (Cons (TwoLeft max.key max.value right) ctx) left
      _   , LT -> down (Cons (TwoLeft k1 v1 right) ctx) k left
      _   , _  -> down (Cons (TwoRight left k1 v1) ctx) k right
  down ctx k (Three left k1 v1 mid k2 v2 right) =
    let leaves =
          case left, mid, right of
            Leaf, Leaf, Leaf -> true
            _   , _   , _    -> false
    in case leaves, comp k k1, comp k k2 of
      true, EQ, _  -> fromZipper ctx (Two Leaf k2 v2 Leaf)
      true, _ , EQ -> fromZipper ctx (Two Leaf k1 v1 Leaf)
      _   , EQ, _  -> let max = maxNode left
                       in removeMaxNode (Cons (ThreeLeft max.key max.value mid k2 v2 right) ctx) left
      _   , _ , EQ -> let max = maxNode mid
                       in removeMaxNode (Cons (ThreeMiddle left k1 v1 max.key max.value right) ctx) mid
      _   , LT, _  -> down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) k left
      _   , GT, LT -> down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) k mid
      _   , _ , _  -> down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) k right

  up :: List (TreeContext k v) -> Map k v -> Map k v
  up Nil tree = tree
  up (Cons x ctx) tree =
    case x, tree of
      TwoLeft k1 v1 Leaf, Leaf -> fromZipper ctx (Two Leaf k1 v1 Leaf)
      TwoRight Leaf k1 v1, Leaf -> fromZipper ctx (Two Leaf k1 v1 Leaf)
      TwoLeft k1 v1 (Two m k2 v2 r), l -> up ctx (Three l k1 v1 m k2 v2 r)
      TwoRight (Two l k1 v1 m) k2 v2, r -> up ctx (Three l k1 v1 m k2 v2 r)
      TwoLeft k1 v1 (Three b k2 v2 c k3 v3 d), a -> fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
      TwoRight (Three a k1 v1 b k2 v2 c) k3 v3, d -> fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
      ThreeLeft k1 v1 Leaf k2 v2 Leaf, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
      ThreeMiddle Leaf k1 v1 k2 v2 Leaf, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
      ThreeRight Leaf k1 v1 Leaf k2 v2, Leaf -> fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
      ThreeLeft k1 v1 (Two b k2 v2 c) k3 v3 d, a -> fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
      ThreeMiddle (Two a k1 v1 b) k2 v2 k3 v3 d, c -> fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
      ThreeMiddle a k1 v1 k2 v2 (Two c k3 v3 d), b -> fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
      ThreeRight a k1 v1 (Two b k2 v2 c) k3 v3, d -> fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
      ThreeLeft k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 e, a -> fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
      ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e, d -> fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
      ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e), b -> fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
      ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4, e -> fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
      _, _ -> unsafeThrow "Impossible case in 'up'"

  maxNode :: Map k v -> { key :: k, value :: v }
  maxNode (Two _ k v Leaf) = { key: k, value: v }
  maxNode (Two _ _ _ right) = maxNode right
  maxNode (Three _ _ _ _ k v Leaf) = { key: k, value: v }
  maxNode (Three _ _ _ _ _ _ right) = maxNode right
  maxNode Leaf = unsafeThrow "Impossible case in 'maxNode'"

  removeMaxNode :: List (TreeContext k v) -> Map k v -> Map k v
  removeMaxNode ctx (Two Leaf _ _ Leaf) = up ctx Leaf
  removeMaxNode ctx (Two left k v right) = removeMaxNode (Cons (TwoRight left k v) ctx) right
  removeMaxNode ctx (Three Leaf k1 v1 Leaf _ _ Leaf) = up (Cons (TwoRight Leaf k1 v1) ctx) Leaf
  removeMaxNode ctx (Three left k1 v1 mid k2 v2 right) = removeMaxNode (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) right
  removeMaxNode _ Leaf = unsafeThrow "Impossible case in 'removeMaxNode'"

-- | Insert the value, delete a value, or update a value for a key in a map
alter :: forall k v. (Ord k) => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

-- | Update or delete the value for a key in a map
update :: forall k v. (Ord k) => (v -> Maybe v) -> k -> Map k v -> Map k v
update f k m = alter (maybe Nothing f) k m

-- | Convert any foldable collection of key/value pairs to a map.
-- | On key collision, later values take precedence over earlier ones.
fromFoldable :: forall f k v. (Ord k, Foldable f) => f (Tuple k v) -> Map k v
fromFoldable = foldl (\m (Tuple k v) -> insert k v m) empty

-- | Convert any foldable collection of key/value pairs to a map.
-- | On key collision, the values are configurably combined.
fromFoldableWith :: forall f k v. (Ord k, Foldable f) => (v -> v -> v) -> f (Tuple k v) -> Map k v
fromFoldableWith f = foldl (\m (Tuple k v) -> alter (combine v) k m) empty where
  combine v (Just v') = Just $ f v v'
  combine v Nothing = Just v

-- | Convert a map to a list of key/value pairs
toList :: forall k v. Map k v -> List (Tuple k v)
toList Leaf = Nil
toList (Two left k v right) = toList left ++ pure (Tuple k v) ++ toList right
toList (Three left k1 v1 mid k2 v2 right) = toList left ++ pure (Tuple k1 v1) ++ toList mid ++ pure (Tuple k2 v2) ++ toList right

-- | Create a map from a list of key/value pairs
fromList :: forall k v. (Ord k) => List (Tuple k v) -> Map k v
fromList = fromFoldable

-- | Create a map from a list of key/value pairs, using the specified function
-- | to combine values for duplicate keys.
fromListWith :: forall k v. (Ord k) => (v -> v -> v) -> List (Tuple k v) -> Map k v
fromListWith = fromFoldableWith

-- | Get a list of the keys contained in a map
keys :: forall k v. Map k v -> List k
keys Leaf = Nil
keys (Two left k _ right) = keys left ++ pure k ++ keys right
keys (Three left k1 _ mid k2 _ right) = keys left ++ pure k1 ++ keys mid ++ pure k2 ++ keys right

-- | Get a list of the values contained in a map
values :: forall k v. Map k v -> List v
values Leaf = Nil
values (Two left _ v right) = values left ++ pure v ++ values right
values (Three left _ v1 mid _ v2 right) = values left ++ pure v1 ++ values mid ++ pure v2 ++ values right

-- | Compute the union of two maps, using the specified function
-- | to combine values for duplicate keys.
unionWith :: forall k v. (Ord k) => (v -> v -> v) -> Map k v -> Map k v -> Map k v
unionWith f m1 m2 = foldl go m2 (toList m1)
  where
  go m (Tuple k v) = alter (Just <<< maybe v (f v)) k m

-- | Compute the union of two maps, preferring values from the first map in the case
-- | of duplicate keys
union :: forall k v. (Ord k) => Map k v -> Map k v -> Map k v
union = unionWith const

-- | Compute the union of a collection of maps
unions :: forall k v f. (Ord k, Foldable f) => f (Map k v) -> Map k v
unions = foldl union empty

-- | Calculate the number of key/value pairs in a map
size :: forall k v. Map k v -> Int
size = length <<< values

-- | This module defines a type of maps as balanced 2-3 trees, based on
-- | <http://www.cs.princeton.edu/~dpw/courses/cos326-12/ass/2-3-trees.pdf>

module Data.Map
  ( Map()
  , showTree
  , empty
  , isEmpty
  , singleton
  , checkValid
  , insert
  , lookup
  , fromFoldable
  , fromFoldableWith
  , toList
  , fromList
  , fromListWith
  , delete
  , member
  , alter
  , update
  , keys
  , values
  , union
  , unionWith
  , unions
  , size
  ) where

import Prelude

import Data.Foldable (foldl, foldMap, foldr, Foldable)
import Data.List (List(..), length, nub)
import Data.Maybe (Maybe(..), maybe, isJust)
import Data.Maybe.Unsafe (unsafeThrow)
import Data.Monoid (Monoid)
import Data.Traversable (traverse, Traversable)
import Data.Tuple (Tuple(..), uncurry)

-- | `Map k v` represents maps from keys of type `k` to values of type `v`.
data Map k v
  = Leaf
  | Two (Map k v) k v (Map k v)
  | Three (Map k v) k v (Map k v) k v (Map k v)

instance eqMap :: (Eq k, Eq v) => Eq (Map k v) where
  eq m1 m2 = toList m1 == toList m2

instance showMap :: (Show k, Show v) => Show (Map k v) where
  show m = "fromList " ++ show (toList m)

instance ordMap :: (Ord k, Ord v) => Ord (Map k v) where
  compare m1 m2 = compare (toList m1) (toList m2)

instance semigroupMap :: (Ord k) => Semigroup (Map k v) where
  append = union

instance monoidMap :: (Ord k) => Monoid (Map k v) where
  mempty = empty

instance functorMap :: Functor (Map k) where
  map _ Leaf = Leaf
  map f (Two left k v right) = Two (map f left) k (f v) (map f right)
  map f (Three left k1 v1 mid k2 v2 right) = Three (map f left) k1 (f v1) (map f mid) k2 (f v2) (map f right)

instance foldableMap :: Foldable (Map k) where
  foldl   f z m = foldl   f z (values m)
  foldr   f z m = foldr   f z (values m)
  foldMap f   m = foldMap f   (values m)

instance traversableMap :: (Ord k) => Traversable (Map k) where
  traverse f ms = foldr (\x acc -> union <$> x <*> acc) (pure empty) (((<$>) (uncurry singleton)) <$> (traverse f <$> toList ms))
  sequence = traverse id

-- | Render a `Map` as a `String`
showTree :: forall k v. (Show k, Show v) => Map k v -> String
showTree Leaf = "Leaf"
showTree (Two left k v right) =
  "Two (" ++ showTree left ++
  ") (" ++ show k ++
  ") (" ++ show v ++
  ") (" ++ showTree right ++ ")"
showTree (Three left k1 v1 mid k2 v2 right) =
  "Three (" ++ showTree left ++
  ") (" ++ show k1 ++
  ") (" ++ show v1 ++
  ") (" ++ showTree mid ++
  ") (" ++ show k2 ++
  ") (" ++ show v2 ++
  ") (" ++ showTree right ++ ")"

-- | An empty map
empty :: forall k v. Map k v
empty = Leaf

-- | Test if a map is empty
isEmpty :: forall k v. Map k v -> Boolean
isEmpty Leaf = true
isEmpty _ = false

-- | Create a map with one key/value pair
singleton :: forall k v. k -> v -> Map k v
singleton k v = Two Leaf k v Leaf

-- | Check whether the underlying tree satisfies the 2-3 invariant
-- |
-- | This function is provided for internal use.
checkValid :: forall k v. Map k v -> Boolean
checkValid tree = length (nub (allHeights tree)) == one
  where
  allHeights :: Map k v -> List Int
  allHeights Leaf = pure zero
  allHeights (Two left _ _ right) = map (\n -> n + one) (allHeights left ++ allHeights right)
  allHeights (Three left _ _ mid _ _ right) = map (\n -> n + one) (allHeights left ++ allHeights mid ++ allHeights right)

-- | Lookup a value for the specified key
lookup :: forall k v. (Ord k) => k -> Map k v -> Maybe v
lookup _ Leaf = Nothing
lookup k (Two _ k1 v _) | k == k1 = Just v
lookup k (Two left k1 _ _) | k < k1 = lookup k left
lookup k (Two _ _ _ right) = lookup k right
lookup k (Three _ k1 v1 _ _ _ _) | k == k1 = Just v1
lookup k (Three _ _ _ _ k2 v2 _) | k == k2 = Just v2
lookup k (Three left k1 _ _ _ _ _) | k < k1 = lookup k left
lookup k (Three _ k1 _ mid k2 _ _) | k1 < k && k <= k2 = lookup k mid
lookup k (Three _ _ _ _ _ _ right) = lookup k right

-- | Test if a key is a member of a map
member :: forall k v. (Ord k) => k -> Map k v -> Boolean
member k m = isJust (k `lookup` m)

data TreeContext k v
  = TwoLeft k v (Map k v)
  | TwoRight (Map k v) k v
  | ThreeLeft k v (Map k v) k v (Map k v)
  | ThreeMiddle (Map k v) k v k v (Map k v)
  | ThreeRight (Map k v) k v (Map k v) k v

fromZipper :: forall k v. (Ord k) => List (TreeContext k v) -> Map k v -> Map k v
fromZipper Nil tree = tree
fromZipper (Cons (TwoLeft k1 v1 right) ctx) left = fromZipper ctx (Two left k1 v1 right)
fromZipper (Cons (TwoRight left k1 v1) ctx) right = fromZipper ctx (Two left k1 v1 right)
fromZipper (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) left = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
fromZipper (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) mid = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
fromZipper (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) right = fromZipper ctx (Three left k1 v1 mid k2 v2 right)

data KickUp k v = KickUp (Map k v) k v (Map k v)

-- | Insert a key/value pair into a map
insert :: forall k v. (Ord k) => k -> v -> Map k v -> Map k v
insert = down Nil
  where
  down :: List (TreeContext k v) -> k -> v -> Map k v -> Map k v
  down ctx k v Leaf = up ctx (KickUp Leaf k v Leaf)
  down ctx k v (Two left k1 _ right) | k == k1 = fromZipper ctx (Two left k v right)
  down ctx k v (Two left k1 v1 right) | k < k1 = down (Cons (TwoLeft k1 v1 right) ctx) k v left
  down ctx k v (Two left k1 v1 right) = down (Cons (TwoRight left k1 v1) ctx) k v right
  down ctx k v (Three left k1 _ mid k2 v2 right) | k == k1 = fromZipper ctx (Three left k v mid k2 v2 right)
  down ctx k v (Three left k1 v1 mid k2 _ right) | k == k2 = fromZipper ctx (Three left k1 v1 mid k v right)
  down ctx k v (Three left k1 v1 mid k2 v2 right) | k < k1 = down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) k v left
  down ctx k v (Three left k1 v1 mid k2 v2 right) | k1 < k && k <= k2 = down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) k v mid
  down ctx k v (Three left k1 v1 mid k2 v2 right) = down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) k v right

  up :: List (TreeContext k v) -> KickUp k v -> Map k v
  up Nil (KickUp left k v right) = Two left k v right
  up (Cons (TwoLeft k1 v1 right) ctx) (KickUp left k v mid) = fromZipper ctx (Three left k v mid k1 v1 right)
  up (Cons (TwoRight left k1 v1) ctx) (KickUp mid k v right) = fromZipper ctx (Three left k1 v1 mid k v right)
  up (Cons (ThreeLeft k1 v1 c k2 v2 d) ctx) (KickUp a k v b) = up ctx (KickUp (Two a k v b) k1 v1 (Two c k2 v2 d))
  up (Cons (ThreeMiddle a k1 v1 k2 v2 d) ctx) (KickUp b k v c) = up ctx (KickUp (Two a k1 v1 b) k v (Two c k2 v2 d))
  up (Cons (ThreeRight a k1 v1 b k2 v2) ctx) (KickUp c k v d) = up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k v d))

-- | Delete a key and its corresponding value from a map
delete :: forall k v. (Ord k) => k -> Map k v -> Map k v
delete = down Nil
  where
  down :: List (TreeContext k v) -> k -> Map k v -> Map k v
  down ctx _ Leaf = fromZipper ctx Leaf
  down ctx k (Two Leaf k1 _ Leaf)
    | k == k1 = up ctx Leaf
  down ctx k (Two left k1 v1 right)
    | k == k1   = let max = maxNode left
                    in removeMaxNode (Cons (TwoLeft max.key max.value right) ctx) left
    | k < k1    = down (Cons (TwoLeft k1 v1 right) ctx) k left
    | otherwise = down (Cons (TwoRight left k1 v1) ctx) k right
  down ctx k (Three Leaf k1 v1 Leaf k2 v2 Leaf)
    | k == k1 = fromZipper ctx (Two Leaf k2 v2 Leaf)
    | k == k2 = fromZipper ctx (Two Leaf k1 v1 Leaf)
  down ctx k (Three left k1 v1 mid k2 v2 right)
    | k == k1 = let max = maxNode left
                  in removeMaxNode (Cons (ThreeLeft max.key max.value mid k2 v2 right) ctx) left
    | k == k2 = let max = maxNode mid
                  in removeMaxNode (Cons (ThreeMiddle left k1 v1 max.key max.value right) ctx) mid
    | k < k1               = down (Cons (ThreeLeft k1 v1 mid k2 v2 right) ctx) k left
    | k1 < k && k < k2 = down (Cons (ThreeMiddle left k1 v1 k2 v2 right) ctx) k mid
    | otherwise            = down (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) k right

  up :: List (TreeContext k v) -> Map k v -> Map k v
  up Nil tree = tree
  up (Cons (TwoLeft k1 v1 Leaf) ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
  up (Cons (TwoRight Leaf k1 v1) ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
  up (Cons (TwoLeft k1 v1 (Two m k2 v2 r)) ctx) l = up ctx (Three l k1 v1 m k2 v2 r)
  up (Cons (TwoRight (Two l k1 v1 m) k2 v2) ctx) r = up ctx (Three l k1 v1 m k2 v2 r)
  up (Cons (TwoLeft k1 v1 (Three b k2 v2 c k3 v3 d)) ctx) a = fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
  up (Cons (TwoRight (Three a k1 v1 b k2 v2 c) k3 v3) ctx) d = fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
  up (Cons (ThreeLeft k1 v1 Leaf k2 v2 Leaf) ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (Cons (ThreeMiddle Leaf k1 v1 k2 v2 Leaf) ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (Cons (ThreeRight Leaf k1 v1 Leaf k2 v2) ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (Cons (ThreeLeft k1 v1 (Two b k2 v2 c) k3 v3 d) ctx) a = fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
  up (Cons (ThreeMiddle (Two a k1 v1 b) k2 v2 k3 v3 d) ctx) c = fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
  up (Cons (ThreeMiddle a k1 v1 k2 v2 (Two c k3 v3 d)) ctx) b = fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
  up (Cons (ThreeRight a k1 v1 (Two b k2 v2 c) k3 v3) ctx) d = fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
  up (Cons (ThreeLeft k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 e) ctx) a = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
  up (Cons (ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e) ctx) d = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
  up (Cons (ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e)) ctx) b = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
  up (Cons (ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4) ctx) e = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
  up _ _ = unsafeThrow "Impossible case in 'up'"

  maxNode :: Map k v -> { key :: k, value :: v }
  maxNode (Two _ k v Leaf) = { key: k, value: v }
  maxNode (Two _ _ _ right) = maxNode right
  maxNode (Three _ _ _ _ k v Leaf) = { key: k, value: v }
  maxNode (Three _ _ _ _ _ _ right) = maxNode right
  maxNode Leaf = unsafeThrow "Impossible case in 'maxNode'"

  removeMaxNode :: List (TreeContext k v) -> Map k v -> Map k v
  removeMaxNode ctx (Two Leaf _ _ Leaf) = up ctx Leaf
  removeMaxNode ctx (Two left k v right) = removeMaxNode (Cons (TwoRight left k v) ctx) right
  removeMaxNode ctx (Three Leaf k1 v1 Leaf _ _ Leaf) = up (Cons (TwoRight Leaf k1 v1) ctx) Leaf
  removeMaxNode ctx (Three left k1 v1 mid k2 v2 right) = removeMaxNode (Cons (ThreeRight left k1 v1 mid k2 v2) ctx) right
  removeMaxNode _ Leaf = unsafeThrow "Impossible case in 'removeMaxNode'"

-- | Insert the value, delete a value, or update a value for a key in a map
alter :: forall k v. (Ord k) => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

-- | Update or delete the value for a key in a map
update :: forall k v. (Ord k) => (v -> Maybe v) -> k -> Map k v -> Map k v
update f k m = alter (maybe Nothing f) k m

-- | Convert any foldable collection of key/value pairs to a map.
-- | On key collision, later values take precedence over earlier ones.
fromFoldable :: forall f k v. (Ord k, Foldable f) => f (Tuple k v) -> Map k v
fromFoldable = foldl (\m (Tuple k v) -> insert k v m) empty

-- | Convert any foldable collection of key/value pairs to a map.
-- | On key collision, the values are configurably combined.
fromFoldableWith :: forall f k v. (Ord k, Foldable f) => (v -> v -> v) -> f (Tuple k v) -> Map k v
fromFoldableWith f = foldl (\m (Tuple k v) -> alter (combine v) k m) empty where
  combine v (Just v') = Just $ f v v'
  combine v Nothing = Just v

-- | Convert a map to a list of key/value pairs
toList :: forall k v. Map k v -> List (Tuple k v)
toList Leaf = Nil
toList (Two left k v right) = toList left ++ pure (Tuple k v) ++ toList right
toList (Three left k1 v1 mid k2 v2 right) = toList left ++ pure (Tuple k1 v1) ++ toList mid ++ pure (Tuple k2 v2) ++ toList right

-- | Create a map from a list of key/value pairs
fromList :: forall k v. (Ord k) => List (Tuple k v) -> Map k v
fromList = fromFoldable

-- | Create a map from a list of key/value pairs, using the specified function
-- | to combine values for duplicate keys.
fromListWith :: forall k v. (Ord k) => (v -> v -> v) -> List (Tuple k v) -> Map k v
fromListWith = fromFoldableWith

-- | Get a list of the keys contained in a map
keys :: forall k v. Map k v -> List k
keys Leaf = Nil
keys (Two left k _ right) = keys left ++ pure k ++ keys right
keys (Three left k1 _ mid k2 _ right) = keys left ++ pure k1 ++ keys mid ++ pure k2 ++ keys right

-- | Get a list of the values contained in a map
values :: forall k v. Map k v -> List v
values Leaf = Nil
values (Two left _ v right) = values left ++ pure v ++ values right
values (Three left _ v1 mid _ v2 right) = values left ++ pure v1 ++ values mid ++ pure v2 ++ values right

-- | Compute the union of two maps, using the specified function
-- | to combine values for duplicate keys.
unionWith :: forall k v. (Ord k) => (v -> v -> v) -> Map k v -> Map k v -> Map k v
unionWith f m1 m2 = foldl go m2 (toList m1)
  where
  go m (Tuple k v) = alter (Just <<< maybe v (f v)) k m

-- | Compute the union of two maps, preferring values from the first map in the case
-- | of duplicate keys
union :: forall k v. (Ord k) => Map k v -> Map k v -> Map k v
union = unionWith const

-- | Compute the union of a collection of maps
unions :: forall k v f. (Ord k, Foldable f) => f (Map k v) -> Map k v
unions = foldl union empty

-- | Calculate the number of key/value pairs in a map
size :: forall k v. Map k v -> Int
size = length <<< values


more accurate cost model (new)

more accurate cost model (new)

module KanColle.Expedition.CostModel where

import Prelude
import KanColle.Expedition.SType
import Data.Maybe
import Control.MonadPlus

data MaxCost = MC
  { fuel :: Int
  , ammo :: Int
  }

instance semigroupMaxCost :: Semigroup MaxCost where
  append (MC a) (MC b) = MC {fuel: a.fuel, ammo: b.fuel}

mkMC :: Int -> Int -> MaxCost
mkMC fuel ammo = MC {fuel: fuel, ammo: ammo}

-- | multiple `MaxCost` with an integer
mcTimes :: MaxCost -> Int -> MaxCost
mcTimes _ 0 = mkMC 0 0
mcTimes (MC a) n = mkMC (a.fuel*n) (a.ammo*n)

-- | `CostModel` calculates the total maximum cost
-- | given a ship type and how many ships are present.
-- | This cost model is designed for just one fleet so
-- | the input number should only be one of `[0,1,2,3,4,5,6]`.
-- | Note that for a cost model `f`, it's not guaranteed
-- | that `f stype a + f stype b` and `f stype (a+b)` give
-- | the same answer.
type CostModel = SType -> Int -> Maybe MaxCost

-- | a normal cost model assumes all ships are remodelled to
-- | their final forms. (the exceptions are like Taigei, Chitose-A and Chiyoda-A
-- | as their further remodels also change ship type.)
normalCostModel :: CostModel
normalCostModel stype = case stype of
    DD -> ddCost
    CL -> clCost
    CVLLike -> cvlLikeCost
    SSLike -> ssLikeCost
    CA -> caCost
    BBV -> bbvCost
    AS -> asCost
    CT -> ctCost
    AV -> avCost
  where
    ddCost n =
      -- use Mutsuki class destroyers
      Just (mcTimes (mkMC 15 15) n)
    clCost n
      | n <= 2 =
        -- use 2 Tenryuu class ships,
        Just (mcTimes (mkMC 25 25) n)
      | n <= 6 = do
        -- if we need more, fill the rest with some Nagara class ships
        c <- clCost 2
        Just (c <> mcTimes (mkMC 25 30) (n-2))
      | otherwise = Nothing
    avCost n
      | n <= 2 =
        -- Chitose-A and Chiyoda-A
        Just (mcTimes (mkMC 35 45) n)
      | n <= 3 = do
        -- and Mizuho Kai
        c <- avCost 2
        Just (c <> mkMC 40 45)
      | n <= 4 = do
        -- and Akitsushima Kai
        c <- avCost 3
        Just (c <> mkMC 60 15)
      | otherwise = Nothing
    -- Taigei
    asCost n = do
        guard (n <= 1)
        Just (mcTimes (mkMC 35 10) n)
    -- Katori class
    ctCost n = do
        guard (n <= 2)
        Just (mcTimes (mkMC 35 20) n)
    caCost n
      | n <= 1 =
        -- Aoba Kai
        Just (mcTimes (mkMC 35 55) n)
      | n <= 4 = do
        -- Furutaka Kai Ni, Kako Kai Ni, Kinugasa Kai Ni
        c <- caCost 1
        Just (c <> mcTimes (mkMC 35 65) (n-1))
      | n <= 6 = do
        -- Takao Kai, Atago Kai
        c <- caCost 4
        Just (c <> mcTimes (mkMC 40 70) (n-4))
      | otherwise = Nothing
    bbvCost n
      | n <= 2 =
        -- Ise class
        Just (mcTimes (mkMC 95 105) n)
      | n <= 4 = do
        -- Fusou class
        c <- bbvCost 2
        Just (c <> mcTimes (mkMC 105 140) (n-2))
      | otherwise = Nothing
    ssLikeCost n
      | n <= 1 =
        -- Maruyu Kai
        Just (mcTimes (mkMC 10 10) n)
      | n <= 6 = do
        -- no need for SSV if we just consider:
        -- I-168, I-58, I-19, I-8 and Ro-500
        c <- ssLikeCost 1
        Just (mcTimes (mkMC 10 20) (n-1))
      | otherwise = Nothing
    cvlLikeCost n
      | n <= 1 =
        -- Houshou Kai
        Just (mcTimes (mkMC 30 30) n)
      | n <= 2 = do
        -- Ryuuhou Kai
        c <- cvlLikeCost 1
        Just (c <> mcTimes (mkMC 35 40) (n-1))
      | n <= 4 = do
        -- Chitose-A, Chiyoda-A
        c <- cvlLikeCost 2
        Just (c <> mcTimes (mkMC 35 45) (n-2))
      | n <= 6 = do
        -- Shouhou Kai, Zuihou Kai
        c <- cvlLikeCost 4
        Just (c <> mcTimes (mkMC 40 40) (n-4))
      | otherwise = Nothing

error: pathspec 'src/KanColle/Expedition/CostModel.purs' did not match any file(s) known to git


Add third way to create a table

Add third way to create a table

Signed-off-by: Joern Bernhardt <7b85a41a628204b76aba4326273a3ccc74bd009a@campudus.com>

module ThirdTab
  ( class ColT
  ) where

import Data.List

class ColT a

type Cells a = List a

newtype ThirdTab colTypes = ThirdTab
  { cols :: List colTypes
  , rows :: List (Cells colTypes)
  }

empty :: forall a. ColT a => ThirdTab a
empty = ThirdTab
  { cols : Nil
  , rows : Nil
  }

addColumn :: forall a. ColT a => Int -> String -> ThirdTab a -> ThirdTab a
addColumn id name (ThirdTab table) = ThirdTab { cols: table.cols, rows: table.rows }

error: pathspec '05-purescript-project/src/ThirdTab.purs' did not match any file(s) known to git


Refactoring Render Code

Refactoring Render Code

module Openspace.Ui.Render where

import           Control.Apply
import           Control.Monad.Eff
import           DOM
import           Data.Array
import           Data.Function
import qualified Data.Map as M
import           Data.Maybe
import           Data.Tuple
import           Openspace.Types

type Grid = [[Maybe SanitizedTopic]]

sanitizeTopic :: Topic -> SanitizedTopic
sanitizeTopic (Topic t) = { topicDescription: t.topicDescription,
                            topicTyp: show t.topicTyp }

findIn :: Room -> Block -> M.Map Slot Topic -> Maybe SanitizedTopic
findIn r b timeslots = M.lookup (Slot {block:b, room:r}) timeslots
                       <#> sanitizeTopic

makeGrid :: AppState -> Grid
makeGrid as = (\r ->
                (\b -> findIn r b as.timeslots ) <$> (sort as.blocks)
              ) <$> as.rooms

foreign import renderMenu
  """
  function renderMenu(topicTypes){
    return function(){
      React.render(
        React.createElement(Menu, {topicTypes: topicTypes}),
        document.getElementById('menu')
        );
    }
  }
  """ :: forall eff. [String] -> Eff( dom::DOM | eff ) Unit

foreign import renderTopicsImpl
  """
  function renderTopicsImpl(topics){
    return function(){
      React.render(
        React.createElement(Topics, {topics: topics}),
        document.getElementById('topics')
        )
      }
    }
    """ :: forall eff. [SanitizedTopic] -> Eff( dom::DOM | eff ) Unit

foreign import renderGridImpl
  """
  function renderGridImpl(rooms, blocks, grid){
    return function(){
      React.render(
        React.createElement(Grid, {rooms: rooms, blocks: blocks, grid: grid}),
          document.getElementById('grid')
        );
    }
  }
  """ :: forall eff. Fn3 [Room] [Block] Grid (Eff( dom::DOM | eff ) Unit)

renderTopics :: forall eff. AppState -> Eff( dom::DOM | eff ) Unit
renderTopics as = renderTopicsImpl (sanitizeTopic <$> filter topicNotInGrid as.topics)
  where topicNotInGrid t = elemIndex t (M.values as.timeslots) == -1

renderGrid :: forall eff. AppState -> Eff( dom::DOM | eff ) Unit
renderGrid as = runFn3 renderGridImpl as.rooms (sort as.blocks) (makeGrid as)

renderApp :: forall eff. AppState -> Eff( dom::DOM | eff ) Unit
renderApp as = renderTopics as *> renderGrid as

module Openspace.Ui.Render where

import           Control.Monad.Eff
import           DOM
import           Data.Array
import qualified Data.Map as M
import           Data.Maybe
import           Data.Tuple
import           Openspace.Types

sanitizeTopic :: Topic -> SanitizedTopic
sanitizeTopic (Topic t) = { topicDescription: t.topicDescription,
                            topicTyp: show t.topicTyp }

sanitizeSlot :: Slot -> SanitizedSlot
sanitizeSlot (Slot s) = { room  : show s.room
                        , block : show s.block
                        }

sanitizeTimeslot :: Timeslot -> SanitizedTimeslot
sanitizeTimeslot (Tuple s t) = Tuple (sanitizeSlot s) (sanitizeTopic t)

sanitizeAppState :: AppState -> SanitizedAppState
sanitizeAppState as = let topicNotInGrid t = (filter (\t' -> t == t')(M.values as.timeslots)) == []
                      in { topics          : sanitizeTopic    <$> filter topicNotInGrid as.topics
                         , rooms           : as.rooms
                         , blocks          : show <$> as.blocks
                         , timeslots       : sanitizeTimeslot <$> (M.toList as.timeslots)
                         }

findIn :: Room -> Block -> M.Map Slot Topic -> Maybe SanitizedTopic
findIn r b timeslots = M.lookup (Slot {block:b, room:r}) timeslots
                       <#> sanitizeTopic

makeGrid :: AppState -> [[Maybe SanitizedTopic]]
makeGrid as = (\r ->
                (\b -> findIn r b as.timeslots ) <$> (sort as.blocks)
              ) <$> as.rooms

foreign import renderMenu
  """function renderMenu(topicTypes){
    return function(){
      React.render(
        React.createElement(Menu, {topicTypes: topicTypes}),
        document.getElementById('menu')
        );
    }
  }
  """ :: forall eff. [String] -> Eff( dom::DOM | eff ) Unit

foreign import renderTopics
  """function renderTopics(topics){
    return function(){
      React.render(
        React.createElement(Topics, {topics: topics}),
        document.getElementById('topics')
        )
      }
    }
    """ :: forall eff. [SanitizedTopic] -> Eff( dom::DOM | eff ) Unit

foreign import renderGrid
  """
  function renderGrid(rooms){
    return function(blocks){
      return function(grid){
        return function(){
          React.render(
            React.createElement(Grid, {rooms: rooms, blocks: blocks, grid: grid}),
            document.getElementById('grid')
            );
          }
        }
      }
  }
  """ :: forall eff. [Room] -> [Block] -> [[Maybe SanitizedTopic]] -> Eff( dom::DOM | eff ) Unit

renderApp :: forall eff. AppState -> Eff( dom::DOM | eff ) Unit
renderApp as = do
  let as' = sanitizeAppState as
  renderTopics $ as'.topics
  renderGrid as.rooms (sort as.blocks) (makeGrid as)


Test very simple routes generation

Test very simple routes generation

module Test.Main where

import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Data.Generic (class Generic, gEq, gShow)
import Data.Maybe (Maybe(..))
import Prelude (bind, class Eq, class Show, Unit)
import Test.Unit (test, runTest, TIMER)
import Test.Unit.Console (TESTOUTPUT)
import Test.Unit.Assert (equal)
import Text.Boomerang.String (parse, serialize)
import Routing.Bob (bob)
import Type.Proxy (Proxy(..))

data BooleanIntRoute = BooleanIntRoute
  { extended :: Boolean
  , id :: Int
  }
derive instance genericBooleanIntRoute :: Generic BooleanIntRoute

data PrimitivePositionalValue = PrimitivePositionalValue Int
derive instance genericPrimitivePositionalValue :: Generic PrimitivePositionalValue
instance eqPrimitivePositionalValue :: Eq PrimitivePositionalValue where
  eq = gEq
instance showPrimitivePositionalValue :: Show PrimitivePositionalValue where
  show = gShow

data PrimitivePositionalValues = PrimitivePositionalValues Int Boolean Int
derive instance genericPrimitivePositionalValues :: Generic PrimitivePositionalValues
instance eqPrimitivePositionalValues :: Eq PrimitivePositionalValues where
  eq = gEq
instance showPrimitivePositionalValues :: Show PrimitivePositionalValues where
  show = gShow

data UnionOfPrimitivePositionalValues =
    FirstConstructor Int Boolean Int
  | SecondConstructor Int Boolean Int
derive instance genericUnionOfPrimitivePositionalValues :: Generic UnionOfPrimitivePositionalValues
instance eqUnionOfPrimitivePositionalValues :: Eq UnionOfPrimitivePositionalValues where
  eq = gEq
instance showUnionOfPrimitivePositionalValues :: Show UnionOfPrimitivePositionalValues where
  show = gShow

main :: forall e. Eff ( timer :: TIMER
                      , avar :: AVAR
                      , testOutput :: TESTOUTPUT | e
                      ) Unit
main = runTest do
  test "bob handles constructor with single, primitive value" do
    let route = bob (Proxy :: Proxy PrimitivePositionalValue)
        obj = PrimitivePositionalValue 8
    equal (Just "/8") (serialize route obj)
    equal (Just obj) (parse route "/8")

  test "gRoute handles construtor with multiple, primitive values" do
    let route = bob (Proxy :: Proxy PrimitivePositionalValues)
        obj = PrimitivePositionalValues 8 true 9
    equal (Just "/8/on/9") (serialize route obj)
    equal (Just obj) (parse route "/8/on/9")

error: pathspec 'test/Main.purs' did not match any file(s) known to git


Add example

Add example

module Main where

  import Prelude
  import Maybe
  import Eff
  import Trace
  import Data.Date

  foreign import testJSDateOk "var testJSDateOk = new Date();" :: JSDate
  foreign import testJSDateBad "var testJSDateBad = new Date('fail');" :: JSDate

  main = do
    d <- now
    Trace.print d

    Trace.print $ fromJSDate testJSDateOk
    Trace.print $ fromJSDate testJSDateBad

    Trace.print $ fromString "Tue Feb 18 2014 23:24:53 GMT+3000"
    Trace.print $ date 2003 January 01
    Trace.print $ dateTime 2044 February 01 13 26 48 06

    Trace.print $ toYear d
    Trace.print $ toMonth d
    Trace.print $ toDay d
    Trace.print $ toHours d
    Trace.print $ toMinutes d
    Trace.print $ toSeconds d
    Trace.print $ toMilliseconds d

    Trace.print $ toUTCYear d
    Trace.print $ toUTCMonth d
    Trace.print $ toUTCDay d
    Trace.print $ toUTCHours d
    Trace.print $ toUTCMinutes d
    Trace.print $ toUTCSeconds d
    Trace.print $ toUTCMilliseconds d

    Trace.print $ timezoneOffset d
    Trace.print $ toEpochMilliseconds d

    Trace.print $ fromEpochMilliseconds 0
    Trace.print $ fromEpochMilliseconds 999999999999
    Trace.print $ fromEpochMilliseconds (0-999999999999)

error: pathspec 'examples/Date.purs' did not match any file(s) known to git


Add test that should pass, but doesn't

Add test that should pass, but doesn't

module Main where

newtype Id = Id forall a. a -> a

runId = \id a -> case id of
  Id f -> f a

newtype Nat = Nat forall r. r -> (r -> r) -> r

runNat = \nat -> case nat of
  Nat f -> f 0 (\n -> n + 1)

zero = Nat (\zero _ -> zero)

succ = \n -> case n of
  Nat f -> Nat (\zero succ -> succ (f zero succ))

add = \n m -> case n of
  Nat f -> case m of
    Nat g -> Nat (\zero succ -> g (f zero succ) succ)

one = succ zero
two = succ zero
four = add two two
fourNumber = runNat four

main = Debug.Trace.trace "Done"

error: pathspec 'examples/shouldpass/NewtypeTCO.purs' did not match any file(s) known to git


Update tests

Update tests

module Test.Main where

import Prelude hiding (degree)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)

import Data.StrMap (insert)
import Data.Either(Either(..))
import Data.Foldable (traverse_)

import Test.Unit (suite, test, failure)
import Test.Unit.Main (runTest)
import Test.Unit.Console (TESTOUTPUT)

import Text.Parsing.Parser (parseErrorMessage, parseErrorPosition)
import Text.Parsing.Parser.Pos (Position(..))

import Quantities ((./), (.*), milli, nano, meter, inch, hour, minute, kilo,
                   mile, gram, second, deci, tera, hertz, degree, radian)

import Insect.Language (Func(..), BinOp(..), Expression(..), Statement(..))
import Insect.Parser (parseInsect)
import Insect.Environment (Environment, initialEnvironment)
import Insect (repl)

shouldParseAs ∷ ∀ eff. Statement → String → Aff eff Unit
shouldParseAs expected input =
  case parseInsect input of
    Left err →
      case parseErrorPosition err of
        (Position pos) →
          failure $ "Parse error for input '" <> input <> "': "
                                <> parseErrorMessage err
                                <> " at position "
                                <> show pos.column
    Right output →
      unless (output == expected) $ do
        failure $ "Unexpected result:\n" <>
                  "Input:    '" <> input <> "'\n" <>
                  "Output:   " <> show output <> "\n" <>
                  "Expected: " <> show expected <> "\n"

allParseAs ∷ ∀ eff. Statement → Array String → Aff eff Unit
allParseAs expected = traverse_ (shouldParseAs expected)

shouldFail ∷ ∀ eff. String → Aff eff Unit
shouldFail input = do
  case parseInsect input of
   Left _ → pure unit
   Right output → failure $ "input is expected to throw a parse error: '" <> input <> "'"

expectOutput ∷ ∀ eff. Environment → String → String → Aff eff Unit
expectOutput env expected inp =
  let res = repl env inp
      out = res.msg
  in
    unless (out == expected) do
      failure $ "Unexpected result:\n" <>
                "Input:    '" <> inp <> "'\n" <>
                "Output:   '" <> out <> "'\n" <>
                "Expected: '" <> expected <> "'\n"

main ∷ Eff (console ∷ CONSOLE, testOutput ∷ TESTOUTPUT, avar ∷ AVAR) Unit
main = runTest do
  -- Helper to construct quantities
  let q s u = BinOp Mul (Scalar s) (Unit u)

  suite "Parser - Numbers" do
    test "Simple numbers" do
      allParseAs (Expression (Scalar 1.0))
        [ "1"
        , "1.0"
        , "  1  "
        , " 1.0000   "
        , " +1.0   "
        , "+1"
        ]

      allParseAs (Expression (Scalar 3.5))
        [ "3.5"
        , "  3.5  "
        , "3.50"
        , "+3.50"
        ]

      shouldFail "123.."
      shouldFail "0.."
      shouldFail ".0."
      shouldFail "."
      shouldFail ".2"

    test "Large numbers" do
      allParseAs (Expression (Scalar 1234567890000000.0))
        [ "1234567890000000"
        , "1234567890000000.0"
        , "+1234567890000000.0"
        ]

    test "Negative numbers" do
      shouldParseAs (Expression (Negate (Scalar 123.45)))
        "-123.45"

    test "Exponential notation" do
      shouldParseAs (Expression (Negate (Scalar 1.3e13)))
        "-1.3e13"

      shouldParseAs (Expression (Scalar 2.7e-3))
        "2.7e-3"

      shouldFail "2.7e 3"
      shouldFail "123e+"
      shouldFail "1223e++2"
      shouldFail "1223e+-2"

  suite "Parser - Units" do
    test "Simple" do
      allParseAs (Expression (Unit meter))
        [ "m"
        , "      m "
        , "meter"
        , "meters"
        ]

      allParseAs (Expression (Unit inch))
        [ "in"
        , "      in "
        , "inch"
        , "inches"
        ]

      allParseAs (Expression (Unit degree))
        [ "°"
        , "      ° "
        , "deg"
        , "degree"
        , "degrees"
        ]

  suite "Parser - Quantities" do
    test "Simple" do
      allParseAs (Expression (q 2.3 meter))
        [ "2.3*m"
        , " 2.3 * m "
        , "2.3m"
        , "  2.3 m "
        , "2.3meter"
        , "2.3 meter"
        , "2.3meters"
        ]

      allParseAs (Expression (q 5.0 second))
        [ "5s"
        , "5second"
        , "5 seconds"
        ]

      allParseAs (Expression (q 5.0 gram))
        [ "5g"
        , "5gram"
        , "5 grams"
        ]

      allParseAs (Expression (q 10.0 minute))
        [ "10minutes"
        , "10minute"
        , "10min"
        ]

      allParseAs (Expression (q 10.0 mile))
        [ "10miles"
        , "10mile"
        ]

      allParseAs (Expression (q 10.0 inch))
        [ "10inches"
        , "10inch"
        , "10in"
        ]

      allParseAs (Expression (q 360.0 degree))
        [ "360degrees"
        , "360degree"
        , "360deg"
        , "360°"
        , "360.0°"
        ]

      allParseAs (Expression (q 1.0 radian))
        [ "1.0rad"
        , "1.0 radian"
        , "1.0 radians"
        ]

    test "SI prefixes" do
      allParseAs (Expression (q 2.3 (kilo meter)))
        [ "2.3km"
        , "  2.3 km "
        , "  2.3 kmeter "
        , "  2.3 kmeters "
        ]

      allParseAs (Expression (q 2.3 (milli meter)))
        [ "2.3mm"
        , "  2.3 mm "
        , "  2.3 mmeter "
        , "  2.3 mmeters "
        ]

      allParseAs (Expression (q 2.3 (nano gram)))
        [ "2.3ng"
        , "  2.3 ng "
        ]

      allParseAs (Expression (q 2.3 (kilo minute)))
        [ "2.3kmin"
        , "  2.3 kmin "
        ]

      allParseAs (Expression (q 2.3 (deci meter)))
        [ "2.3dm"
        , "  2.3 dm "
        ]

      allParseAs (Expression (q 42.3 (tera hertz)))
        [ "42.3THz"
        , "42.3Thertz"
        ]

    test "Divisions" do
      allParseAs (Expression (BinOp Div (q 2.3 (kilo meter)) (Unit hour)))
        [ "2.3km/h"
        , "2.30km/h"
        ]

  suite "Parser - Operators" do
    test "Exponentiation" do
      allParseAs (Expression (BinOp Pow (Scalar 5.0) (Scalar 3.0))) $
        [ "5^3"
        , " 5 ^ 3 "
        , " ( 5 ) ^ ( 3 ) "
        , " ( ( 5 ) ^ ( 3 ) ) "
        , " ( 5 ^ 3 ) "
        , "5^(+3)"
        , "+5^3"
        ]

      shouldParseAs (Expression (BinOp Pow (Scalar 2.0) (BinOp Pow (Scalar 3.0) (BinOp Pow (Scalar 4.0) (Scalar 5.0))))) $
        "2^3^4^5"

      allParseAs (Expression (BinOp Pow (Scalar 4.0) (Scalar 3.0))) $
        [ "4^3"
        , "4 ^ 3"
        , "4**3"
        , "4 ** 3"
        , "4³"
        , "4  ³"
        ]

      allParseAs (Expression (BinOp Pow (Variable "pi") (Scalar 2.0))) $
        [ "pi^2"
        , "pi ^ 2"
        , "pi**2"
        , "pi ** 2"
        , "pi²"
        , "(pi)²"
        ]

      allParseAs (Expression (Negate (BinOp Pow (Scalar 3.0) (Scalar 4.0)))) $
        [ "-3^4"
        , "-3 ^ 4"
        , "-3**4"
        , "-3 ** 4"
        , "-(3^4)"
        ]

      allParseAs (Expression (BinOp Pow (Scalar 3.0) (Negate (Scalar 1.4)))) $
        [ "3 ^ (-1.4)"
        , "3 ** (-1.4)"
        ]

      shouldFail "³"
      shouldFail "³2"
      shouldFail "2^"
      shouldFail "^2"

    test "Multiplication" do
      allParseAs (Expression (BinOp Mul (Scalar 5.0) (Scalar 3.0))) $
        [ "5*3"
        , " 5 * 3 "
        , " ( 5 ) * ( 3 ) "
        , " ( 5 ) ( 3 ) "
        , " ( ( 5 ) * ( 3 ) ) "
        , " ( 5 * 3 ) "
        , "5(3)"
        , "(5)3"
        , "5(+3)"
        , "+5*3"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 5.0) (Negate $ Scalar 3.0))) $
        [ "5*(-3)"
        , " 5 * (-3) "
        , " ( 5 ) * ( -3 ) "
        , " ( ( 5 ) * (-( 3 )) ) "
        , " ( 5 * (-3) ) "
        , "+5*(-3)"
        ]

      shouldFail "5*"

    test "Division" do
      allParseAs (Expression (BinOp Div (Scalar 5.0) (Scalar 3.0))) $
        [ "5/3"
        , " 5 / 3 "
        , " ( 5 ) / ( 3 ) "
        , " ( ( 5 ) / ( 3 ) ) "
        , " ( 5 / 3 ) "
        ]

      shouldFail "5/"

    test "Addition" do
      allParseAs (Expression (BinOp Add (Scalar 5.0) (Scalar 3.0))) $
        [ "5+3"
        , " 5 + 3 "
        , " ( 5 ) + ( 3 ) "
        , " ( ( 5 ) + ( 3 ) ) "
        , " ( 5 + 3 ) "
        ]

      shouldFail "3 + "
      shouldFail "3 + @"

    test "Subtraction" do
      allParseAs (Expression (BinOp Sub (Scalar 5.0) (Scalar 3.0))) $
        [ "5-3"
        , " 5 - 3 "
        , " ( 5 ) - ( 3 ) "
        , " ( ( 5 ) - ( 3 ) ) "
        , " ( 5 - 3 ) "
        ]

      shouldFail "3 - "

    test "Precedence" do
      allParseAs (Expression (BinOp Add (q 5.0 meter) (BinOp Mul (q 3.0 inch) (Scalar 7.0)))) $
        [ "5m+3in*7"
        , "5m+(3in*7)"
        , "5m+(3in·7)"
        , "  5 m +   3  in * 7    "
        ]

      allParseAs (Expression (BinOp Mul (BinOp Add (q 5.0 meter) (q 3.0 inch)) (Scalar 7.0))) $
        [ "(5m+3in)*7"
        , "((5m+3in))*7"
        , "(((((((5m))+((3in)))))))*((7))"
        , "  (  5 m + ( 3  in )  )  * 7    "
        ]

      allParseAs (Expression (BinOp Mul (BinOp Div (Scalar 5.0) (Scalar 3.0)) (Scalar 2.0)))
        [ "5/3*2"
        , "(5/3)*2"
        ]

      shouldFail "3+*4"
      shouldFail "3*/4"
      shouldFail "(3+4"
      shouldFail "3+4)"
      shouldFail "3+("
      shouldFail "()"
      shouldFail "(3+)4"

    test "Multiple division" do
      allParseAs (Expression (BinOp Div (BinOp Div (Scalar 42.0) (Scalar 7.0)) (Scalar 3.0))) $
        [ "42/7/3"
        , "(42/7)/3"
        ]

    test "Involving units" do
      allParseAs (Expression (BinOp Pow (q 3.0 meter) (Scalar 2.0))) $
        [ "(3m)^2"
        , "(3.0m)^(2.0)"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 3.0) (BinOp Pow (Unit meter) (Scalar 2.0)))) $
        [ "3m^2"
        , "3.0(m)^(2.0)"
        , "3m²"
        , "3 m²"
        , "3·m²"
        , "3·m^(2.0)"
        ]

      allParseAs (Expression (BinOp Div (q 3.0 meter) (Unit second))) $
        [ "3m/s"
        , "3 meter / second"
        , "(3m)/s"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 3.0) (BinOp Div (Unit meter) (Unit second)))) $
        [ "3·m/s"
        , "3*meter / second"
        , "3*meter / sec"
        ]

      allParseAs (Expression (BinOp Pow (Unit meter) (Negate $ Scalar 1.0))) $
        [ "m^(-1)"
        , "m^(-1.0)"
        , "meter^(-1.0)"
        ]

  suite "Parser - Conversions" do
    test "Simple" do
      allParseAs (Expression (BinOp ConvertTo (q (2.3) meter) (Unit inch)))
        [ "2.3m -> in"
        , "  2.3 meters->inches "
        , "  2.3 m  ->  in "
        ]

      allParseAs (Expression (BinOp ConvertTo (q 120.0 minute) (Unit hour)))
        [ "120min -> h"
        , "120minutes -> hours"
        ]

      shouldFail "2.3m->"

    test "Complex units" do
      allParseAs (Expression (BinOp ConvertTo (BinOp Mul (Scalar 36.0) (BinOp Div (Unit (kilo meter)) (Unit hour))) (Unit (mile ./ hour))))
        [ "36·km/h -> mph"
        , " 36 · km / hour->mph"
        ]

      allParseAs (Expression (BinOp ConvertTo (BinOp Div (q 36.0 (kilo meter)) (Unit hour)) (Unit (mile ./ hour))))
        [ "36km/h -> mph"
        , " 36km / hour->mph "
        ]

  suite "Parser - Identifiers" do
    test "Valid and invalid names" do
      shouldParseAs (Expression (Variable "x")) "x"
      shouldParseAs (Expression (Variable "µ")) "µ"
      shouldParseAs (Expression (Variable "pi")) "pi"
      shouldParseAs (Expression (Variable "x_2")) "x_2"
      shouldParseAs (Expression (Variable "länge")) "länge"
      shouldParseAs (Expression (Variable "_prefixed")) "_prefixed"
      shouldParseAs (Expression (Variable "x'")) "x'"
      shouldParseAs (Expression (Variable "t''")) "t''"

      shouldFail "xs,as"
      shouldFail "hello$"

    test "Variables which begin like units" do
      shouldParseAs (Expression (Variable "myVariable")) "myVariable"
      shouldParseAs (Expression (Variable "density")) "density"

  suite "Parser - Functions" do
    test "Simple" do
      allParseAs (Expression (Apply Sin (q 30.0 degree)))
        [ "sin(30°)"
        , "  sin( 30° )  "
        , "  sin( +30° )  "
        ]

      allParseAs (Expression (Apply Sqrt (Scalar 2.0)))
        [ "sqrt(2)"
        , "  sqrt( 2.0 )  "
        , "  sqrt( +2.0 )  "
        ]

      allParseAs (Expression (Apply Exp (Negate $ Scalar 10.0)))
        [ "exp(-10)"
        , "  exp( -10 )  "
        ]

  suite "Parser - Assignments" do
    test "Simple" do
      allParseAs (Assignment "xyz_123" (Scalar 1.0)) $
        [ "xyz_123 = 1"
        , "xyz_123=1"
        , "  xyz_123  =  1  "
        ]

      shouldFail "x²=3"
      shouldFail "x+y=3"
      shouldFail "x+2=3"
      shouldFail "3=5"
      shouldFail "x="

  let expectOutput' = expectOutput initialEnvironment

  suite "Integration" do
    test "Simple" do
      expectOutput' "3.0m" "3m"
      expectOutput' "3.0m" " 3.0 meter  "

    test "Implicit multiplication" do
      let myEnv = insert "x" (5.0 .* meter) initialEnvironment
      expectOutput myEnv "5.0m" "x"
      expectOutput myEnv "10.0m" "2x"
      expectOutput myEnv "10.0m" "2 x"
      expectOutput myEnv "25.0m²" "x x"
      expectOutput myEnv "25.0m²" "x²"
      expectOutput myEnv "Unknown variable 'x2'" "x2"

    test "Simple" do
      expectOutput' "1080.0" "1920/16*9"
      expectOutput' "4294967296.0" "2^32"
      expectOutput' "36.316811075498" "pi(1.4+2)²"

      expectOutput' "2.5min" "2min + 30s"
      expectOutput' "150.0s" "2min + 30s -> sec"
      expectOutput' "904778684233.8604km³" "4/3 * pi (6000km)³"
      expectOutput' "58800.0kg·m·cm/s²" "40kg * 9.8m/s² * 150cm"

      expectOutput' "26.8224m/s" "60mph -> m/s"
      expectOutput' "10.0km/h" "240km/day -> km/h"
      expectOutput' "0.057295779513082325°" "1mrad -> °"
      expectOutput' "364.0d" "52weeks -> days"
      expectOutput' "73.66cm" "5in + 2ft -> cm"

      expectOutput' "0.7071067811865476" "cos(pi/4)"
      expectOutput' "0.49999999999999994" "sin(30°)"
      expectOutput' "8.530765609948133°" "atan(30cm / 2m) -> °"

      expectOutput' "0.75" "3m/4m"
      expectOutput' "4.0" "4/2*2"
      expectOutput' "0.5s" "1/2 Hz -> s"

    test "Earth mass" do
      let env1 = initialEnvironment
          env2 = (repl env1 "r = 6000km").newEnv
          env3 = (repl env2 "vol = 4/3 * pi * r³").newEnv
          env4 = (repl env3 "density = 5g/cm³").newEnv

      expectOutput env4 "4.5238934211693013e+24kg" "vol * density -> kg"

    test "Pendulum" do
      let env1 = initialEnvironment
          env2 = (repl env1 "grav = 9.81m/s²").newEnv
          env3 = (repl env2 "L = 20cm").newEnv

      expectOutput env3 "897.1402930932747ms" "2pi*sqrt(L/grav) -> ms"

module Test.Main where

import Prelude hiding (degree)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR)

import Data.StrMap (insert)
import Data.Either(Either(..))
import Data.Foldable (traverse_)

import Test.Unit (suite, test, failure)
import Test.Unit.Main (runTest)
import Test.Unit.Console (TESTOUTPUT)

import Text.Parsing.Parser (parseErrorMessage, parseErrorPosition)
import Text.Parsing.Parser.Pos (Position(..))

import Quantities ((./), (.*), milli, nano, meter, inch, hour, minute, kilo,
                   mile, gram, second, deci, tera, hertz, degree, radian)

import Insect.Language (Func(..), BinOp(..), Expression(..), Statement(..))
import Insect.Parser (parseInsect)
import Insect.Environment (Environment, initialEnvironment)
import Insect (repl)

shouldParseAs ∷ ∀ eff. Statement → String → Aff eff Unit
shouldParseAs expected input =
  case parseInsect input of
    Left err →
      case parseErrorPosition err of
        (Position pos) →
          failure $ "Parse error for input '" <> input <> "': "
                                <> parseErrorMessage err
                                <> " at position "
                                <> show pos.column
    Right output →
      unless (output == expected) $ do
        failure $ "Unexpected result:\n" <>
                  "Input:    '" <> input <> "'\n" <>
                  "Output:   " <> show output <> "\n" <>
                  "Expected: " <> show expected <> "\n"

allParseAs ∷ ∀ eff. Statement → Array String → Aff eff Unit
allParseAs expected = traverse_ (shouldParseAs expected)

shouldFail ∷ ∀ eff. String → Aff eff Unit
shouldFail input = do
  case parseInsect input of
   Left _ → pure unit
   Right output → failure $ "input is expected to throw a parse error: '" <> input <> "'"

expectOutput ∷ ∀ eff. Environment → String → String → Aff eff Unit
expectOutput env expected inp =
  let res = repl env inp
      out = res.msg
  in
    unless (out == expected) do
      failure $ "Unexpected result:\n" <>
                "Input:    '" <> inp <> "'\n" <>
                "Output:   '" <> out <> "'\n" <>
                "Expected: '" <> expected <> "'\n"

main ∷ Eff (console ∷ CONSOLE, testOutput ∷ TESTOUTPUT, avar ∷ AVAR) Unit
main = runTest do
  -- Helper to construct quantities
  let q s u = BinOp Mul (Scalar s) (Unit u)

  suite "Parser - Numbers" do
    test "Simple numbers" do
      allParseAs (Expression (Scalar 1.0))
        [ "1"
        , "1.0"
        , "  1  "
        , " 1.0000   "
        , " +1.0   "
        , "+1"
        ]

      allParseAs (Expression (Scalar 3.5))
        [ "3.5"
        , "  3.5  "
        , "3.50"
        , "+3.50"
        ]

      shouldFail "123.."
      shouldFail "0.."
      shouldFail ".0."
      shouldFail "."
      shouldFail ".2"

    test "Large numbers" do
      allParseAs (Expression (Scalar 1234567890000000.0))
        [ "1234567890000000"
        , "1234567890000000.0"
        , "+1234567890000000.0"
        ]

    test "Negative numbers" do
      shouldParseAs (Expression (Negate (Scalar 123.45)))
        "-123.45"

    test "Exponential notation" do
      shouldParseAs (Expression (Negate (Scalar 1.3e13)))
        "-1.3e13"

      shouldParseAs (Expression (Scalar 2.7e-3))
        "2.7e-3"

      shouldFail "2.7e 3"
      shouldFail "123e+"
      shouldFail "1223e++2"
      shouldFail "1223e+-2"

  suite "Parser - Units" do
    test "Simple" do
      allParseAs (Expression (Unit meter))
        [ "m"
        , "      m "
        , "meter"
        , "meters"
        ]

      allParseAs (Expression (Unit inch))
        [ "in"
        , "      in "
        , "inch"
        , "inches"
        ]

      allParseAs (Expression (Unit degree))
        [ "°"
        , "      ° "
        , "deg"
        , "degree"
        , "degrees"
        ]

  suite "Parser - Quantities" do
    test "Simple" do
      allParseAs (Expression (q 2.3 meter))
        [ "2.3*m"
        , " 2.3 * m "
        , "2.3m"
        , "  2.3 m "
        , "2.3meter"
        , "2.3 meter"
        , "2.3meters"
        ]

      allParseAs (Expression (q 5.0 second))
        [ "5s"
        , "5second"
        , "5 seconds"
        ]

      allParseAs (Expression (q 5.0 gram))
        [ "5g"
        , "5gram"
        , "5 grams"
        ]

      allParseAs (Expression (q 10.0 mile))
        [ "10miles"
        , "10mile"
        ]

      allParseAs (Expression (q 10.0 inch))
        [ "10inches"
        , "10inch"
        , "10in"
        ]

      allParseAs (Expression (q 360.0 degree))
        [ "360degrees"
        , "360degree"
        , "360deg"
        , "360°"
        , "360.0°"
        ]

      allParseAs (Expression (q 1.0 radian))
        [ "1.0rad"
        , "1.0 radian"
        , "1.0 radians"
        ]

    test "SI prefixes" do
      allParseAs (Expression (q 2.3 (kilo meter)))
        [ "2.3km"
        , "  2.3 km "
        , "  2.3 kmeter "
        , "  2.3 kmeters "
        ]

      allParseAs (Expression (q 2.3 (milli meter)))
        [ "2.3mm"
        , "  2.3 mm "
        , "  2.3 mmeter "
        , "  2.3 mmeters "
        ]

      allParseAs (Expression (q 2.3 (nano gram)))
        [ "2.3ng"
        , "  2.3 ng "
        ]

      allParseAs (Expression (q 2.3 (kilo minute)))
        [ "2.3kmin"
        , "  2.3 kmin "
        ]

      allParseAs (Expression (q 2.3 (deci meter)))
        [ "2.3dm"
        , "  2.3 dm "
        ]

      allParseAs (Expression (q 42.3 (tera hertz)))
        [ "42.3THz"
        , "42.3Thertz"
        ]

    test "Divisions" do
      allParseAs (Expression (BinOp Div (q 2.3 (kilo meter)) (Unit hour)))
        [ "2.3km/h"
        , "2.30km/h"
        ]

  suite "Parser - Operators" do
    test "Exponentiation" do
      allParseAs (Expression (BinOp Pow (Scalar 5.0) (Scalar 3.0))) $
        [ "5^3"
        , " 5 ^ 3 "
        , " ( 5 ) ^ ( 3 ) "
        , " ( ( 5 ) ^ ( 3 ) ) "
        , " ( 5 ^ 3 ) "
        , "5^(+3)"
        , "+5^3"
        ]

      shouldParseAs (Expression (BinOp Pow (Scalar 2.0) (BinOp Pow (Scalar 3.0) (BinOp Pow (Scalar 4.0) (Scalar 5.0))))) $
        "2^3^4^5"

      allParseAs (Expression (BinOp Pow (Scalar 4.0) (Scalar 3.0))) $
        [ "4^3"
        , "4 ^ 3"
        , "4**3"
        , "4 ** 3"
        , "4³"
        , "4  ³"
        ]

      allParseAs (Expression (BinOp Pow (Variable "pi") (Scalar 2.0))) $
        [ "pi^2"
        , "pi ^ 2"
        , "pi**2"
        , "pi ** 2"
        , "pi²"
        , "(pi)²"
        ]

      allParseAs (Expression (Negate (BinOp Pow (Scalar 3.0) (Scalar 4.0)))) $
        [ "-3^4"
        , "-3 ^ 4"
        , "-3**4"
        , "-3 ** 4"
        , "-(3^4)"
        ]

      allParseAs (Expression (BinOp Pow (Scalar 3.0) (Negate (Scalar 1.4)))) $
        [ "3 ^ (-1.4)"
        , "3 ** (-1.4)"
        ]

      shouldFail "³"
      shouldFail "³2"
      shouldFail "2^"
      shouldFail "^2"

    test "Multiplication" do
      allParseAs (Expression (BinOp Mul (Scalar 5.0) (Scalar 3.0))) $
        [ "5*3"
        , " 5 * 3 "
        , " ( 5 ) * ( 3 ) "
        , " ( 5 ) ( 3 ) "
        , " ( ( 5 ) * ( 3 ) ) "
        , " ( 5 * 3 ) "
        , "5(3)"
        , "(5)3"
        , "5(+3)"
        , "+5*3"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 5.0) (Negate $ Scalar 3.0))) $
        [ "5*(-3)"
        , " 5 * (-3) "
        , " ( 5 ) * ( -3 ) "
        , " ( ( 5 ) * (-( 3 )) ) "
        , " ( 5 * (-3) ) "
        , "+5*(-3)"
        ]

      shouldFail "5*"

    test "Division" do
      allParseAs (Expression (BinOp Div (Scalar 5.0) (Scalar 3.0))) $
        [ "5/3"
        , " 5 / 3 "
        , " ( 5 ) / ( 3 ) "
        , " ( ( 5 ) / ( 3 ) ) "
        , " ( 5 / 3 ) "
        ]

      shouldFail "5/"

    test "Addition" do
      allParseAs (Expression (BinOp Add (Scalar 5.0) (Scalar 3.0))) $
        [ "5+3"
        , " 5 + 3 "
        , " ( 5 ) + ( 3 ) "
        , " ( ( 5 ) + ( 3 ) ) "
        , " ( 5 + 3 ) "
        ]

      shouldFail "3 + "
      shouldFail "3 + @"

    test "Subtraction" do
      allParseAs (Expression (BinOp Sub (Scalar 5.0) (Scalar 3.0))) $
        [ "5-3"
        , " 5 - 3 "
        , " ( 5 ) - ( 3 ) "
        , " ( ( 5 ) - ( 3 ) ) "
        , " ( 5 - 3 ) "
        ]

      shouldFail "3 - "

    test "Precedence" do
      allParseAs (Expression (BinOp Add (q 5.0 meter) (BinOp Mul (q 3.0 inch) (Scalar 7.0)))) $
        [ "5m+3in*7"
        , "5m+(3in*7)"
        , "5m+(3in·7)"
        , "  5 m +   3  in * 7    "
        ]

      allParseAs (Expression (BinOp Mul (BinOp Add (q 5.0 meter) (q 3.0 inch)) (Scalar 7.0))) $
        [ "(5m+3in)*7"
        , "((5m+3in))*7"
        , "(((((((5m))+((3in)))))))*((7))"
        , "  (  5 m + ( 3  in )  )  * 7    "
        ]

      allParseAs (Expression (BinOp Mul (BinOp Div (Scalar 5.0) (Scalar 3.0)) (Scalar 2.0)))
        [ "5/3*2"
        , "(5/3)*2"
        ]

      shouldFail "3+*4"
      shouldFail "3*/4"
      shouldFail "(3+4"
      shouldFail "3+4)"
      shouldFail "3+("
      shouldFail "()"
      shouldFail "(3+)4"

    test "Multiple division" do
      allParseAs (Expression (BinOp Div (BinOp Div (Scalar 42.0) (Scalar 7.0)) (Scalar 3.0))) $
        [ "42/7/3"
        , "(42/7)/3"
        ]

    test "Involving units" do
      allParseAs (Expression (BinOp Pow (q 3.0 meter) (Scalar 2.0))) $
        [ "(3m)^2"
        , "(3.0m)^(2.0)"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 3.0) (BinOp Pow (Unit meter) (Scalar 2.0)))) $
        [ "3m^2"
        , "3.0(m)^(2.0)"
        , "3m²"
        , "3 m²"
        , "3·m²"
        , "3·m^(2.0)"
        ]

      allParseAs (Expression (BinOp Div (q 3.0 meter) (Unit second))) $
        [ "3m/s"
        , "3 meter / second"
        , "(3m)/s"
        ]

      allParseAs (Expression (BinOp Mul (Scalar 3.0) (BinOp Div (Unit meter) (Unit second)))) $
        [ "3·m/s"
        , "3*meter / second"
        , "3*meter / sec"
        ]

      allParseAs (Expression (BinOp Pow (Unit meter) (Negate $ Scalar 1.0))) $
        [ "m^(-1)"
        , "m^(-1.0)"
        , "meter^(-1.0)"
        ]

  suite "Parser - Conversions" do
    test "Simple" do
      allParseAs (Expression (BinOp ConvertTo (q (2.3) meter) (Unit inch)))
        [ "2.3m -> in"
        , "  2.3 meters->inches "
        , "  2.3 m  ->  in "
        ]

      allParseAs (Expression (BinOp ConvertTo (q 120.0 minute) (Unit hour)))
        [ "120min -> h"
        , "120minutes -> hours"
        ]

      shouldFail "2.3m->"

    test "Complex units" do
      allParseAs (Expression (BinOp ConvertTo (BinOp Mul (Scalar 36.0) (BinOp Div (Unit (kilo meter)) (Unit hour))) (Unit (mile ./ hour))))
        [ "36·km/h -> mph"
        , " 36 · km / hour->mph"
        ]

      allParseAs (Expression (BinOp ConvertTo (BinOp Div (q 36.0 (kilo meter)) (Unit hour)) (Unit (mile ./ hour))))
        [ "36km/h -> mph"
        , " 36km / hour->mph "
        ]

  suite "Parser - Identifiers" do
    test "Valid and invalid names" do
      shouldParseAs (Expression (Variable "x")) "x"
      shouldParseAs (Expression (Variable "µ")) "µ"
      shouldParseAs (Expression (Variable "pi")) "pi"
      shouldParseAs (Expression (Variable "x_2")) "x_2"
      shouldParseAs (Expression (Variable "länge")) "länge"
      shouldParseAs (Expression (Variable "_prefixed")) "_prefixed"
      shouldParseAs (Expression (Variable "x'")) "x'"
      shouldParseAs (Expression (Variable "t''")) "t''"

      shouldFail "xs,as"
      shouldFail "hello$"

    test "Variables which begin like units" do
      shouldParseAs (Expression (Variable "myVariable")) "myVariable"
      shouldParseAs (Expression (Variable "density")) "density"

  suite "Parser - Functions" do
    test "Simple" do
      allParseAs (Expression (Apply Sin (q 30.0 degree)))
        [ "sin(30°)"
        , "  sin( 30° )  "
        , "  sin( +30° )  "
        ]

      allParseAs (Expression (Apply Sqrt (Scalar 2.0)))
        [ "sqrt(2)"
        , "  sqrt( 2.0 )  "
        , "  sqrt( +2.0 )  "
        ]

      allParseAs (Expression (Apply Exp (Negate $ Scalar 10.0)))
        [ "exp(-10)"
        , "  exp( -10 )  "
        ]

  suite "Parser - Assignments" do
    test "Simple" do
      allParseAs (Assignment "xyz_123" (Scalar 1.0)) $
        [ "xyz_123 = 1"
        , "xyz_123=1"
        , "  xyz_123  =  1  "
        ]

      shouldFail "x²=3"
      shouldFail "x+y=3"
      shouldFail "x+2=3"
      shouldFail "3=5"
      shouldFail "x="

  let expectOutput' = expectOutput initialEnvironment

  suite "Integration" do
    test "Simple" do
      expectOutput' "3.0m" "3m"
      expectOutput' "3.0m" " 3.0 meter  "

    test "Implicit multiplication" do
      let myEnv = insert "x" (5.0 .* meter) initialEnvironment
      expectOutput myEnv "5.0m" "x"
      expectOutput myEnv "10.0m" "2x"
      expectOutput myEnv "10.0m" "2 x"
      expectOutput myEnv "25.0m²" "x x"
      expectOutput myEnv "25.0m²" "x²"
      expectOutput myEnv "Unknown variable 'x2'" "x2"

    test "Simple" do
      expectOutput' "1080.0" "1920/16*9"
      expectOutput' "4294967296.0" "2^32"
      expectOutput' "36.316811075498" "pi(1.4+2)²"
      expectOutput' "904778684233.8604km³" "4/3 * pi (6000km)³"
      expectOutput' "2.5min" "2min + 30s"
      expectOutput' "150.0s" "2min + 30s -> sec"
      expectOutput' "26.8224m/s" "60mph -> m/s"
      expectOutput' "10.0km/h" "240km/day -> km/h"
      expectOutput' "0.057295779513082325°" "1mrad -> °"
      expectOutput' "364.0d" "52weeks -> days"
      expectOutput' "12.7cm" "5in -> cm"
      expectOutput' "0.7071067811865476" "cos(pi/4)"
      expectOutput' "0.49999999999999994" "sin(30°)"
      expectOutput' "8.530765609948133°" "atan(30cm / 2m) -> °"
      expectOutput' "0.75" "3m/4m"
      expectOutput' "4.0" "4/2*2"
      expectOutput' "0.5s" "1/2 Hz -> s"

    test "Earth mass" do
      let env1 = initialEnvironment
          env2 = (repl env1 "r = 6000km").newEnv
          env3 = (repl env2 "vol = 4/3 * pi * r³").newEnv
          env4 = (repl env3 "density = 5g/cm³").newEnv

      expectOutput env4 "4.5238934211693013e+24kg" "vol * density -> kg"

    test "Pendulum" do
      let env1 = initialEnvironment
          env2 = (repl env1 "grav = 9.81m/s²").newEnv
          env3 = (repl env2 "L = 20cm").newEnv

      expectOutput env3 "897.1402930932747ms" "2pi*sqrt(L/grav) -> ms"


Update Example.purs

Update Example.purs

module Starter.Kit.Example where

import Data.Array
import Data.Maybe

-- This module defines a single function diffs, which
-- returns the differences for an increasing array.
--
-- If the input is not increasing, it returns Nothing.
--
-- This contrived example was chosen to demonstrate the use
-- of the Data.Array and Data.Maybe standard libraries.

diffs :: [Number] -> Maybe [Number]
diffs [] = return []
diffs [_] = return []
diffs (x : tail@(x' : xs)) | x <= x' = do
  tailDiffs <- diffs tail
  return (x' - x : tailDiffs)
diffs _ = Nothing

module Starter.Kit.Example where

import Data.Array
import Data.Maybe

-- This module defines a single function diffs, which
-- returns the differences for an increasing array.
--
-- If the input is not increasing, it returns Nothing.
--
-- This contrived example is picked to demonstrate the use
-- of a few standard libraries.

diffs :: [Number] -> Maybe [Number]
diffs [] = return []
diffs [_] = return []
diffs (x : tail@(x' : xs)) | x <= x' = do
  tailDiffs <- diffs tail
  return (x' - x : tailDiffs)
diffs _ = Nothing


Fix warning

Fix warning

module Graphics.D3.Selection
  ( Selection()
  , Update()
  , Enter()
  , Exit()
  , Transition()
  , Void()
  , class AttrValue
  , class Existing
  , class Appendable
  , class Clickable
  , rootSelect
  , rootSelectAll
  , select
  , selectAll
  , bindData
  , enter
  , exit
  , transition
  , append
  , remove
  , attr
  , attr'
  , attr''
  , style
  , style'
  , style''
  , text
  , text'
  , text''
  , delay
  , delay'
  , delay''
  , duration
  , duration'
  , duration''
  , onClick
  , onDoubleClick
  ) where

import Graphics.D3.Base (D3Eff)
import Control.Monad.Eff (Eff)

import Data.Foreign (Foreign)
import Data.Foreign.EasyFFI (unsafeForeignFunction)

import Prelude ( Unit() )

ffi :: forall a. Array String -> String -> a
ffi = unsafeForeignFunction

-- The "selection-y" types, parameterized by the type of their bound data
foreign import data Selection :: * -> *
foreign import data Update :: * -> *
foreign import data Enter :: * -> *
foreign import data Transition :: * -> *

-- Exit selections have the same semantics as regular selections
type Exit d = Selection d

-- The (uninhabited) type of an unbound selection's data
data Void

-- The class of types which element attribute values can have (numbers and strings)
class AttrValue a

instance attrValNumber :: AttrValue Number
instance attrValString :: AttrValue String

rootSelect :: String -> D3Eff (Selection Void)
rootSelect = ffi ["selector", ""] "d3.select(selector)"

rootSelectAll :: String -> D3Eff (Selection Void)
rootSelectAll = ffi ["selector", ""] "d3.selectAll(selector)"

select :: forall d. String -> Selection d -> D3Eff (Selection d)
select = ffi ["selector", "selection", ""] "selection.select(selector)"

selectAll :: forall d. String -> Selection d -> D3Eff (Selection Void)
selectAll = ffi ["selector", "selection", ""] "selection.selectAll(selector)"

bindData :: forall oldData newData. Array newData -> Selection oldData -> D3Eff (Update newData)
bindData = ffi ["array", "selection", ""] "selection.data(array)"

enter :: forall d. Update d -> D3Eff (Enter d)
enter = ffi ["update", ""] "update.enter()"

exit :: forall d. Update d -> D3Eff (Exit d)
exit = ffi ["update", ""] "update.exit()"

transition :: forall s d. (Existing s) => s d -> D3Eff (Transition d)
transition = ffi ["selection", ""] "selection.transition()"

unsafeAppend :: forall x y. String -> x -> D3Eff y
unsafeAppend = ffi ["tag", "selection", ""] "selection.append(tag)"

unsafeRemove :: forall s. s -> D3Eff Unit
unsafeRemove = ffi ["selection", ""] "selection.remove()"

unsafeAttr :: forall v s. (AttrValue v) => String -> v -> s -> D3Eff s
unsafeAttr = ffi ["key", "val", "selection", ""] "selection.attr(key, val)"

unsafeAttr' :: forall d v s. (AttrValue v) => String -> (d -> v) -> s -> D3Eff s
unsafeAttr' = ffi ["key", "val", "selection", ""] "selection.attr(key, val)"

unsafeAttr'' :: forall d v s. (AttrValue v) => String -> (d -> Number -> v) -> s -> D3Eff s
unsafeAttr'' = ffi
  ["key", "val", "selection", ""]
  "selection.attr(key, function (d, i) { return val(d)(i); })"

unsafeStyle :: forall s. String -> String -> s -> D3Eff s
unsafeStyle = ffi ["key", "val", "selection", ""] "selection.style(key, val)"

unsafeStyle' :: forall d s. String -> (d -> String) -> s -> D3Eff s
unsafeStyle' = ffi ["key", "val", "selection", ""] "selection.style(key, val)"

unsafeStyle'' :: forall d s. String -> (d -> Number -> String) -> s -> D3Eff s
unsafeStyle'' = ffi
  ["key", "val", "selection", ""]
  "selection.style(key, function (d, i) { return val(d)(i); })"

unsafeText :: forall s. String -> s -> D3Eff s
unsafeText = ffi ["text", "selection", ""] "selection.text(text)"

unsafeText' :: forall d s. (d -> String) -> s -> D3Eff s
unsafeText' = ffi ["text", "selection", ""] "selection.text(text)"

unsafeText'' :: forall d s. (d -> Number -> String) -> s -> D3Eff s
unsafeText'' = ffi
  ["text", "selection", ""]
  "selection.text(function (d, i) { return text(d)(i); })"

unsafeOnClick :: forall eff c i r. (Clickable c) => (i -> Eff eff r) -> c -> D3Eff c
unsafeOnClick = ffi ["callback", "clickable", ""] "clickable.on('click', function(data) { callback(data)(); })"

unsafeOnDoubleClick :: forall eff c i r. (Clickable c) => (i -> Eff eff r) -> c -> D3Eff c
unsafeOnDoubleClick = ffi ["callback", "clickable", ""] "clickable.on('dblclick', function (data) { callback(data)(); })"

-- Transition-only stuff
delay :: forall d. Number -> Transition d -> D3Eff (Transition d)
delay = ffi ["delay", "transition", ""] "transition.delay(delay)"

delay' :: forall d. (d -> Number) -> Transition d -> D3Eff (Transition d)
delay' = ffi ["delay", "transition", ""] "transition.delay(delay)"

delay'' :: forall d. (d -> Number -> Number) -> Transition d -> D3Eff (Transition d)
delay'' = ffi
  ["delay", "transition", ""]
  "transition.delay(function (d, i) { return delay(d)(i); })"

duration :: forall d. Number -> Transition d -> D3Eff (Transition d)
duration = ffi ["duration", "transition", ""] "transition.duration(duration)"

duration' :: forall d. (d -> Number) -> Transition d -> D3Eff (Transition d)
duration' = ffi ["duration", "transition", ""] "transition.duration(duration)"

duration'' :: forall d. (d -> Number -> Number) -> Transition d -> D3Eff (Transition d)
duration'' = ffi
  ["duration", "transition", ""]
  "transition.duration(function (d, i) { return duration(d)(i); })"

-- Selection-y things which can be appended to / inserted into
class Appendable s where
  append :: forall d. String -> s d -> D3Eff (Selection d)

instance appendableSelection  :: Appendable Selection where
  append = unsafeAppend

instance appendableUpdate     :: Appendable Update where
  append = unsafeAppend

instance appendableEnter      :: Appendable Enter where
  append = unsafeAppend

-- Selection-y things that contain existing DOM elements
class Existing s where
  attr :: forall d v. (AttrValue v) => String -> v -> s d -> D3Eff (s d)
  attr' :: forall d v. (AttrValue v) => String -> (d -> v) -> s d -> D3Eff (s d)
  attr'' :: forall d v. (AttrValue v) => String -> (d -> Number -> v) -> s d -> D3Eff (s d)
  style :: forall d. String -> String -> s d -> D3Eff (s d)
  style' :: forall d. String -> (d -> String) -> s d -> D3Eff (s d)
  style'' :: forall d. String -> (d -> Number -> String) -> s d -> D3Eff (s d)
  text :: forall d. String -> s d -> D3Eff (s d)
  text' :: forall d. (d -> String) -> s d -> D3Eff (s d)
  text'' :: forall d. (d -> Number -> String) -> s d -> D3Eff (s d)
  remove :: forall d. s d -> D3Eff Unit

instance existingSelection :: Existing Selection where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

instance existingUpdate :: Existing Update where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

instance existingTransition :: Existing Transition where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

class Clickable c where
  onClick :: forall eff r. (Foreign -> Eff eff r) -> c -> D3Eff c
  onDoubleClick :: forall eff r. (Foreign -> Eff eff r) -> c -> D3Eff c

instance clickableSelection :: Clickable (Selection a) where
  -- NOTE: psc complains about cycles unless onclick/onDoubleClick are inlined
  onClick = ffi ["callback", "clickable", ""] "clickable.on('click', function(data) { callback(data)(); })"
  onDoubleClick = ffi ["callback", "clickable", ""] "clickable.on('dblclick', function (data) { callback(data)(); })"

module Graphics.D3.Selection
  ( Selection()
  , Update()
  , Enter()
  , Exit()
  , Transition()
  , Void()
  , class AttrValue
  , class Existing
  , class Appendable
  , class Clickable
  , rootSelect
  , rootSelectAll
  , select
  , selectAll
  , bindData
  , enter
  , exit
  , transition
  , append
  , remove
  , attr
  , attr'
  , attr''
  , style
  , style'
  , style''
  , text
  , text'
  , text''
  , delay
  , delay'
  , delay''
  , duration
  , duration'
  , duration''
  , onClick
  , onDoubleClick
  ) where

import Graphics.D3.Base (D3Eff)
import Control.Monad.Eff (Eff)

import Data.Foreign (Foreign)
import Data.Foreign.EasyFFI (unsafeForeignFunction)

import Prelude ( Unit() )

ffi = unsafeForeignFunction

-- The "selection-y" types, parameterized by the type of their bound data
foreign import data Selection :: * -> *
foreign import data Update :: * -> *
foreign import data Enter :: * -> *
foreign import data Transition :: * -> *

-- Exit selections have the same semantics as regular selections
type Exit d = Selection d

-- The (uninhabited) type of an unbound selection's data
data Void

-- The class of types which element attribute values can have (numbers and strings)
class AttrValue a

instance attrValNumber :: AttrValue Number
instance attrValString :: AttrValue String

rootSelect :: String -> D3Eff (Selection Void)
rootSelect = ffi ["selector", ""] "d3.select(selector)"

rootSelectAll :: String -> D3Eff (Selection Void)
rootSelectAll = ffi ["selector", ""] "d3.selectAll(selector)"

select :: forall d. String -> Selection d -> D3Eff (Selection d)
select = ffi ["selector", "selection", ""] "selection.select(selector)"

selectAll :: forall d. String -> Selection d -> D3Eff (Selection Void)
selectAll = ffi ["selector", "selection", ""] "selection.selectAll(selector)"

bindData :: forall oldData newData. Array newData -> Selection oldData -> D3Eff (Update newData)
bindData = ffi ["array", "selection", ""] "selection.data(array)"

enter :: forall d. Update d -> D3Eff (Enter d)
enter = ffi ["update", ""] "update.enter()"

exit :: forall d. Update d -> D3Eff (Exit d)
exit = ffi ["update", ""] "update.exit()"

transition :: forall s d. (Existing s) => s d -> D3Eff (Transition d)
transition = ffi ["selection", ""] "selection.transition()"

unsafeAppend :: forall x y. String -> x -> D3Eff y
unsafeAppend = ffi ["tag", "selection", ""] "selection.append(tag)"

unsafeRemove :: forall s. s -> D3Eff Unit
unsafeRemove = ffi ["selection", ""] "selection.remove()"

unsafeAttr :: forall v s. (AttrValue v) => String -> v -> s -> D3Eff s
unsafeAttr = ffi ["key", "val", "selection", ""] "selection.attr(key, val)"

unsafeAttr' :: forall d v s. (AttrValue v) => String -> (d -> v) -> s -> D3Eff s
unsafeAttr' = ffi ["key", "val", "selection", ""] "selection.attr(key, val)"

unsafeAttr'' :: forall d v s. (AttrValue v) => String -> (d -> Number -> v) -> s -> D3Eff s
unsafeAttr'' = ffi
  ["key", "val", "selection", ""]
  "selection.attr(key, function (d, i) { return val(d)(i); })"

unsafeStyle :: forall s. String -> String -> s -> D3Eff s
unsafeStyle = ffi ["key", "val", "selection", ""] "selection.style(key, val)"

unsafeStyle' :: forall d s. String -> (d -> String) -> s -> D3Eff s
unsafeStyle' = ffi ["key", "val", "selection", ""] "selection.style(key, val)"

unsafeStyle'' :: forall d s. String -> (d -> Number -> String) -> s -> D3Eff s
unsafeStyle'' = ffi
  ["key", "val", "selection", ""]
  "selection.style(key, function (d, i) { return val(d)(i); })"

unsafeText :: forall s. String -> s -> D3Eff s
unsafeText = ffi ["text", "selection", ""] "selection.text(text)"

unsafeText' :: forall d s. (d -> String) -> s -> D3Eff s
unsafeText' = ffi ["text", "selection", ""] "selection.text(text)"

unsafeText'' :: forall d s. (d -> Number -> String) -> s -> D3Eff s
unsafeText'' = ffi
  ["text", "selection", ""]
  "selection.text(function (d, i) { return text(d)(i); })"

unsafeOnClick :: forall eff c i r. (Clickable c) => (i -> Eff eff r) -> c -> D3Eff c
unsafeOnClick = ffi ["callback", "clickable", ""] "clickable.on('click', function(data) { callback(data)(); })"

unsafeOnDoubleClick :: forall eff c i r. (Clickable c) => (i -> Eff eff r) -> c -> D3Eff c
unsafeOnDoubleClick = ffi ["callback", "clickable", ""] "clickable.on('dblclick', function (data) { callback(data)(); })"

-- Transition-only stuff
delay :: forall d. Number -> Transition d -> D3Eff (Transition d)
delay = ffi ["delay", "transition", ""] "transition.delay(delay)"

delay' :: forall d. (d -> Number) -> Transition d -> D3Eff (Transition d)
delay' = ffi ["delay", "transition", ""] "transition.delay(delay)"

delay'' :: forall d. (d -> Number -> Number) -> Transition d -> D3Eff (Transition d)
delay'' = ffi
  ["delay", "transition", ""]
  "transition.delay(function (d, i) { return delay(d)(i); })"

duration :: forall d. Number -> Transition d -> D3Eff (Transition d)
duration = ffi ["duration", "transition", ""] "transition.duration(duration)"

duration' :: forall d. (d -> Number) -> Transition d -> D3Eff (Transition d)
duration' = ffi ["duration", "transition", ""] "transition.duration(duration)"

duration'' :: forall d. (d -> Number -> Number) -> Transition d -> D3Eff (Transition d)
duration'' = ffi
  ["duration", "transition", ""]
  "transition.duration(function (d, i) { return duration(d)(i); })"

-- Selection-y things which can be appended to / inserted into
class Appendable s where
  append :: forall d. String -> s d -> D3Eff (Selection d)

instance appendableSelection  :: Appendable Selection where
  append = unsafeAppend

instance appendableUpdate     :: Appendable Update where
  append = unsafeAppend

instance appendableEnter      :: Appendable Enter where
  append = unsafeAppend

-- Selection-y things that contain existing DOM elements
class Existing s where
  attr :: forall d v. (AttrValue v) => String -> v -> s d -> D3Eff (s d)
  attr' :: forall d v. (AttrValue v) => String -> (d -> v) -> s d -> D3Eff (s d)
  attr'' :: forall d v. (AttrValue v) => String -> (d -> Number -> v) -> s d -> D3Eff (s d)
  style :: forall d. String -> String -> s d -> D3Eff (s d)
  style' :: forall d. String -> (d -> String) -> s d -> D3Eff (s d)
  style'' :: forall d. String -> (d -> Number -> String) -> s d -> D3Eff (s d)
  text :: forall d. String -> s d -> D3Eff (s d)
  text' :: forall d. (d -> String) -> s d -> D3Eff (s d)
  text'' :: forall d. (d -> Number -> String) -> s d -> D3Eff (s d)
  remove :: forall d. s d -> D3Eff Unit

instance existingSelection :: Existing Selection where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

instance existingUpdate :: Existing Update where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

instance existingTransition :: Existing Transition where
  attr = unsafeAttr
  attr' = unsafeAttr'
  attr'' = unsafeAttr''
  style = unsafeStyle
  style' = unsafeStyle'
  style'' = unsafeStyle''
  text = unsafeText
  text' = unsafeText'
  text'' = unsafeText''
  remove = unsafeRemove

class Clickable c where
  onClick :: forall eff r. (Foreign -> Eff eff r) -> c -> D3Eff c
  onDoubleClick :: forall eff r. (Foreign -> Eff eff r) -> c -> D3Eff c

instance clickableSelection :: Clickable (Selection a) where
  -- NOTE: psc complains about cycles unless onclick/onDoubleClick are inlined
  onClick = ffi ["callback", "clickable", ""] "clickable.on('click', function(data) { callback(data)(); })"
  onDoubleClick = ffi ["callback", "clickable", ""] "clickable.on('dblclick', function (data) { callback(data)(); })"


solution for Day3 Part1

solution for Day3 Part1

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/michaelsbradleyjr/advent-of-code.git/'


Added basic tests

Added basic tests

module Test.Main where

import Prelude

import App.Routes (LoggedInSubRoute(..), MainRoute(..), match, toURL)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Foldable (for_)
import Test.Assert (ASSERT, assert)

type Tests = Eff (console :: CONSOLE, assert :: ASSERT) Unit

main :: Tests
main = do
  log "Test route/url generating and parsing"
  for_ routes testRoute
  where
    testRoute :: MainRoute -> Tests
    testRoute r = do
      log $ "Testing " <> show r
      assert $ r == (match $ toURL r)

    routes :: Array MainRoute
    routes = [Home, LoggedIn Overview, LoggedIn (Detail 4)]

error: pathspec 'test/Test/Main.purs' did not match any file(s) known to git


Add XHR API types

Add XHR API types

-- | Types for the [WHATWG XMLHttpRequest Living Standard](https://xhr.spec.whatwg.org/#interface-formdata).
module DOM.XHR where

-- | An `XMLHttpRequest` object instance.
foreign import data XMLHttpRequest :: *

-- | A `FormData` object instance.
foreign import data FormData :: *

-- | A `ProgressEvent` object instance.
foreign import data ProgressEvent :: *

error: pathspec 'src/DOM/XHR.purs' did not match any file(s) known to git


import from Day1.Part1 (code reuse, yay!)


Add Language.World module for checking consistency of bindings

Removing a global that has dependencies will be an error instead of a
warning going forward.

module Language.World
  ( World
  , Dependency(..)
  , new
  , define
  , undefine
  , focus
  , unfocus
  ) where

import Prelude hiding (add)

import Data.Array as Array
import Data.Either (Either(..))
import Data.Foldable (foldM, foldl, fold)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Data.Generic.Rep.Ord (genericCompare)
import Data.Grammar as Grammar
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Set (Set)
import Data.Set as Set
import Data.Tuple (Tuple(..))
import Language.Expr (Expr, freeVars)
import Language.Name (Name)
import Partial.Unsafe (unsafeCrashWith)

type World =
  { nameToDeps :: Map Name (Set Dependency)
  , depToNames :: Map Dependency (Set Name)
  }

data Dependency
  = Global Name
  | Root

derive instance genericDependency :: Generic Dependency _

instance eqDependency :: Eq Dependency where
  eq x = genericEq x

instance ordDependency :: Ord Dependency where
  compare x = genericCompare x

instance showDependency :: Show Dependency where
  show = case _ of
    Global name -> show name
    Root -> "the input"

data ConsistencyError
  = Undefined (Set Name)
  | CannotDelete Name (Set Dependency)

format :: ConsistencyError -> String
format = case _ of
  Undefined missing -> fold
    [ "No top-level "
    , Grammar.pluralizeWith "s" (Set.size missing) "definition"
    , " for "
    , Grammar.joinWith "and" $ show <$> Array.fromFoldable missing
    ]
  CannotDelete name deps -> fold
    [ "Cannot delete "
    , show name
    , " because it's still referenced by "
    , Grammar.joinWith "and" $ show <$> Array.fromFoldable deps
    ]

empty :: World
empty =
  { nameToDeps: Map.empty
  , depToNames: Map.empty
  }

new :: Array (Tuple Name Expr) -> World
new prelude = case foldM (flip addGlobal) empty prelude of
  Left err -> unsafeCrashWith $ "Malformed prelude: " <> err
  Right world -> world
 where
  addGlobal (Tuple name expr) = add (Global name) expr

define :: Name -> Expr -> World -> Either String World
define name = add $ Global name

undefine :: Name -> World -> Either String World
undefine name world = do
  let deps = fromMaybe Set.empty $ Map.lookup name world.nameToDeps
  if Set.size deps == 0
    then pure $ remove (Global name) world
    else Left $ format $ CannotDelete name deps

focus :: Expr -> World -> Either String World
focus = add Root

unfocus :: World -> World
unfocus = remove Root

add :: Dependency -> Expr -> World -> Either String World
add dep expr world = do
  let
    newWorld = remove dep world
    fvs = freeVars expr
    missing = fvs `Set.difference` globals newWorld
  if Set.size missing == 0
    then pure $ combine newWorld $ fromFreeVars dep fvs
    else Left $ format $ Undefined missing

remove :: Dependency -> World -> World
remove dep world@{ nameToDeps, depToNames } =
  case Map.lookup dep depToNames of
    Nothing -> world
    Just names ->
      { depToNames: Map.delete dep depToNames
      , nameToDeps: foldl eliminate nameToDeps names
      }
 where
  eliminate m name = Map.update (pure <<< Set.delete dep) name m

globals :: World -> Set Name
globals = Map.keys <<< _.nameToDeps

fromFreeVars :: Dependency -> Set Name -> World
fromFreeVars dep fvs =
  { nameToDeps
  , depToNames
  }
 where
  nameToDeps = Map.fromFoldable $ case dep of
    Root -> others
    Global name -> Array.snoc others $ Tuple name Set.empty
  others = do
    name <- Array.fromFoldable fvs
    pure $ Tuple name $ Set.singleton dep
  depToNames = Map.singleton dep fvs

combine :: World -> World -> World
combine lhs rhs =
  { nameToDeps: Map.unionWith Set.union lhs.nameToDeps rhs.nameToDeps
  , depToNames: Map.unionWith Set.union lhs.depToNames rhs.depToNames
  }

error: pathspec 'src/Language/World.purs' did not match any file(s) known to git


[CSM-233] Add missing TLS module

[CSM-233] Add missing TLS module

module Daedalus.TLS
       ( FS
       , TLSOptions
       , initTLS
       ) where

-- TLS
import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Node.FS.Sync (readFile)
import Node.FS as FS
import Node.HTTP.Client (protocol, hostname, port, RequestOptions)
import Data.Options (opt, (:=), Option, Options)
import Node.Buffer (Buffer)

type TLSOptions = Options RequestOptions
type FS = FS.FS

-- | Certificate Authority
ca :: Option RequestOptions Buffer
ca = opt "ca"

initTLS :: forall eff. String -> Eff (fs :: FS, err :: EXCEPTION | eff) TLSOptions
initTLS caFilePath = do
    caFile <- readFile caFilePath
    pure $ daedalusTLSOptions <> ca := caFile
    -- TODO: check does this reueses openned TLS connection or is a new connection
    -- initialized on every request. If later, then we have to reuse it (look at nodejs https agents)
  where
    daedalusTLSOptions :: Options RequestOptions
    daedalusTLSOptions =
           protocol := "https"
        <> hostname := "127.0.0.1"
        <> port     := 8090

error: pathspec 'daedalus/src/Daedalus/TLS.purs' did not match any file(s) known to git


Adding FormController

Adding FormController

module Angular.FormController
 ( FormController(..)
 , FormCtrl(..)
 , addControl
 , removeControl
 , setValidity
 , setDirty
 , setPristine
 , pristine
 , dirty
 , valid
 , invalid
 , error
 ) where

import Control.Monad.Eff

import Angular.NgModelController (NgModelController(..), ValidationErrorKey(..))

foreign import data FormController :: *

foreign import data FormCtrl :: !

foreign import addControl
  " function addControl(control){ \
  \   return function($ctrl){ \
  \     return function(){ \
  \       return $ctrl.$addControl(control); \
  \     }; \
  \   }; \
  \ } "
  :: forall e a. NgModelController a -> FormController -> Eff (ngform :: FormCtrl | e) Unit

foreign import removeControl
  " function removeControl(control){ \
  \   return function($ctrl){ \
  \     return function(){ \
  \       return $ctrl.$removeControl(control); \
  \     }; \
  \   }; \
  \ } "
  :: forall e a. NgModelController a -> FormController -> Eff (ngform :: FormCtrl | e) Unit

foreign import setValidity
  " function setValidity(key){ \
  \   return function(isValid){ \
  \     return function(control){ \
  \       return function($ctrl){ \
  \         return function(){ \
  \           return $ctrl.$setValidity(key, isValid, control, $ctrl); \
  \         }; \
  \       }; \
  \     }; \
  \   }; \
  \ } "
 :: forall e a. ValidationErrorKey -> Boolean -> NgModelController a -> FormController -> Eff (ngform :: FormCtrl | e) Unit

foreign import setDirty
  " function setDirty($ctrl){ \
  \   return function(){ \
  \     return $ctrl.$setDirty(); \
  \   }; \
  \ } "
  :: forall e. FormController -> Eff (ngform :: FormCtrl | e) Unit

foreign import setPristine
  " function setPristine($ctrl){ \
  \   return function(){ \
  \     return $ctrl.$setPristine(); \
  \   }; \
  \ } "
  :: forall e. FormController -> Eff (ngform :: FormCtrl | e) Unit

foreign import pristine
  " function pristine($ctrl){ \
  \   return function(){ \
  \     return $ctrl.$pristine; \
  \   }; \
  \ } "
  :: forall e. FormController -> Eff (ngform :: FormCtrl | e) Boolean

foreign import dirty
  " function dirty($ctrl){ \
  \   return function(){ \
  \     return $ctrl.$dirty; \
  \   }; \
  \ } "
  :: forall e. FormController -> Eff (ngform :: FormCtrl | e) Boolean

foreign import valid
  " function valid($ctrl){ \
  \   return function(){ \
  \     return $ctrl.$valid; \
  \   }; \
  \ } "
  :: forall e. FormController -> Eff (ngform :: FormCtrl | e) Boolean

foreign import invalid
  " function invalid($ctrl){ \
  \   return function(){ \
  \     return $ctrl.$invalid; \
  \   }; \
  \ } "
  :: forall e. FormController -> Eff (ngform :: FormCtrl | e) Boolean

foreign import error
  " function error($ctrl){ \
  \   return function(){ \
  \     return $ctrl.$error; \
  \   }; \
  \ } "
  :: forall e a. FormController -> Eff (ngform :: FormCtrl | e) { | a }

error: pathspec 'src/Angular/FormController.purs' did not match any file(s) known to git


Small improvements before moving on to `showJobs`.

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/0dB/cats-utils.git/'