Fix spacing

Fix spacing

module Data.FoldableWithIndex
  ( class FoldableWithIndex, foldrWithIndex, foldlWithIndex, foldMapWithIndex
  , foldrWithIndexDefault
  , foldlWithIndexDefault
  , foldMapWithIndexDefaultR
  , foldMapWithIndexDefaultL
  , foldWithIndexM
  , traverseWithIndex_
  , forWithIndex_
  , surroundMapWithIndex
  , allWithIndex
  , anyWithIndex
  , findWithIndex
  ) where

import Prelude

import Data.Foldable (class Foldable, foldMap, foldl, foldr)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Maybe (Maybe(..))
import Data.Maybe.First (First)
import Data.Maybe.Last (Last)
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive)
import Data.Monoid.Conj (Conj(..))
import Data.Monoid.Disj (Disj(..))
import Data.Monoid.Dual (Dual(..))
import Data.Monoid.Endo (Endo(..))
import Data.Monoid.Multiplicative (Multiplicative)
import Data.Newtype (unwrap)

-- | A `Foldable` with an additional index.
-- | A `FoldableWithIndex` instance must be compatible with its `Foldable`
-- | instance
-- | ```purescript
-- | foldr f = foldrWithIndex (const f)
-- | foldl f = foldlWithIndex (const f)
-- | foldMap f = foldMapWithIndex (const f)
-- | ```
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `foldrWithIndexDefault`
-- | - `foldlWithIndexDefault`
-- | - `foldMapWithIndexDefaultR`
-- | - `foldMapWithIndexDefaultL`
-- |
-- | Note: some combinations of the default implementations are unsafe to
-- | use together - causing a non-terminating mutually recursive cycle.
-- | These combinations are documented per function.
class Foldable f <= FoldableWithIndex i f | f -> i where
  foldrWithIndex :: forall a b. (i -> a -> b -> b) -> b -> f a -> b
  foldlWithIndex :: forall a b. (i -> b -> a -> b) -> b -> f a -> b
  foldMapWithIndex :: forall a m. Monoid m => (i -> a -> m) -> f a -> m

-- | A default implementation of `foldrWithIndex` using `foldMapWithIndex`.
-- |
-- | Note: when defining a `FoldableWithIndex` instance, this function is
-- | unsafe to use in combination with `foldMapWithIndexDefaultR`.
foldrWithIndexDefault
  :: forall i f a b
   . FoldableWithIndex i f
  => (i -> a -> b -> b)
  -> b
  -> f a
  -> b
foldrWithIndexDefault c u xs = unwrap (foldMapWithIndex (\i -> Endo <<< c i) xs) u

-- | A default implementation of `foldlWithIndex` using `foldMapWithIndex`.
-- |
-- | Note: when defining a `FoldableWithIndex` instance, this function is
-- | unsafe to use in combination with `foldMapWithIndexDefaultL`.
foldlWithIndexDefault
  :: forall i f a b
   . FoldableWithIndex i f
  => (i -> b -> a -> b)
  -> b
  -> f a
  -> b
foldlWithIndexDefault c u xs = unwrap (unwrap (foldMapWithIndex (\i -> Dual <<< Endo <<< flip (c i)) xs)) u

-- | A default implementation of `foldMapWithIndex` using `foldrWithIndex`.
-- |
-- | Note: when defining a `FoldableWithIndex` instance, this function is
-- | unsafe to use in combination with `foldrWithIndexDefault`.
foldMapWithIndexDefaultR
  :: forall i f a m
   . FoldableWithIndex i f
  => Monoid m
  => (i -> a -> m)
  -> f a
  -> m
foldMapWithIndexDefaultR f = foldrWithIndex (\i x acc -> f i x <> acc) mempty

-- | A default implementation of `foldMapWithIndex` using `foldlWithIndex`.
-- |
-- | Note: when defining a `FoldableWithIndex` instance, this function is
-- | unsafe to use in combination with `foldlWithIndexDefault`.
foldMapWithIndexDefaultL
  :: forall i f a m
   . FoldableWithIndex i f
  => Monoid m
  => (i -> a -> m)
  -> f a
  -> m
foldMapWithIndexDefaultL f = foldlWithIndex (\i acc x -> acc <> f i x) mempty

data Tuple a b = Tuple a b

instance foldableWithIndexArray :: FoldableWithIndex Int Array where
  foldrWithIndex f z = foldr (\(Tuple i x) y -> f i x y) z <<< mapWithIndex Tuple
  foldlWithIndex f z = foldl (\y (Tuple i x) -> f i y x) z <<< mapWithIndex Tuple
  foldMapWithIndex = foldMapWithIndexDefaultR

instance foldableWithIndexMaybe :: FoldableWithIndex Unit Maybe where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldableWithIndexFirst :: FoldableWithIndex Unit First where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldableWithIndexLast :: FoldableWithIndex Unit Last where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldableWithIndexAdditive :: FoldableWithIndex Unit Additive where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldableWithIndexDual :: FoldableWithIndex Unit Dual where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldableWithIndexDisj :: FoldableWithIndex Unit Disj where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldableWithIndexConj :: FoldableWithIndex Unit Conj where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldableWithIndexMultiplicative :: FoldableWithIndex Unit Multiplicative where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

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

-- | Traverse a data structure with access to the index, performing some
-- | effects encoded by an `Applicative` functor at each value, ignoring the
-- | final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > traverseWithIndex_ (curry logShow) ["a", "b", "c"]
-- | (Tuple 0 "a")
-- | (Tuple 1 "b")
-- | (Tuple 2 "c")
-- | ```
traverseWithIndex_
  :: forall i a b f m
   . Applicative m
  => FoldableWithIndex i f
  => (i -> a -> m b)
  -> f a
  -> m Unit
traverseWithIndex_ f = foldrWithIndex (\i -> (*>) <<< f i) (pure unit)

-- | A version of `traverseWithIndex_` with its arguments flipped.
-- |
-- | This can be useful when running an action written using do notation
-- | for every element in a data structure:
-- |
-- | For example:
-- |
-- | ```purescript
-- | forWithIndex_ ["a", "b", "c"] \i x -> do
-- |   logShow i
-- |   log x
-- | ```
forWithIndex_
  :: forall i a b f m
   . Applicative m
  => FoldableWithIndex i f
  => f a
  -> (i -> a -> m b)
  -> m Unit
forWithIndex_ = flip traverseWithIndex_

-- | `foldMapWithIndex` but with each element surrounded by some fixed value.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > surroundMapWithIndex "*" (\i x -> show i <> x) []
-- | = "*"
-- |
-- | > surroundMapWithIndex "*" (\i x -> show i <> x) ["a"]
-- | = "*0a*"
-- |
-- | > surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b"]
-- | = "*0a*1b*"
-- |
-- | > surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b", "c"]
-- | = "*0a*1b*2c*"
-- | ```
surroundMapWithIndex
  :: forall i f a m
   . FoldableWithIndex i f
  => Semigroup m
  => m
  -> (i -> a -> m)
  -> f a
  -> m
surroundMapWithIndex d t f = unwrap (foldMapWithIndex joined f) d
  where joined i a = Endo \m -> d <> t i a <> m

-- | `allWithIndex f` is the same as `and <<< mapWithIndex f`; map a function over the
-- | structure, and then get the conjunction of the results.
allWithIndex
  :: forall i a b f
   . FoldableWithIndex i f
  => HeytingAlgebra b
  => (i -> a -> b)
  -> f a
  -> b
allWithIndex t = unwrap <<< foldMapWithIndex (\i -> Conj <<< t i)

-- | `anyWithIndex f` is the same as `or <<< mapWithIndex f`; map a function over the
-- | structure, and then get the disjunction of the results.
anyWithIndex
  :: forall i a b f
   . FoldableWithIndex i f
  => HeytingAlgebra b
  => (i -> a -> b)
  -> f a
  -> b
anyWithIndex t = unwrap <<< foldMapWithIndex (\i -> Disj <<< t i)

-- | Try to find an element in a data structure which satisfies a predicate
-- | with access to the index.
findWithIndex
  :: forall i a f
   . FoldableWithIndex i f
  => (i -> a -> Boolean)
  -> f a
  -> Maybe { index :: i, value :: a }
findWithIndex p = foldlWithIndex go Nothing
  where
  go
    :: i
    -> Maybe { index :: i, value :: a }
    -> a
    -> Maybe { index :: i, value :: a }
  go i Nothing x | p i x = Just { index: i, value: x }
  go _ r _ = r

module Data.FoldableWithIndex
  ( class FoldableWithIndex, foldrWithIndex, foldlWithIndex, foldMapWithIndex
  , foldrWithIndexDefault
  , foldlWithIndexDefault
  , foldMapWithIndexDefaultR
  , foldMapWithIndexDefaultL
  , foldWithIndexM
  , traverseWithIndex_
  , forWithIndex_
  , surroundMapWithIndex
  , allWithIndex
  , anyWithIndex
  , findWithIndex
  ) where

import Prelude

import Data.Foldable (class Foldable, foldMap, foldl, foldr)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Maybe (Maybe(..))
import Data.Maybe.First (First)
import Data.Maybe.Last (Last)
import Data.Monoid (class Monoid, mempty)
import Data.Monoid.Additive (Additive)
import Data.Monoid.Conj (Conj(..))
import Data.Monoid.Disj (Disj(..))
import Data.Monoid.Dual (Dual(..))
import Data.Monoid.Endo (Endo(..))
import Data.Monoid.Multiplicative (Multiplicative)
import Data.Newtype (unwrap)

-- | A `Foldable` with an additional index.
-- | A `FoldableWithIndex` instance must be compatible with its `Foldable`
-- | instance
-- | ```purescript
-- | foldr f = foldrWithIndex (const f)
-- | foldl f = foldlWithIndex (const f)
-- | foldMap f = foldMapWithIndex (const f)
-- | ```
-- |
-- | Default implementations are provided by the following functions:
-- |
-- | - `foldrWithIndexDefault`
-- | - `foldlWithIndexDefault`
-- | - `foldMapWithIndexDefaultR`
-- | - `foldMapWithIndexDefaultL`
-- |
-- | Note: some combinations of the default implementations are unsafe to
-- | use together - causing a non-terminating mutually recursive cycle.
-- | These combinations are documented per function.
class Foldable f <= FoldableWithIndex i f | f -> i where
  foldrWithIndex :: forall a b. (i -> a -> b -> b) -> b -> f a -> b
  foldlWithIndex :: forall a b. (i -> b -> a -> b) -> b -> f a -> b
  foldMapWithIndex :: forall a m. Monoid m => (i -> a -> m) -> f a -> m

-- | A default implementation of `foldrWithIndex` using `foldMapWithIndex`.
-- |
-- | Note: when defining a `FoldableWithIndex` instance, this function is
-- | unsafe to use in combination with `foldMapWithIndexDefaultR`.
foldrWithIndexDefault
  :: forall i f a b
   . FoldableWithIndex i f
  => (i -> a -> b -> b)
  -> b
  -> f a
  -> b
foldrWithIndexDefault c u xs = unwrap (foldMapWithIndex (\i -> Endo <<< c i) xs) u

-- | A default implementation of `foldlWithIndex` using `foldMapWithIndex`.
-- |
-- | Note: when defining a `FoldableWithIndex` instance, this function is
-- | unsafe to use in combination with `foldMapWithIndexDefaultL`.
foldlWithIndexDefault
  :: forall i f a b
   . FoldableWithIndex i f
  => (i -> b -> a -> b)
  -> b
  -> f a
  -> b
foldlWithIndexDefault c u xs = unwrap (unwrap (foldMapWithIndex (\i -> Dual <<< Endo <<< flip (c i)) xs)) u

-- | A default implementation of `foldMapWithIndex` using `foldrWithIndex`.
-- |
-- | Note: when defining a `FoldableWithIndex` instance, this function is
-- | unsafe to use in combination with `foldrWithIndexDefault`.
foldMapWithIndexDefaultR
  :: forall i f a m
   . FoldableWithIndex i f
  => Monoid m
  => (i -> a -> m)
  -> f a
  -> m
foldMapWithIndexDefaultR f = foldrWithIndex (\i x acc -> f i x <> acc) mempty

-- | A default implementation of `foldMapWithIndex` using `foldlWithIndex`.
-- |
-- | Note: when defining a `FoldableWithIndex` instance, this function is
-- | unsafe to use in combination with `foldlWithIndexDefault`.
foldMapWithIndexDefaultL
  :: forall i f a m
   . FoldableWithIndex i f
  => Monoid m
  => (i -> a -> m)
  -> f a
  -> m
foldMapWithIndexDefaultL f = foldlWithIndex (\i acc x -> acc <> f i x) mempty

data Tuple a b = Tuple a b

instance foldableWithIndexArray :: FoldableWithIndex Int Array where
  foldrWithIndex f z = foldr (\(Tuple i x) y -> f i x y) z <<< mapWithIndex Tuple
  foldlWithIndex f z = foldl (\y (Tuple i x) -> f i y x) z <<< mapWithIndex Tuple
  foldMapWithIndex = foldMapWithIndexDefaultR

instance foldableWithIndexMaybe :: FoldableWithIndex Unit Maybe where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldableWithIndexFirst :: FoldableWithIndex Unit First where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldableWithIndexLast :: FoldableWithIndex Unit Last where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldableWithIndexAdditive :: FoldableWithIndex Unit Additive where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldableWithIndexDual :: FoldableWithIndex Unit Dual where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldableWithIndexDisj :: FoldableWithIndex Unit Disj where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldableWithIndexConj :: FoldableWithIndex Unit Conj where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldableWithIndexMultiplicative :: FoldableWithIndex Unit Multiplicative where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

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

-- | Traverse a data structure with access to the index, performing some
-- | effects encoded by an `Applicative` functor at each value, ignoring the
-- | final result.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > traverseWithIndex_ (curry logShow) ["a", "b", "c"]
-- | (Tuple 0 "a")
-- | (Tuple 1 "b")
-- | (Tuple 2 "c")
-- | ```
traverseWithIndex_
  :: forall i a b f m
   . Applicative m
  => FoldableWithIndex i f
  => (i -> a -> m b)
  -> f a
  -> m Unit
traverseWithIndex_ f = foldrWithIndex (\i -> (*>) <<< f i) (pure unit)

-- | A version of `traverseWithIndex_` with its arguments flipped.
-- |
-- | This can be useful when running an action written using do notation
-- | for every element in a data structure:
-- |
-- | For example:
-- |
-- | ```purescript
-- | forWithIndex_ ["a", "b", "c"] \i x -> do
-- |   logShow i
-- |   log x
-- | ```
forWithIndex_
  :: forall i a b f m
   . Applicative m
  => FoldableWithIndex i f
  => f a
  -> (i -> a -> m b)
  -> m Unit
forWithIndex_ = flip traverseWithIndex_

-- | `foldMapWithIndex` but with each element surrounded by some fixed value.
-- |
-- | For example:
-- |
-- | ```purescript
-- | > surroundMapWithIndex "*" (\i x -> show i <> x) []
-- | = "*"
-- |
-- | > surroundMapWithIndex "*" (\i x -> show i <> x) ["a"]
-- | = "*0a*"
-- |
-- | > surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b"]
-- | = "*0a*1b*"
-- |
-- | > surroundMapWithIndex "*" (\i x -> show i <> x) ["a", "b", "c"]
-- | = "*0a*1b*2c*"
-- | ```
surroundMapWithIndex
  :: forall i f a m
   . FoldableWithIndex i f
  => Semigroup m
  => m
  -> (i -> a -> m)
  -> f a
  -> m
surroundMapWithIndex d t f = unwrap (foldMapWithIndex joined f) d
  where joined i a = Endo \m -> d <> t i a <> m

-- | `allWithIndex f` is the same as `and <<< mapWithIndex f`; map a function over the
-- | structure, and then get the conjunction of the results.
allWithIndex
  :: forall i a b f
   . FoldableWithIndex i f
  => HeytingAlgebra b
  => (i -> a -> b)
  -> f a
  -> b
allWithIndex t = unwrap <<< foldMapWithIndex (\i -> Conj <<< t i)

-- | `anyWithIndex f` is the same as `or <<< mapWithIndex f`; map a function over the
-- | structure, and then get the disjunction of the results.
anyWithIndex
  :: forall i a b f
   . FoldableWithIndex i f
  => HeytingAlgebra b
  => (i -> a -> b)
  -> f a
  -> b
anyWithIndex t = unwrap <<< foldMapWithIndex (\i -> Disj <<< t i)

-- | Try to find an element in a data structure which satisfies a predicate
-- | with access to the index.
findWithIndex
  :: forall i a f
   . FoldableWithIndex i f
  => (i -> a -> Boolean)
  -> f a
  -> Maybe { index :: i, value :: a}
findWithIndex p = foldlWithIndex go Nothing
  where
  go
    :: i
    -> Maybe { index :: i, value :: a}
    -> a
    -> Maybe { index :: i, value :: a}
  go i Nothing x | p i x = Just { index: i, value: x}
  go _ r _ = r


Add type class for checking if a RowList conflicts...

with a given label and type

module Genetics.Browser.Track
       ( class TrackRecord
       , buildTrack
       , makeTrack
       , TrackConfigRecord
       , class TrackConfig
       , makeContainersImpl
       , makeContainers
       , class TrackData
       , fetchDataImpl
       , fetchData
       , class CombineFuns
       , combineFunsImpl
       , combineFuns
       ) where

import Prelude

import Data.Foldable (foldMap)
import Data.Maybe (Maybe)
import Data.Pair (Pair)
import Effect (Effect)
import Effect.Aff (Aff)
import Genetics.Browser.Canvas (TrackContainer, trackContainer, withLoadingIndicator)
import Genetics.Browser.Coordinates (CoordSysView)
import Genetics.Browser.Layer (TrackPadding)
import Genetics.Browser.Types (Point)
import Prim.Boolean (False, True, kind Boolean)
import Prim.Row as Row
import Prim.RowList (class RowToList, Cons, Nil, kind RowList)
import Record (delete, get, insert)
import Type.Data.Boolean as Boolean
import Type.Data.Symbol as Symbol
import Type.Prelude (class IsSymbol, class TypeEquals, Proxy(..), RLProxy(..), RProxy(..), SProxy(..), from)
import Unsafe.Coerce (unsafeCoerce)

type TrackInterface a =
  { render   :: Pair Number -> CoordSysView -> Aff Unit
  , hotspots :: Aff (Number -> Point -> Array a) }

class TrackRecord
      (trackList :: RowList)
      (trackRow :: # Type)
      a
      | trackList -> trackRow
      , trackList -> a where
  buildTrack :: RLProxy trackList
             -> Record trackRow
             -> TrackContainer
             -> Aff { render   :: Pair Number -> CoordSysView -> Aff Unit
                    , hotspots :: Aff (Number -> Point -> Array a) }

instance trackRecordRender ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Pair Number -> CoordSysView -> Aff Unit) trackRow' trackRow
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Pair Number -> CoordSysView -> Aff Unit) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let rLayer p c = (get name r) p c

    pure { render:   rLayer <> rest.render
         , hotspots: rest.hotspots }

instance trackRecordUI ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Aff Unit) trackRow' trackRow
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Aff Unit) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let rLayer _ _ = (get name r)

    pure { render:   rLayer <> rest.render
         , hotspots: rest.hotspots }

instance trackRecordHotspots ::
  ( IsSymbol  name
  , Row.Lacks name trackRow'
  , Row.Cons  name (Aff (Number -> pt -> Array a)) trackRow' trackRow
  , TypeEquals pt Point
  , TrackRecord trackTail trackRow' a
  ) => TrackRecord (Cons name (Aff (Number -> pt -> Array a)) trackTail) trackRow a where
  buildTrack _ r tcont = do

    let name = SProxy :: SProxy name

    rest <- buildTrack (RLProxy :: RLProxy trackTail)
                       (delete name r) tcont

    let hotspots = ado
          h  <- get name r
          h' <- rest.hotspots
          in \rad p -> h rad (from p) <> h' rad p

    pure { render: rest.render, hotspots }

instance trackRecordNil ::
  ( TypeEquals (Record trackRow) {}
  ) => TrackRecord Nil trackRow a where
  buildTrack _ _ _ = mempty

makeTrack :: ∀ row list a.
             RowToList row list
          => TrackRecord list row a
          => Record row
          -> TrackContainer
          -> Aff (TrackInterface a)
makeTrack r c = buildTrack (RLProxy :: RLProxy list) r c

type TrackConfigRecord r =
  { trackHeight :: Number
  , padding :: TrackPadding | r }

class TrackConfig
  (confList :: RowList)
  (confRow  :: # Type)
  (trackRow :: # Type)
  | confList -> confRow trackRow
  where
  makeContainersImpl :: RLProxy confList
                     -> Number
                     -> Record confRow
                     -> Effect (Record trackRow)

instance trackConfigNil ::
  ( TypeEquals (Record tr) {}
  ) => TrackConfig Nil cr tr where
  makeContainersImpl _ _ _ = pure $ from {}

instance trackConfigCons ::
  ( IsSymbol name
  , TrackConfig tail confRow' trackRow'
  , Row.Cons name c confRow' confRow
  , Row.Lacks name confRow'
  , Row.Cons name TrackContainer trackRow' trackRow
  , Row.Lacks name trackRow'
  , TypeEquals (TrackConfigRecord we) c
  ) => TrackConfig (Cons name c tail) confRow trackRow where
  makeContainersImpl _ width r = do
    let n = SProxy :: SProxy name

        c :: TrackConfigRecord we
        c = from $ get n r

    cont <- trackContainer
              {width, height: c.trackHeight}
              c.padding
              (Symbol.reflectSymbol n)

    rest <- makeContainersImpl
              (RLProxy :: RLProxy tail)
              width
              (delete n $ from r)

    pure $ insert n cont rest

makeContainers :: ∀ cl cr tr.
                  RowToList cr cl
               => TrackConfig cl cr tr
               => Number
               -> Record cr
               -> Effect (Record tr)
makeContainers = makeContainersImpl (RLProxy :: RLProxy cl)

class TrackData
      (fetcherList :: RowList)
      (fetcherRow :: # Type)
      (urlRow :: # Type)
      (dataRow :: # Type)
      | fetcherList -> fetcherRow
      , fetcherList -> urlRow
      , fetcherList -> dataRow where
  fetchDataImpl :: RLProxy fetcherList
            -> Record fetcherRow
            -> Record urlRow
            -> Aff (Record dataRow)

instance trackDataCons ::
  ( IsSymbol  name
  , Row.Lacks name fetcherRow'
  , Row.Cons  name (String -> Aff x) fetcherRow' fetcherRow
  , Monoid x
  , Row.Cons  name (Maybe String) urlRow' urlRow
  , Row.Lacks name dataRow'
  , Row.Cons  name x dataRow' dataRow
  , TrackData fetcherTail fetcherRow' urlRow dataRow'
  ) => TrackData (Cons name (String -> Aff x) fetcherTail)
                 fetcherRow
                 urlRow
                 dataRow where
  fetchDataImpl _ fetchers urls = do
    let name = SProxy :: _ name

    rest <- fetchDataImpl (RLProxy :: _ fetcherTail)
                          (delete name fetchers)
                          urls

    dataset <- foldMap (get name fetchers) (get name urls)

    pure $ insert name dataset rest

instance trackDataNil ::
  ( TypeEquals (Record dataRow) {}
  ) => TrackData Nil () urlRow dataRow where
  fetchDataImpl _ _ _ = pure $ from {}

-- | `fetchData` puts a loading indicator in the provided TrackContainer,
-- | fetches the data in the provided `urlRow` record, and parses it
-- | using the parsers in the provided `parserRow` record.
fetchData :: ∀ fetcherRow fetcherList urlRow urlList dataRow.
             RowToList fetcherRow fetcherList
          => RowToList urlRow urlList
          => TrackData fetcherList fetcherRow urlRow dataRow
          => TrackContainer
          -> Record fetcherRow
          -> Record urlRow
          -> Aff (Record dataRow)
fetchData tc fs urls = withLoadingIndicator tc
                       $ fetchDataImpl (RLProxy :: _ fetcherList)
                                       fs
                                       urls

-- | Combine a record of functions from records,
-- | into a function from a record of their union,
-- | to a record of their outputs.
-- | E.g. `{f :: Record r1 -> a, g :: Record r2 -> b}`
-- | into `Record (r1 + r2) -> { f :: a, g :: b }`
class CombineFuns
  (funsList :: RowList)
  (funsRow :: # Type)
  (argRow :: # Type)
  (outRow :: # Type)
  | funsList -> funsRow
  , funsList -> argRow
  , funsList -> outRow where
  combineFunsImpl :: RLProxy funsList
              -> Record funsRow
              -> Record argRow
              -> Record outRow

instance combineFunCons ::
  ( IsSymbol  name
  , Row.Lacks name funsRow'
  , Row.Cons  name (Record r -> a) funsRow' funsRow
  , Row.Union argRow' r argRowUnion
  , Row.Nub   argRowUnion argRowNubbed
  , Row.Lacks name outRow'
  , Row.Cons  name a outRow' outRow
  , CombineFuns funsTail funsRow' argRow' outRow'
  ) => CombineFuns (Cons name (Record r -> a) funsTail)
                  funsRow
                  argRowNubbed
                  outRow where
  combineFunsImpl _ funs args =
    let name = SProxy :: _ name

        thoseArgs :: Record argRow'
        thoseArgs = unsafeCoerce args

        theseArgs :: Record r
        theseArgs = unsafeCoerce args

        rest = combineFunsImpl (RLProxy :: _ funsTail)
                               (delete name funs)
                               thoseArgs
        fn = (get name funs)

    in (insert name (fn theseArgs) rest)

instance combineFunNil ::
  ( TypeEquals (Record outRow) {}
  ) => CombineFuns Nil () () outRow where
  combineFunsImpl _ _ _ = from {}

-- | Note! this isn't actually type safe yet.
-- | If two functions use arguments with the same label
-- | but different types, things break...
combineFuns :: ∀ funsList funsRow argRow outRow.
               RowToList funsRow funsList
            => CombineFuns funsList funsRow argRow outRow
            => Record funsRow
            -> Record argRow
            -> Record outRow
combineFuns funs args = combineFunsImpl (RLProxy :: _ funsList) funs args

class BuildLayers
  (layers :: # Type)
  (output :: # Type)
  | layers -> output

class GetBrowserConfig
  (totalConfig :: # Type)
  (browser :: # Type)
  | totalConfig -> browser where
    getBrowserConfigImpl :: Record totalConfig
                         -> Record browser

instance getBrowserConfig ::
  ( IsSymbol sBrowser
  , TypeEquals (SProxy sBrowser) (SProxy "browser")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")

  , Row.Cons sBrowser (Record browser') totalConfig' totalConfig
  , Row.Lacks sBrowser totalConfig'

  , Row.Cons sLayers layers browser browser'
  , Row.Lacks sLayers browser
  ) => GetBrowserConfig totalConfig browser where
  getBrowserConfigImpl total =
    let browser' :: Record browser'
        browser' = get (from (SProxy :: _ "browser")) total
    in delete (from (SProxy :: _ "layers")) browser'

class GetTrackConfig
  (totalConfig :: # Type)
  (track :: # Type)
  (trackName :: Symbol)
  | totalConfig trackName -> track where
    getTrackConfigImpl :: Record totalConfig
                       -> SProxy trackName
                       -> Record track

instance getTrackConfig ::
  ( IsSymbol sTracks
  , TypeEquals (SProxy sTracks) (SProxy "tracks")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")
  , IsSymbol trackName

  , Row.Cons sTracks (Record tracks) totalConfig' totalConfig
  , Row.Lacks sTracks totalConfig'

  , Row.Cons trackName (Record thisTrack') tracks' tracks
  , Row.Lacks trackName tracks'

  , Row.Cons sLayers layers thisTrack thisTrack'
  , Row.Lacks sLayers thisTrack

  ) => GetTrackConfig totalConfig thisTrack trackName where
    getTrackConfigImpl total _ =
      let tracks' :: Record tracks
          tracks' = get (from (SProxy :: _ "tracks")) total

          thisTrack :: Record thisTrack'
          thisTrack = get (from (SProxy :: _ trackName)) tracks'

      in delete (from (SProxy :: _ "layers")) thisTrack

class GetLayerConfig
  (totalConfig :: # Type)
  (layer :: # Type)
  (trackName :: Symbol)
  (layerName :: Symbol)
  | totalConfig trackName layerName -> layer where
    getLayerConfigImpl :: Record totalConfig
                       -> SProxy trackName
                       -> SProxy layerName
                       -> Record layer

instance getLayerConfig ::
  ( IsSymbol sTracks
  , TypeEquals (SProxy sTracks) (SProxy "tracks")
  , IsSymbol sLayers
  , TypeEquals (SProxy sLayers) (SProxy "layers")
  , IsSymbol trackName
  , IsSymbol layerName

  , Row.Cons sTracks (Record tracks) totalConfig' totalConfig
  , Row.Lacks sTracks totalConfig'

  , Row.Cons trackName (Record thisTrack) tracks' tracks
  , Row.Lacks trackName tracks'

  , Row.Cons sLayers (Record layers) thisTrack' thisTrack
  , Row.Lacks sLayers thisTrack

  , Row.Cons layerName (Record thisLayer) layers' layers
  , Row.Lacks layerName layers'
  ) => GetLayerConfig totalConfig thisLayer trackName layerName where
    getLayerConfigImpl total _ _ =
      let tracks' :: Record tracks
          tracks' = get (from (SProxy :: _ "tracks")) total

          thisTrack :: Record thisTrack
          thisTrack = get (from (SProxy :: _ trackName)) tracks'

          layers :: Record layers
          layers = get (from (SProxy :: _ "layers")) thisTrack

      in get (from (SProxy :: _ layerName)) layers

newtype LayerDef browser track layer a
  = LayerDef ({ browserConfig :: Record browser
              , trackConfig :: Record track
              , layerConfig :: Record layer }
              -> a)

class ApplyLayerDef
  (browser :: # Type)
  (track :: # Type)
  (layer :: # Type)
  (totalConfig :: # Type)
  (trackName :: Symbol)
  (layerName :: Symbol)
  a
  | trackName layerName totalConfig -> track layer where
    applyLayerDefImpl :: LayerDef browser track layer a
                      -> SProxy trackName
                      -> SProxy layerName
                      -> Record totalConfig
                      -> a

instance applyLayerDefInst ::
  ( IsSymbol trackName
  , IsSymbol layerName
  , GetBrowserConfig totalConfig browser
  , GetTrackConfig totalConfig track trackName
  , GetLayerConfig totalConfig layer trackName layerName
  ) => ApplyLayerDef browser track layer totalConfig trackName layerName a where
    applyLayerDefImpl (LayerDef f) trackName layerName total =
      let browserConfig = getBrowserConfigImpl total
          trackConfig = getTrackConfigImpl total trackName
          layerConfig = getLayerConfigImpl total trackName layerName
      in f { browserConfig, trackConfig, layerConfig }

applyLayerDef :: ∀ browser track layer trackName layerName config a.
                 IsSymbol trackName
              => IsSymbol layerName
              => ApplyLayerDef browser track layer config trackName layerName a
              => LayerDef browser track layer a
              -> SProxy trackName
              -> SProxy layerName
              -> Record config
              -> a
applyLayerDef = applyLayerDefImpl

-- | Class for checking if a RowList has a "conflict" with a
-- | given label and type. If the list lacks the label, or
-- | has the label with the same type, return False; if it
-- | has the label, but with a different type, return True.
class ConflictsWith
  (list :: RowList)
  (label :: Symbol)
  (t :: Type)
  (result :: Boolean)
  | list label t -> result

-- no conflict base case
instance conflictsWithNil ::
  ConflictsWith Nil label t False

-- same label and type, no conflict, recurse
instance conflictsWithCons1 ::
  ( ConflictsWith tail label t tailResult
  ) => ConflictsWith (Cons label  t  tail) label t tailResult

-- found conflict base case
else instance conflictsWithCons3 ::
  ConflictsWith (Cons label  t' tail) label t True

-- different label, same or different type, recurse
else instance conflictsWithCons2 ::
  ( ConflictsWith tail label t tailResult
  ) =>  ConflictsWith (Cons label' t' tail) label t tailResult

hasConflict :: ∀ row list l a .
                 RowToList row list
              => IsSymbol l
              => ConflictsWith list l a True
              => RProxy row
              -> SProxy l
              -> Proxy a
              -> Unit
hasConflict _ _ _ = unit

noConflict :: ∀ row list l a .
                 RowToList row list
              => IsSymbol l
              => ConflictsWith list l a False
              => RProxy row
              -> SProxy l
              -> Proxy a
              -> Unit
noConflict _ _ _ = unit

conflict1 = hasConflict  (RProxy :: _ (a :: Int, b :: String, c :: Boolean))
                         (SProxy :: _ "c") (Proxy :: _ Int)

conflict2 = hasConflict  (RProxy :: _ (a :: Int, b :: String, c :: Boolean))
                         (SProxy :: _ "b") (Proxy :: _ Int)

noconflict1 = noConflict (RProxy :: _ (a :: Int, b :: String, c :: Boolean))
                         (SProxy :: _ "d") (Proxy :: _ Int)

noconflict2 = noConflict (RProxy :: _ (a :: Int, b :: String, c :: Boolean))
                         (SProxy :: _ "b") (Proxy :: _ String)


Add empty method, needs correct type

Add empty method, needs correct type

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

module Tab
  ( Cell
  , Col
  , class ColType
  , kind
  , Tab
  ) where

import Prelude
import Data.Maybe (Maybe(..))
import Data.Vec
import Data.Vec (empty) as Vec
import Data.List
import Data.Typelevel.Num

type Col x = ColType x =>
  { id :: Int
  , name :: String
  , kind :: x
  }

class ColType a where
  kind :: a

instance stringCol :: ColType String where
  kind = ""

type Cell a = Maybe a

class Conv a where
  conv :: ColType a => a -> Cell a

instance convAny :: Conv a where
  conv x = Just x

newtype Tab size cols cells = Table
  { columns :: Vec size cols
  , rows :: List (Vec size cells)
  }

empty :: Tab D0 (Vec D0) List
empty = Tab
  { columns : Vec.empty
  , rows : Nil
  }

module Tab
  ( Cell
  , Col
  , class ColType
  , kind
  , Tab
  ) where

import Prelude
import Data.Maybe (Maybe(..))
import Data.Vec
import Data.List
import Data.Typelevel.Num

type Col x = ColType x =>
  { id :: Int
  , name :: String
  , kind :: x
  }

class ColType a where
  kind :: a

instance stringCol :: ColType String where
  kind = ""

type Cell a = Maybe a

class Conv a where
  conv :: ColType a => a -> Cell a

instance convAny :: Conv a where
  conv x = Just x

newtype Tab size cols cells = Table
  { columns :: Vec size cols
  , rows :: List (Vec size cells)
  }


Test quickCheck through type proxy and unit tests

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

module Test.Main where

import Prelude (Unit, discard, (>=), ($), (==), negate)

import Control.Monad.Free (Free)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Eff.Exception (EXCEPTION)
import Type.Proxy (Proxy(..))

import Test.Unit (suite, test, TestF)
import Test.Unit.Console (TESTOUTPUT)

import Test.Unit.Main (runTest)
import Test.Unit.Assert as Assert

import Test.QuickCheck (quickCheck)
import Test.QuickCheck.Arbitrary (class Arbitrary)

import Data.List (List(..), (:))
import Main (length, sum)

main :: forall e. Eff (console :: CONSOLE, testOutput :: TESTOUTPUT, random :: RANDOM, avar :: AVAR, exception :: EXCEPTION | e) Unit
main = do
  mainQuickCheck
  mainUnit

-- Using QuickCheck
mainQuickCheck :: forall e. Eff (console :: CONSOLE, random :: RANDOM, exception :: EXCEPTION | e) Unit
mainQuickCheck = do
  testWith (Proxy :: Proxy Int)
  testWith (Proxy :: Proxy Char)
  testWith (Proxy :: Proxy String)
  testWith (Proxy :: Proxy Boolean)

testWith :: forall a e. Arbitrary a => Proxy a -> Eff (console :: CONSOLE, random :: RANDOM, exception :: EXCEPTION | e) Unit
testWith _ = do
  quickCheck \(xs :: List a) -> length xs >= 0

-- Using Test.Unit
mainUnit :: forall e. Eff (console :: CONSOLE, testOutput :: TESTOUTPUT, avar :: AVAR | e) Unit
mainUnit = runTest do
  sumTest
  lengthTest

sumTest :: forall e. Free (TestF e) Unit
sumTest = suite "sum" do
  test "should be zero for empty list" do
    Assert.assert "empty array should be 0" $ (sum Nil) == 0
  test "should be the same value for a single element" do
    Assert.assert "0 for [0]" $ (sum (0 : Nil)) == 0
    Assert.assert "1 for [1]" $ (sum (1 : Nil)) == 1
    Assert.assert "-210 for [-210]" $ (sum (-210 : Nil)) == -210
    Assert.assert "93152 for [93152]" $ (sum (93152 : Nil)) == 93152
  test "should sum up multiple values of variable length" do
    Assert.assert "0 for [0, 0, 0, 0, 0]" $ (sum (0 : 0 : 0 : 0 : 0 : Nil)) == 0
    Assert.assert "1 for [1, 2, 3, 4]" $ (sum (1 : 2 : 3 : 4 : Nil)) == 10
    Assert.assert "77 for [6, 1, 15, 52, 3]" $ (sum (6 : 1 : 15 : 52 : 3 : Nil)) == 77

lengthTest :: forall e. Free (TestF e) Unit
lengthTest = suite "length" do
  test "should be zero for empty list" do
    Assert.assert "empty list should be 0" $ (length Nil) == 0
  test "should be the same value for a single element" do
    Assert.assert "1 for [0]" $ (length (0 : Nil)) == 1
    Assert.assert "1 for [-123]" $ (length (-123 : Nil)) == 1
    Assert.assert "1 for [[]]" $ (length ((Nil) : Nil)) == 1
  test "should length up multiple values of variable length" do
    Assert.assert "3 for [[1], [2], [3]]" $ (length ((1 : Nil) : (2 : Nil) : (3 : Nil) : Nil)) == 3
    Assert.assert "3 for [[], [1], [2]]" $ (length ((Nil) : (1 : Nil) : (2 : Nil) : Nil)) == 3
    Assert.assert "2 for [[1, 2], [3, 4]]" $ (length ((1 : 2 : Nil) : (3 : 4 : Nil) : Nil)) == 2

module Test.Main where

import Prelude (Unit, discard, (>=))

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Eff.Exception (EXCEPTION)

-- import Test.Unit (suite, test, TestF)
-- import Test.Unit.Console (TESTOUTPUT)
--
-- import Test.Unit.Main (runTest)
-- import Test.Unit.Assert as Assert

import Test.QuickCheck (quickCheck)

import Data.List (List)
import Main (length)

main :: forall e. Eff (console :: CONSOLE, random :: RANDOM, exception :: EXCEPTION | e) Unit
main = mainQuickCheck

-- Using QuickCheck
mainQuickCheck :: forall e. Eff (console :: CONSOLE, random :: RANDOM, exception :: EXCEPTION | e) Unit
mainQuickCheck = do
  quickCheck \(xs :: List Int) -> length xs >= 0
  quickCheck \(xs :: List Char) -> length xs >= 0
  quickCheck \(xs :: List String) -> length xs >= 0
  quickCheck \(xs :: List Boolean) -> length xs >= 0

-- Using Test.Unit
-- mainUnit :: forall e. Eff (console :: CONSOLE, testOutput :: TESTOUTPUT, avar :: AVAR | e) Unit
-- mainUnit = runTest do
--   sumTest
--   lengthTest
--
-- sumTest :: forall e. Free (TestF e) Unit
-- sumTest = suite "sum" do
--   test "should be zero for empty list" do
--     Assert.assert "empty array should be 0" $ (sum Nil) == 0
--   test "should be the same value for a single element" do
--     Assert.assert "0 for [0]" $ (sum (0 : Nil)) == 0
--     Assert.assert "1 for [1]" $ (sum (1 : Nil)) == 1
--     Assert.assert "-210 for [-210]" $ (sum (-210 : Nil)) == -210
--     Assert.assert "93152 for [93152]" $ (sum (93152 : Nil)) == 93152
--   test "should sum up multiple values of variable length" do
--     Assert.assert "0 for [0, 0, 0, 0, 0]" $ (sum (0 : 0 : 0 : 0 : 0 : Nil)) == 0
--     Assert.assert "1 for [1, 2, 3, 4]" $ (sum (1 : 2 : 3 : 4 : Nil)) == 10
--     Assert.assert "77 for [6, 1, 15, 52, 3]" $ (sum (6 : 1 : 15 : 52 : 3 : Nil)) == 77
--
-- lengthTest :: forall e. Free (TestF e) Unit
-- lengthTest = suite "length" do
--   test "should be zero for empty list" do
--     Assert.assert "empty list should be 0" $ (length Nil) == 0
--   test "should be the same value for a single element" do
--     Assert.assert "1 for [0]" $ (length (0 : Nil)) == 1
--     Assert.assert "1 for [-123]" $ (length (-123 : Nil)) == 1
--     Assert.assert "1 for [[]]" $ (length ((Nil) : Nil)) == 1
--   test "should length up multiple values of variable length" do
--     Assert.assert "3 for [[1], [2], [3]]" $ (length ((1 : Nil) : (2 : Nil) : (3 : Nil) : Nil)) == 3
--     Assert.assert "3 for [[], [1], [2]]" $ (length ((Nil) : (1 : Nil) : (2 : Nil) : Nil)) == 3
--     Assert.assert "2 for [[1, 2], [3, 4]]" $ (length ((1 : 2 : Nil) : (3 : 4 : Nil) : Nil)) == 2
--


Navbar

Navbar

module Component.Page where

import Prelude

import Halogen
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Halogen.HTML.Core (className)

import Halogen.Component.ChildPath (ChildPath(), cpL, cpR, (:>))

import Control.Monad.Aff.Class

import Data.Maybe (Maybe(Nothing))
import Data.Either (Either(..))
import Data.Functor.Coproduct (Coproduct())
import Data.Tuple

import Component.Blog as Blog
import Component.Jenny as Jenny
import Model

type State = Page
type PageEffects a = Blog.BlogEffects a

data Query a =
  Navigate Page a

data BlogSlot = BlogSlot

instance ordBlogSlot :: Ord BlogSlot where
  compare _ _ = EQ

instance eqBlogSlot :: Eq BlogSlot where
  eq _ _ = true

data JennySlot = JennySlot
instance ordJennySlot :: Ord JennySlot where
  compare _ _ = EQ

instance eqJennySlot :: Eq JennySlot where
  eq _ _ = true

type ChildState g = Either (Blog.FState g) Jenny.State
type ChildQuery = Coproduct (Blog.FQuery) (Jenny.Query )
type ChildSlot = Either BlogSlot JennySlot

type FState g = ParentState State (ChildState g) Query ChildQuery g ChildSlot
type FQuery = Coproduct Query (ChildF ChildSlot ChildQuery)
type PageDSL g = ParentDSL State (ChildState g) Query ChildQuery g ChildSlot
type PageHTML g = ParentHTML (ChildState g) Query ChildQuery g ChildSlot

page :: forall a eff . (Functor a, MonadAff (PageEffects eff) a) => Component (FState a) FQuery a
page =
  parentComponent {render, eval, peek: Nothing}
  where
    render :: State -> PageHTML a
    render s = H.div_
               [ renderLinks
               , H.h1_
                 [ H.text "Toby's Blog" ]
               , renderPage s]

    eval :: Natural Query (PageDSL a)
    eval (Navigate p a) = do
      modify (\_ -> p)
      pure a

    renderPage :: State -> PageHTML a
    renderPage BlogPage = H.slot' pathToBlog BlogSlot (\_ -> {initialState: parentState initialBlog, component: Blog.blog})
    renderPage JennyPage = H.slot' pathToJenny JennySlot (\_ -> {initialState: unit, component: Jenny.jenny})

    pathToBlog :: ChildPath (Blog.FState a) (ChildState a) Blog.FQuery ChildQuery BlogSlot ChildSlot
    pathToBlog = cpL

    pathToJenny :: ChildPath Jenny.State (ChildState a) Jenny.Query ChildQuery JennySlot ChildSlot
    pathToJenny = cpR

    renderLinks :: PageHTML a
    renderLinks = makeHeader "TOBY" [ Tuple "BLOG" "/#/blog"
                  , Tuple "JENNY" "/#/jenny"
                  ]

    makeHeader :: String -> Array (Tuple String String) -> PageHTML a
    makeHeader title hs = H.div [P.classes $ map className ["pure-menu", "pure-menu-horizontal", "pure-u-1"]]
                          [ H.a [P.href "/#/", P.classes $ map className ["pure-menu-heading", "pure-menu-link"]] [H.text title]
                          , H.ul [P.class_ $ className "pure-menu-list"]
                            (map (\(Tuple n l) -> H.li [P.class_ $ className "pure-menu-item"]
                                                  [H.a [P.class_ $ className "pure-menu-link" , P.href l]
                                                    [H.text n]])
                             hs)]

module Component.Page where

import Prelude

import Halogen
import Halogen.HTML.Indexed as H
import Halogen.Component.ChildPath (ChildPath(), cpL, cpR, (:>))

import Control.Monad.Aff.Class

import Data.Maybe (Maybe(Nothing))
import Data.Either (Either(..))
import Data.Functor.Coproduct (Coproduct())

import Component.Blog as Blog
import Component.Jenny as Jenny
import Model

type State = Page
type PageEffects a = Blog.BlogEffects a

data Query a =
  Navigate Page a

data BlogSlot = BlogSlot

instance ordBlogSlot :: Ord BlogSlot where
  compare _ _ = EQ

instance eqBlogSlot :: Eq BlogSlot where
  eq _ _ = true

data JennySlot = JennySlot
instance ordJennySlot :: Ord JennySlot where
  compare _ _ = EQ

instance eqJennySlot :: Eq JennySlot where
  eq _ _ = true

type ChildState g = Either (Blog.FState g) Jenny.State
type ChildQuery = Coproduct (Blog.FQuery) (Jenny.Query )
type ChildSlot = Either BlogSlot JennySlot

type FState g = ParentState State (ChildState g) Query ChildQuery g ChildSlot
type FQuery = Coproduct Query (ChildF ChildSlot ChildQuery)
type PageDSL g = ParentDSL State (ChildState g) Query ChildQuery g ChildSlot
type PageHTML g = ParentHTML (ChildState g) Query ChildQuery g ChildSlot

page :: forall a eff . (Functor a, MonadAff (PageEffects eff) a) => Component (FState a) FQuery a
page =
  parentComponent {render, eval, peek: Nothing}
  where
    render :: State -> PageHTML a
    render s = H.div_
               [ H.h1_
                 [ H.text "Toby's Blog" ]
               , renderPage s]

    eval :: Natural Query (PageDSL a)
    eval (Navigate p a) = do
      modify (\_ -> p)
      pure a

    renderPage :: State -> PageHTML a
    renderPage BlogPage = H.slot' pathToBlog BlogSlot (\_ -> {initialState: parentState initialBlog, component: Blog.blog})
    renderPage JennyPage = H.slot' pathToJenny JennySlot (\_ -> {initialState: unit, component: Jenny.jenny})

    pathToBlog :: ChildPath (Blog.FState a) (ChildState a) Blog.FQuery ChildQuery BlogSlot ChildSlot
    pathToBlog = cpL

    pathToJenny :: ChildPath Jenny.State (ChildState a) Jenny.Query ChildQuery JennySlot ChildSlot
    pathToJenny = cpR


Fix error div width

Fix error div width

module HtmlViews where

import Prelude hiding (div)
import Data.Foldable (foldr, for_)
import Data.Lens.Getter ((^.))
import Control.Monad (when)
import Data.Tuple
import Data.Tuple.Nested ((/\))
import Data.Maybe
import Data.String as String
import Data.Array (sortBy, reverse, catMaybes)
import Data.List as List
import Data.Function (on)
import Data.Map as M
import Text.Smolder.HTML
  (html, head, title, meta, script, style, body, div, h1, h2, canvas, title,
  link, p, input, a)
import Text.Smolder.HTML.Attributes
  (lang, charset, httpEquiv, content, src, defer, type', id, className, name,
  rel, href)
import Text.Smolder.Markup (text, (!))
import Text.Smolder.HTML (Html)

import Utils
import Types
import Style

replaceAll :: Array (Tuple String String) -> String -> String
replaceAll =
  map (\(var /\ value) -> String.replace (String.Pattern var) (String.Replacement value)) >>>
  foldr (>>>) identity

styles =
  -- TODO: this is a bit silly. purescript-css?
  replaceAll
    [ "${linkColor}" /\ linkColor
    , "${backgroundColor}" /\ backgroundColor
    , "${backgroundColor}" /\ backgroundColor
    , "${backgroundColorLighter}" /\ backgroundColorLighter
    , "${fontColor}" /\ fontColor
    , "${fontColor}" /\ fontColor
    , "${fontColor}" /\ fontColor
    , "${fontName}" /\ fontName
    , "${tileColor}" /\ tileColor
    , "${canvasSize}" /\ (show canvasSize)
    , "${canvasSize}" /\ (show canvasSize)
    , "${canvasSize}" /\ (show canvasSize)
    , "${canvasSize}" /\ (show canvasSize)
    , "${canvasSize}" /\ (show canvasSize)
    ] $ rawStyles <> playerColorStyles

rawStyles = """
  .clearfix:after {
	visibility: hidden;
	display: block;
	font-size: 0;
	content: " ";
	clear: both;
	height: 0;
  }

  body {
    background-color: ${backgroundColor};
    color: ${fontColor};
    font: normal 100% ${fontName}, sans-serif;
    margin: 0;
  }

  h1 {
    padding-top: 1em;
    text-align: center;
  }

  div, p {
    word-wrap: break-word;
  }

  a, a:visited {
    color: ${linkColor};
  }

  input {
    border: 5px solid ${fontColor};
    -webkit-box-shadow:
      inset 0 0 8px  rgba(0,0,0,0.1),
            0 0 16px rgba(0,0,0,0.1);
    -moz-box-shadow:
      inset 0 0 8px  rgba(0,0,0,0.1),
            0 0 16px rgba(0,0,0,0.1);
     box-shadow:
      inset 0 0 8px  rgba(0,0,0,0.1),
            0 0 16px rgba(0,0,0,0.1);
    padding: 10px;
    background: rgba(255,255,255,0.3);
    margin: 0 0 10px 0;
    font-size: 150%;
    color: ${fontColor};
    width: 300px;
  }

  #game {
    margin: 0 auto;
    width: ${canvasSize}px;
  }

  #background {
    position: absolute;
    z-index: 0;
  }

  #foreground {
    position: absolute;
    z-index: 1;
  }

  #scores-container {
    position: absolute;
    z-index: 2;
    width: ${canvasSize}px;
  }

  #waiting-message {
    position: absolute;
    z-index: 3;
    width: ${canvasSize}px;
  }

  #prompt {
    z-index: 3;
    margin: 0 auto;
    text-align: center;
    width: ${canvasSize}px;
    font-size: 145%;
  }

  #waiting-message p {
    text-align: center;
    font-size: 140%;
    margin-left: 0 auto;
    margin-right: 0 auto;
  }

  #error {
    position: fixed;
    top: 25%;
    left: 50%;
    transform: translate(-50%, -50%);
    z-index: 101;

    width: calc(${canvasSize}px - 5px);
    background-color: ${backgroundColor};
    display: none;

    border: 1px solid;
    border-radius: 10px;
  }

  #error-overlay {
    position: fixed;
    top: 0;
    left: 0;
    width: 100%;
    height: 100%;
    display: none;
    z-index: 100;
    background-color: rgba(0,0,0, 0.5);
  }

  #error h2 {
    text-align: center;
  }

  #error p {
    padding: 0 4em 0 4em;
  }

  .scores {
    margin-bottom: 5em;
  }

  .scores-header {
    font-size: 200%;
    text-align: center;
  }

  .scores-row {
    height: 2em;
    padding: 0.5em 1em 0.5em 1em;
    margin: 0 auto;
    width: 80%;
  }

  .simple-scores {
    width: 80%;
    margin-left: 10px;
  }

  .simple-scores .player-P1,
  .simple-scores .player-P2,
  .simple-scores .player-P3,
  .simple-scores .player-P4 {
    text-align: right;
  }

  .is-you {
    background-color: ${backgroundColorLighter};
  }

  .scores-cell {
    font-size: 150%;
    float: left;
  }

  .cell-wide {
    width: 60%;
  }

  .cell-thin {
    width: 20%;
  }

  .cell-thinnest {
    width: 11%;
  }

  .score {
    text-align: center;
  }

  .ready-state {
    width: 25%;
    float: left;
  }
"""

playerColorStyles :: String
playerColorStyles =
  concat $
    flip map allPlayerIds
      (\pId ->
        concat [".player-"
               , displayPlayerId pId
               , " { color: "
               , playerColor pId
               , ";}\n"
               ])
  where
  concat = String.joinWith ""

indexHtml :: forall void. Html void
indexHtml =
  html ! lang "en" $ do
    head $ do
      title $ text "multipac"
      meta ! charset "utf-8"
      meta ! httpEquiv "X-UA-Compatible" ! content "IE=edge,chrome=1"
      script ! src "/js/client.js" ! defer "" $ text " "
      link ! rel "stylesheet" ! type' "text/css" ! href fontUrl
      link ! rel "stylesheet" ! type' "text/css" ! href "style.css"

    body $ do
      div ! id "error-overlay" $ text " "
      div ! id "game" $ do
        h1 $ text "multipac"

        div ! id "prompt" $ do
          p ! id "prompt-message" $ text " "
          input ! id "prompt-input" ! type' "text"

        div ! id "waiting-message" $ text " "

        canvas ! id "foreground" $ text " "
        canvas ! id "background" $ text " "

        div ! id "error" $ do
          h2 $ text "disconnected"
          p $ do
            text "Something went wrong and the server couldn't be contacted. "
            text "Please "
            a ! href "" $ text "refresh the page"
            text " to reconnect."

        div ! id "scores-container" $ text " "

type PlayerReadyInfo
  = { ready :: Boolean
    , name  :: String
    }

waitingMessage :: forall void.
  ClientStateWaiting -> PlayerId -> M.Map PlayerId String -> Html void
waitingMessage sw pId playersMap = do
  whenJust sw.prevGame (scoresTable pId playersMap)

  let r = fromMaybe NotReady $ M.lookup pId sw.readyStates
  p $ text $ case r of
               Ready -> "Waiting for other players..."
               NotReady -> "Press SPACE when you're ready"

  div ! className "clearfix" $
    for_ allPlayerIds $ \pId' -> do
      let mInfo = getPlayerInfo pId'
      let cl = "ready-state" <>
                    (if pId' == pId then " is-you" else "") <>
                    (if isJust mInfo then "" else " not-connected")

      div ! className cl $ do
        let pId'str = displayPlayerId pId'
        let cl' = "player-" <> pId'str
        p ! className cl' $ text pId'str
        whenJust mInfo $ \info -> do
          p $ text info.name
          p $ text $ case info.ready of
                       Ready -> "ready!"
                       NotReady -> "not ready"
  where
  getPlayerInfo pId'' = do
    ready <- M.lookup pId'' sw.readyStates
    name <- M.lookup pId'' playersMap
    pure $ { ready: ready, name: name }

type PlayerScoreInfo
  = { score :: Int
    , name  :: String
    , pId   :: PlayerId
    }

scoresTable :: forall void. PlayerId -> M.Map PlayerId String -> Game -> Html void
scoresTable pId playersMap game =
  div ! className "scores clearfix" $ do
    h2 ! className "scores-header" $ text "scores"
    div ! className "scores-table" $ do
      for_ (sortedPlayerInfos game) $ \info -> do
        let cl = "scores-row" <> (if info.pId == pId then " is-you" else "")
        div ! className cl $ do
          let pIdStr = displayPlayerId info.pId
          scoresCellDiv ["cell-thin", "player-" <> pIdStr] pIdStr
          scoresCellDiv ["cell-wide"] info.name
          scoresCellDiv ["cell-thin", "score"] (show info.score)
  where
  sortedPlayerInfos game =
    List.reverse $ List.sortBy (compare `on` score) (playerInfos game playersMap)

  score i = i.score

  scoresCellDiv classes innerText =
    div ! className (String.joinWith " " $ ["scores-cell"] <> classes) $
      text innerText

playerInfos game playersMap =
  List.catMaybes $ map (getPlayerInfo playersMap) allPlayers
  where
  allPlayers = M.toUnfoldable (game ^. players)

getPlayerInfo ::
  M.Map PlayerId String -> Tuple PlayerId Player -> Maybe PlayerScoreInfo
getPlayerInfo playersMap (Tuple pId'' p) = do
  name <- M.lookup pId'' playersMap
  pure $ { score: p ^. pScore, name: name, pId: pId'' }

simpleScores :: forall e. M.Map PlayerId String -> Game -> Html e
simpleScores playersMap game = do
  div ! className "simple-scores" $ do
    for_ (playerInfos game playersMap) $ \info -> do
      let pId = displayPlayerId info.pId
      scoresCellDiv ["cell-thinnest", "player-" <> pId] pId
      scoresCellDiv ["cell-thinnest", "score"] (show info.score)

  where
  scoresCellDiv classes innerText =
    div ! className (String.joinWith " " $ ["scores-cell"] <> classes) $
      text innerText

module HtmlViews where

import Prelude hiding (div)
import Data.Foldable (foldr, for_)
import Data.Lens.Getter ((^.))
import Control.Monad (when)
import Data.Tuple
import Data.Tuple.Nested ((/\))
import Data.Maybe
import Data.String as String
import Data.Array (sortBy, reverse, catMaybes)
import Data.List as List
import Data.Function (on)
import Data.Map as M
import Text.Smolder.HTML
  (html, head, title, meta, script, style, body, div, h1, h2, canvas, title,
  link, p, input, a)
import Text.Smolder.HTML.Attributes
  (lang, charset, httpEquiv, content, src, defer, type', id, className, name,
  rel, href)
import Text.Smolder.Markup (text, (!))
import Text.Smolder.HTML (Html)

import Utils
import Types
import Style

replaceAll :: Array (Tuple String String) -> String -> String
replaceAll =
  map (\(var /\ value) -> String.replace (String.Pattern var) (String.Replacement value)) >>>
  foldr (>>>) identity

styles =
  -- TODO: this is a bit silly. purescript-css?
  replaceAll
    [ "${linkColor}" /\ linkColor
    , "${backgroundColor}" /\ backgroundColor
    , "${backgroundColor}" /\ backgroundColor
    , "${backgroundColorLighter}" /\ backgroundColorLighter
    , "${fontColor}" /\ fontColor
    , "${fontColor}" /\ fontColor
    , "${fontColor}" /\ fontColor
    , "${fontName}" /\ fontName
    , "${tileColor}" /\ tileColor
    , "${canvasSize}" /\ (show canvasSize)
    , "${canvasSize}" /\ (show canvasSize)
    , "${canvasSize}" /\ (show canvasSize)
    , "${canvasSize}" /\ (show canvasSize)
    , "${canvasSize}" /\ (show canvasSize)
    ] $ rawStyles <> playerColorStyles

rawStyles = """
  .clearfix:after {
	visibility: hidden;
	display: block;
	font-size: 0;
	content: " ";
	clear: both;
	height: 0;
  }

  body {
    background-color: ${backgroundColor};
    color: ${fontColor};
    font: normal 100% ${fontName}, sans-serif;
    margin: 0;
  }

  h1 {
    padding-top: 1em;
    text-align: center;
  }

  div, p {
    word-wrap: break-word;
  }

  a, a:visited {
    color: ${linkColor};
  }

  input {
    border: 5px solid ${fontColor};
    -webkit-box-shadow:
      inset 0 0 8px  rgba(0,0,0,0.1),
            0 0 16px rgba(0,0,0,0.1);
    -moz-box-shadow:
      inset 0 0 8px  rgba(0,0,0,0.1),
            0 0 16px rgba(0,0,0,0.1);
     box-shadow:
      inset 0 0 8px  rgba(0,0,0,0.1),
            0 0 16px rgba(0,0,0,0.1);
    padding: 10px;
    background: rgba(255,255,255,0.3);
    margin: 0 0 10px 0;
    font-size: 150%;
    color: ${fontColor};
    width: 300px;
  }

  #game {
    margin: 0 auto;
    width: ${canvasSize}px;
  }

  #background {
    position: absolute;
    z-index: 0;
  }

  #foreground {
    position: absolute;
    z-index: 1;
  }

  #scores-container {
    position: absolute;
    z-index: 2;
    width: ${canvasSize}px;
  }

  #waiting-message {
    position: absolute;
    z-index: 3;
    width: ${canvasSize}px;
  }

  #prompt {
    z-index: 3;
    margin: 0 auto;
    text-align: center;
    width: ${canvasSize}px;
    font-size: 145%;
  }

  #waiting-message p {
    text-align: center;
    font-size: 140%;
    margin-left: 0 auto;
    margin-right: 0 auto;
  }

  #error {
    position: fixed;
    top: 25%;
    left: 50%;
    transform: translate(-50%, -50%);
    z-index: 101;

    width: ${canvasSize}px;
    background-color: ${backgroundColor};
    display: none;

    border: 1px solid;
    border-radius: 10px;
  }

  #error-overlay {
    position: fixed;
    top: 0;
    left: 0;
    width: 100%;
    height: 100%;
    display: none;
    z-index: 100;
    background-color: rgba(0,0,0, 0.5);
  }

  #error h2 {
    text-align: center;
  }

  #error p {
    padding: 0 4em 0 4em;
  }

  .scores {
    margin-bottom: 5em;
  }

  .scores-header {
    font-size: 200%;
    text-align: center;
  }

  .scores-row {
    height: 2em;
    padding: 0.5em 1em 0.5em 1em;
    margin: 0 auto;
    width: 80%;
  }

  .simple-scores {
    width: 80%;
    margin-left: 10px;
  }

  .simple-scores .player-P1,
  .simple-scores .player-P2,
  .simple-scores .player-P3,
  .simple-scores .player-P4 {
    text-align: right;
  }

  .is-you {
    background-color: ${backgroundColorLighter};
  }

  .scores-cell {
    font-size: 150%;
    float: left;
  }

  .cell-wide {
    width: 60%;
  }

  .cell-thin {
    width: 20%;
  }

  .cell-thinnest {
    width: 11%;
  }

  .score {
    text-align: center;
  }

  .ready-state {
    width: 25%;
    float: left;
  }
"""

playerColorStyles :: String
playerColorStyles =
  concat $
    flip map allPlayerIds
      (\pId ->
        concat [".player-"
               , displayPlayerId pId
               , " { color: "
               , playerColor pId
               , ";}\n"
               ])
  where
  concat = String.joinWith ""

indexHtml :: forall void. Html void
indexHtml =
  html ! lang "en" $ do
    head $ do
      title $ text "multipac"
      meta ! charset "utf-8"
      meta ! httpEquiv "X-UA-Compatible" ! content "IE=edge,chrome=1"
      script ! src "/js/client.js" ! defer "" $ text " "
      link ! rel "stylesheet" ! type' "text/css" ! href fontUrl
      link ! rel "stylesheet" ! type' "text/css" ! href "style.css"

    body $ do
      div ! id "error-overlay" $ text " "
      div ! id "game" $ do
        h1 $ text "multipac"

        div ! id "prompt" $ do
          p ! id "prompt-message" $ text " "
          input ! id "prompt-input" ! type' "text"

        div ! id "waiting-message" $ text " "

        canvas ! id "foreground" $ text " "
        canvas ! id "background" $ text " "

        div ! id "error" $ do
          h2 $ text "disconnected"
          p $ do
            text "Something went wrong and the server couldn't be contacted. "
            text "Please "
            a ! href "" $ text "refresh the page"
            text " to reconnect."

        div ! id "scores-container" $ text " "

type PlayerReadyInfo
  = { ready :: Boolean
    , name  :: String
    }

waitingMessage :: forall void.
  ClientStateWaiting -> PlayerId -> M.Map PlayerId String -> Html void
waitingMessage sw pId playersMap = do
  whenJust sw.prevGame (scoresTable pId playersMap)

  let r = fromMaybe NotReady $ M.lookup pId sw.readyStates
  p $ text $ case r of
               Ready -> "Waiting for other players..."
               NotReady -> "Press SPACE when you're ready"

  div ! className "clearfix" $
    for_ allPlayerIds $ \pId' -> do
      let mInfo = getPlayerInfo pId'
      let cl = "ready-state" <>
                    (if pId' == pId then " is-you" else "") <>
                    (if isJust mInfo then "" else " not-connected")

      div ! className cl $ do
        let pId'str = displayPlayerId pId'
        let cl' = "player-" <> pId'str
        p ! className cl' $ text pId'str
        whenJust mInfo $ \info -> do
          p $ text info.name
          p $ text $ case info.ready of
                       Ready -> "ready!"
                       NotReady -> "not ready"
  where
  getPlayerInfo pId'' = do
    ready <- M.lookup pId'' sw.readyStates
    name <- M.lookup pId'' playersMap
    pure $ { ready: ready, name: name }

type PlayerScoreInfo
  = { score :: Int
    , name  :: String
    , pId   :: PlayerId
    }

scoresTable :: forall void. PlayerId -> M.Map PlayerId String -> Game -> Html void
scoresTable pId playersMap game =
  div ! className "scores clearfix" $ do
    h2 ! className "scores-header" $ text "scores"
    div ! className "scores-table" $ do
      for_ (sortedPlayerInfos game) $ \info -> do
        let cl = "scores-row" <> (if info.pId == pId then " is-you" else "")
        div ! className cl $ do
          let pIdStr = displayPlayerId info.pId
          scoresCellDiv ["cell-thin", "player-" <> pIdStr] pIdStr
          scoresCellDiv ["cell-wide"] info.name
          scoresCellDiv ["cell-thin", "score"] (show info.score)
  where
  sortedPlayerInfos game =
    List.reverse $ List.sortBy (compare `on` score) (playerInfos game playersMap)

  score i = i.score

  scoresCellDiv classes innerText =
    div ! className (String.joinWith " " $ ["scores-cell"] <> classes) $
      text innerText

playerInfos game playersMap =
  List.catMaybes $ map (getPlayerInfo playersMap) allPlayers
  where
  allPlayers = M.toUnfoldable (game ^. players)

getPlayerInfo ::
  M.Map PlayerId String -> Tuple PlayerId Player -> Maybe PlayerScoreInfo
getPlayerInfo playersMap (Tuple pId'' p) = do
  name <- M.lookup pId'' playersMap
  pure $ { score: p ^. pScore, name: name, pId: pId'' }

simpleScores :: forall e. M.Map PlayerId String -> Game -> Html e
simpleScores playersMap game = do
  div ! className "simple-scores" $ do
    for_ (playerInfos game playersMap) $ \info -> do
      let pId = displayPlayerId info.pId
      scoresCellDiv ["cell-thinnest", "player-" <> pId] pId
      scoresCellDiv ["cell-thinnest", "score"] (show info.score)

  where
  scoresCellDiv classes innerText =
    div ! className (String.joinWith " " $ ["scores-cell"] <> classes) $
      text innerText


better wording

better wording

module HtmlViews where

import Data.Foldable (foldr, for_)
import Prelude hiding (id)
import Control.Lens ((~), (^.))
import Control.Monad (when)
import Data.Tuple
import Data.Maybe
import Data.String (replace, joinWith)
import Data.Array (sortBy, reverse, map, catMaybes)
import Data.Function (on)
import qualified Data.Map as M
import Text.Smolder.HTML
  (html, head, meta, script, style, body, div, h1, h2, canvas, title, link, p,
   input, a)
import Text.Smolder.HTML.Attributes
  (lang, charset, httpEquiv, content, src, defer, type', id, className, name,
  rel, href)
import Text.Smolder.Markup (text, (!), Markup())
import Text.Smolder.Renderer.String (render)

import Utils
import Types
import Style

replaceAll :: [Tuple String String] -> String -> String
replaceAll = fmap (uncurry replace) >>> foldr (>>>) Prelude.id

styles =
  replaceAll
    [ "${backgroundColor}" ~ backgroundColor
    , "${backgroundColor}" ~ backgroundColor
    , "${backgroundColorLighter}" ~ backgroundColorLighter
    , "${fontColor}" ~ fontColor
    , "${fontColor}" ~ fontColor
    , "${fontColor}" ~ fontColor
    , "${fontName}" ~ fontName
    , "${tileColor}" ~ tileColor
    , "${canvasSize}" ~ (show canvasSize)
    , "${canvasSize}" ~ (show canvasSize)
    , "${canvasSize}" ~ (show canvasSize)
    , "${canvasSize}" ~ (show canvasSize)
    , "${canvasSize}" ~ (show canvasSize)
    ] $ rawStyles <> playerColorStyles

rawStyles = """
  .clearfix:after {
	visibility: hidden;
	display: block;
	font-size: 0;
	content: " ";
	clear: both;
	height: 0;
  }

  body {
    background-color: ${backgroundColor};
    color: ${fontColor};
    font: normal 100% ${fontName}, sans-serif;
    margin: 0;
  }

  h1 {
    padding-top: 1em;
    text-align: center;
  }

  div, p {
    word-wrap: break-word;
  }

  a, a:visited {
    color: ${tileColor};
  }

  input {
    border: 5px solid ${fontColor};
    -webkit-box-shadow:
      inset 0 0 8px  rgba(0,0,0,0.1),
            0 0 16px rgba(0,0,0,0.1);
    -moz-box-shadow:
      inset 0 0 8px  rgba(0,0,0,0.1),
            0 0 16px rgba(0,0,0,0.1);
     box-shadow:
      inset 0 0 8px  rgba(0,0,0,0.1),
            0 0 16px rgba(0,0,0,0.1);
    padding: 10px;
    background: rgba(255,255,255,0.3);
    margin: 0 0 10px 0;
    font-size: 150%;
    color: ${fontColor};
    width: 300px;
  }

  #game {
    margin: 0 auto;
    width: ${canvasSize}px;
  }

  #background {
    position: absolute;
    z-index: 0;
  }

  #foreground {
    position: absolute;
    z-index: 1;
  }

  #scores-container {
    position: absolute;
    z-index: 2;
    width: ${canvasSize}px;
  }

  #waiting-message {
    position: absolute;
    z-index: 3;
    width: ${canvasSize}px;
  }

  #prompt {
    z-index: 3;
    margin: 0 auto;
    text-align: center;
    width: ${canvasSize}px;
    font-size: 145%;
  }

  #waiting-message p {
    text-align: center;
    font-size: 140%;
    margin-left: 0 auto;
    margin-right: 0 auto;
  }

  #error {
    position: fixed;
    top: 25%;
    left: 50%;
    transform: translate(-50%, -50%);
    z-index: 101;

    width: ${canvasSize}px;
    background-color: ${backgroundColor};
    display: none;

    border: 1px solid;
    border-radius: 10px;
  }

  #error-overlay {
    position: fixed;
    width: 100%;
    height: 100%;
    display: none;
    z-index: 100;
    background-color: rgba(0,0,0, 0.5);
  }

  #error h2 {
    text-align: center;
  }

  #error p {
    padding: 0 4em 0 4em;
  }

  .scores {
    margin-bottom: 5em;
  }

  .scores-header {
    font-size: 200%;
    text-align: center;
  }

  .scores-row {
    height: 2em;
    padding: 0.5em 1em 0.5em 1em;
    margin: 0 auto;
    width: 80%;
  }

  .simple-scores {
    width: 80%;
    margin-left: 10px;
  }

  .simple-scores .player-P1,
  .simple-scores .player-P2,
  .simple-scores .player-P3,
  .simple-scores .player-P4 {
    text-align: right;
  }

  .is-you {
    background-color: ${backgroundColorLighter};
  }

  .scores-cell {
    font-size: 150%;
    float: left;
  }

  .cell-wide {
    width: 60%;
  }

  .cell-thin {
    width: 20%;
  }

  .cell-thinnest {
    width: 11%;
  }

  .score {
    text-align: center;
  }

  .ready-state {
    width: 25%;
    float: left;
  }
"""

playerColorStyles =
  concat $
    flip map allPlayerIds
      (\pId ->
        concat [".player-"
               , show pId
               , " { color: "
               , playerColor pId
               , ";}\n"
               ])
  where
  concat = joinWith ""

indexDoc =
  html ! lang "en" $ do
    head $ do
      meta ! charset "utf-8"
      meta ! httpEquiv "X-UA-Compatible" ! content "IE=edge,chrome=1"
      script ! src "/js/game.js" ! defer "" $ text ""
      link ! rel "stylesheet" ! type' "text/css" ! href fontUrl
      style ! type' "text/css" $ text styles

    body $ do
      div ! id "error-overlay" $ text ""
      div ! id "game" $ do
        h1 $ text "multipac"

        div ! id "prompt" $ do
          p ! id "prompt-message" $ text ""
          input ! id "prompt-input" ! type' "text"

        div ! id "waiting-message" $ text ""

        canvas ! id "foreground" $ text ""
        canvas ! id "background" $ text ""

        div ! id "error" $ do
          h2 $ text "disconnected"
          p $ do
            text "Something went wrong and the server couldn't be contacted. "
            text "Please "
            a ! href "" $ text "refresh the page"
            text " to reconnect."

        div ! id "scores-container" $ text ""

indexHtml = render indexDoc

type PlayerReadyInfo
  = { ready :: Boolean
    , name  :: String
    }

waitingMessage ::
  ClientStateWaiting -> PlayerId -> M.Map PlayerId String -> String
waitingMessage sw pId ps = render $ waitingMessageDoc sw pId ps

waitingMessageDoc ::
  ClientStateWaiting -> PlayerId -> M.Map PlayerId String -> Markup
waitingMessageDoc sw pId playersMap = do
  whenJust sw.prevGame (scoresTable pId playersMap)

  let r = fromMaybe false $ M.lookup pId sw.readyStates
  p $ text $ if r
               then "Waiting for other players..."
               else "Press SPACE when you're ready"

  div ! className "clearfix" $
    for_ allPlayerIds $ \pId' -> do
      let mInfo = getPlayerInfo pId'
      let cl = "ready-state" <>
                    (if pId' == pId then " is-you" else "") <>
                    (if isJust mInfo then "" else " not-connected")

      div ! className cl $ do
        let cl' = "player-" <> show pId'
        p ! className cl' $ text (show pId')
        whenJust mInfo $ \info -> do
          p $ text info.name
          p $ text $ if info.ready then "ready!" else "not ready"
  where
  getPlayerInfo pId'' = do
    ready <- M.lookup pId'' sw.readyStates
    name <- M.lookup pId'' playersMap
    return $ { ready: ready, name: name }

type PlayerScoreInfo
  = { score :: Number
    , name  :: String
    , pId   :: PlayerId
    }

scoresTable :: PlayerId -> M.Map PlayerId String -> Game -> Markup
scoresTable pId playersMap game =
  div ! className "scores clearfix" $ do
    h2 ! className "scores-header" $ text "scores"
    div ! className "scores-table" $ do
      for_ (sortedPlayerInfos game) $ \info -> do
        let cl = "scores-row" <> (if info.pId == pId then " is-you" else "")
        div ! className cl $ do
          scoresCellDiv ["cell-thin", "player-" <> show info.pId] (show info.pId)
          scoresCellDiv ["cell-wide"] info.name
          scoresCellDiv ["cell-thin", "score"] (show info.score)
  where
  sortedPlayerInfos game =
    reverse $ sortBy (compare `on` score) (playerInfos game playersMap)

  score i = i.score

  scoresCellDiv classes innerText =
    div ! className (joinWith " " $ ["scores-cell"] <> classes) $
      text innerText

playerInfos game playersMap =
  catMaybes $ map (getPlayerInfo playersMap) allPlayers
  where
  allPlayers = M.toList (game ^. players)

getPlayerInfo ::
  M.Map PlayerId String -> Tuple PlayerId Player -> Maybe PlayerScoreInfo
getPlayerInfo playersMap (Tuple pId'' p) = do
  name <- M.lookup pId'' playersMap
  return $ { score: p ^. pScore, name: name, pId: pId'' }

simpleScores :: M.Map PlayerId String -> Game -> String
simpleScores m game =
  render $ simpleScoresMarkup m game

simpleScoresMarkup :: M.Map PlayerId String -> Game -> Markup
simpleScoresMarkup playersMap game = do
  div ! className "simple-scores" $ do
    for_ (playerInfos game playersMap) $ \info -> do
      scoresCellDiv ["cell-thinnest", "player-" <> show info.pId] (show info.pId)
      scoresCellDiv ["cell-thinnest", "score"] (show info.score)

  where
  scoresCellDiv classes innerText =
    div ! className (joinWith " " $ ["scores-cell"] <> classes) $
      text innerText

module HtmlViews where

import Data.Foldable (foldr, for_)
import Prelude hiding (id)
import Control.Lens ((~), (^.))
import Control.Monad (when)
import Data.Tuple
import Data.Maybe
import Data.String (replace, joinWith)
import Data.Array (sortBy, reverse, map, catMaybes)
import Data.Function (on)
import qualified Data.Map as M
import Text.Smolder.HTML
  (html, head, meta, script, style, body, div, h1, h2, canvas, title, link, p,
   input, a)
import Text.Smolder.HTML.Attributes
  (lang, charset, httpEquiv, content, src, defer, type', id, className, name,
  rel, href)
import Text.Smolder.Markup (text, (!), Markup())
import Text.Smolder.Renderer.String (render)

import Utils
import Types
import Style

replaceAll :: [Tuple String String] -> String -> String
replaceAll = fmap (uncurry replace) >>> foldr (>>>) Prelude.id

styles =
  replaceAll
    [ "${backgroundColor}" ~ backgroundColor
    , "${backgroundColor}" ~ backgroundColor
    , "${backgroundColorLighter}" ~ backgroundColorLighter
    , "${fontColor}" ~ fontColor
    , "${fontColor}" ~ fontColor
    , "${fontColor}" ~ fontColor
    , "${fontName}" ~ fontName
    , "${tileColor}" ~ tileColor
    , "${canvasSize}" ~ (show canvasSize)
    , "${canvasSize}" ~ (show canvasSize)
    , "${canvasSize}" ~ (show canvasSize)
    , "${canvasSize}" ~ (show canvasSize)
    , "${canvasSize}" ~ (show canvasSize)
    ] $ rawStyles <> playerColorStyles

rawStyles = """
  .clearfix:after {
	visibility: hidden;
	display: block;
	font-size: 0;
	content: " ";
	clear: both;
	height: 0;
  }

  body {
    background-color: ${backgroundColor};
    color: ${fontColor};
    font: normal 100% ${fontName}, sans-serif;
    margin: 0;
  }

  h1 {
    padding-top: 1em;
    text-align: center;
  }

  div, p {
    word-wrap: break-word;
  }

  a, a:visited {
    color: ${tileColor};
  }

  input {
    border: 5px solid ${fontColor};
    -webkit-box-shadow:
      inset 0 0 8px  rgba(0,0,0,0.1),
            0 0 16px rgba(0,0,0,0.1);
    -moz-box-shadow:
      inset 0 0 8px  rgba(0,0,0,0.1),
            0 0 16px rgba(0,0,0,0.1);
     box-shadow:
      inset 0 0 8px  rgba(0,0,0,0.1),
            0 0 16px rgba(0,0,0,0.1);
    padding: 10px;
    background: rgba(255,255,255,0.3);
    margin: 0 0 10px 0;
    font-size: 150%;
    color: ${fontColor};
    width: 300px;
  }

  #game {
    margin: 0 auto;
    width: ${canvasSize}px;
  }

  #background {
    position: absolute;
    z-index: 0;
  }

  #foreground {
    position: absolute;
    z-index: 1;
  }

  #scores-container {
    position: absolute;
    z-index: 2;
    width: ${canvasSize}px;
  }

  #waiting-message {
    position: absolute;
    z-index: 3;
    width: ${canvasSize}px;
  }

  #prompt {
    z-index: 3;
    margin: 0 auto;
    text-align: center;
    width: ${canvasSize}px;
    font-size: 145%;
  }

  #waiting-message p {
    text-align: center;
    font-size: 140%;
    margin-left: 0 auto;
    margin-right: 0 auto;
  }

  #error {
    position: fixed;
    top: 25%;
    left: 50%;
    transform: translate(-50%, -50%);
    z-index: 101;

    width: ${canvasSize}px;
    background-color: ${backgroundColor};
    display: none;

    border: 1px solid;
    border-radius: 10px;
  }

  #error-overlay {
    position: fixed;
    width: 100%;
    height: 100%;
    display: none;
    z-index: 100;
    background-color: rgba(0,0,0, 0.5);
  }

  #error h2 {
    text-align: center;
  }

  #error p {
    padding: 0 4em 0 4em;
  }

  .scores {
    margin-bottom: 5em;
  }

  .scores-header {
    font-size: 200%;
    text-align: center;
  }

  .scores-row {
    height: 2em;
    padding: 0.5em 1em 0.5em 1em;
    margin: 0 auto;
    width: 80%;
  }

  .simple-scores {
    width: 80%;
    margin-left: 10px;
  }

  .simple-scores .player-P1,
  .simple-scores .player-P2,
  .simple-scores .player-P3,
  .simple-scores .player-P4 {
    text-align: right;
  }

  .is-you {
    background-color: ${backgroundColorLighter};
  }

  .scores-cell {
    font-size: 150%;
    float: left;
  }

  .cell-wide {
    width: 60%;
  }

  .cell-thin {
    width: 20%;
  }

  .cell-thinnest {
    width: 11%;
  }

  .score {
    text-align: center;
  }

  .ready-state {
    width: 25%;
    float: left;
  }
"""

playerColorStyles =
  concat $
    flip map allPlayerIds
      (\pId ->
        concat [".player-"
               , show pId
               , " { color: "
               , playerColor pId
               , ";}\n"
               ])
  where
  concat = joinWith ""

indexDoc =
  html ! lang "en" $ do
    head $ do
      meta ! charset "utf-8"
      meta ! httpEquiv "X-UA-Compatible" ! content "IE=edge,chrome=1"
      script ! src "/js/game.js" ! defer "" $ text ""
      link ! rel "stylesheet" ! type' "text/css" ! href fontUrl
      style ! type' "text/css" $ text styles

    body $ do
      div ! id "error-overlay" $ text ""
      div ! id "game" $ do
        h1 $ text "multipac"

        div ! id "prompt" $ do
          p ! id "prompt-message" $ text ""
          input ! id "prompt-input" ! type' "text"

        div ! id "waiting-message" $ text ""

        canvas ! id "foreground" $ text ""
        canvas ! id "background" $ text ""

        div ! id "error" $ do
          h2 $ text "disconnected"
          p $ do
            text "something went wrong and I couldn't contact the server. "
            text "Please "
            a ! href "" $ text "refresh the page"
            text " to reconnect."

        div ! id "scores-container" $ text ""

indexHtml = render indexDoc

type PlayerReadyInfo
  = { ready :: Boolean
    , name  :: String
    }

waitingMessage ::
  ClientStateWaiting -> PlayerId -> M.Map PlayerId String -> String
waitingMessage sw pId ps = render $ waitingMessageDoc sw pId ps

waitingMessageDoc ::
  ClientStateWaiting -> PlayerId -> M.Map PlayerId String -> Markup
waitingMessageDoc sw pId playersMap = do
  whenJust sw.prevGame (scoresTable pId playersMap)

  let r = fromMaybe false $ M.lookup pId sw.readyStates
  p $ text $ if r
               then "Waiting for other players..."
               else "Press SPACE when you're ready"

  div ! className "clearfix" $
    for_ allPlayerIds $ \pId' -> do
      let mInfo = getPlayerInfo pId'
      let cl = "ready-state" <>
                    (if pId' == pId then " is-you" else "") <>
                    (if isJust mInfo then "" else " not-connected")

      div ! className cl $ do
        let cl' = "player-" <> show pId'
        p ! className cl' $ text (show pId')
        whenJust mInfo $ \info -> do
          p $ text info.name
          p $ text $ if info.ready then "ready!" else "not ready"
  where
  getPlayerInfo pId'' = do
    ready <- M.lookup pId'' sw.readyStates
    name <- M.lookup pId'' playersMap
    return $ { ready: ready, name: name }

type PlayerScoreInfo
  = { score :: Number
    , name  :: String
    , pId   :: PlayerId
    }

scoresTable :: PlayerId -> M.Map PlayerId String -> Game -> Markup
scoresTable pId playersMap game =
  div ! className "scores clearfix" $ do
    h2 ! className "scores-header" $ text "scores"
    div ! className "scores-table" $ do
      for_ (sortedPlayerInfos game) $ \info -> do
        let cl = "scores-row" <> (if info.pId == pId then " is-you" else "")
        div ! className cl $ do
          scoresCellDiv ["cell-thin", "player-" <> show info.pId] (show info.pId)
          scoresCellDiv ["cell-wide"] info.name
          scoresCellDiv ["cell-thin", "score"] (show info.score)
  where
  sortedPlayerInfos game =
    reverse $ sortBy (compare `on` score) (playerInfos game playersMap)

  score i = i.score

  scoresCellDiv classes innerText =
    div ! className (joinWith " " $ ["scores-cell"] <> classes) $
      text innerText

playerInfos game playersMap =
  catMaybes $ map (getPlayerInfo playersMap) allPlayers
  where
  allPlayers = M.toList (game ^. players)

getPlayerInfo ::
  M.Map PlayerId String -> Tuple PlayerId Player -> Maybe PlayerScoreInfo
getPlayerInfo playersMap (Tuple pId'' p) = do
  name <- M.lookup pId'' playersMap
  return $ { score: p ^. pScore, name: name, pId: pId'' }

simpleScores :: M.Map PlayerId String -> Game -> String
simpleScores m game =
  render $ simpleScoresMarkup m game

simpleScoresMarkup :: M.Map PlayerId String -> Game -> Markup
simpleScoresMarkup playersMap game = do
  div ! className "simple-scores" $ do
    for_ (playerInfos game playersMap) $ \info -> do
      scoresCellDiv ["cell-thinnest", "player-" <> show info.pId] (show info.pId)
      scoresCellDiv ["cell-thinnest", "score"] (show info.score)

  where
  scoresCellDiv classes innerText =
    div ! className (joinWith " " $ ["scores-cell"] <> classes) $
      text innerText


Rename

Rename

Original commit 626dfcc9cb4e8fc4f0a3206ca9150aa2ad40ceaa

module Language.Pseudocode
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory)

import Data.Foldable (for_, intercalate, maximum)

import Data.List as L
import Data.Map as M
import Data.Map (Map)
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.Set (Set)
import Data.String as Str
import Data.String.Util as Str
import Data.Tuple (Tuple(..), fst)

import Utils (mapM)

renderer :: Renderer
renderer =
    { name: "Simple Types"
    , aceMode: "groovy"
    , extension: "types"
    , doc: pseudocodeDoc
    , transforms:
        { nameForClass: noForbidNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        , topLevelName: simpleNamer id
        , unions: Nothing
        }
    }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = upperNameStyle $ combineNames names

isComplex :: IRType -> Boolean
isComplex = case _ of
    IRArray a -> isComplex a
    IRMap _ -> true
    IRUnion _ -> true
    _ -> false

isStartCharacter :: Char -> Boolean
isStartCharacter c = Str.isLetterOrLetterNumber c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isStartCharacter c

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "Any" -- we can have arrays of nothing
    IRNull -> pure "Null"
    IRInteger -> pure "Double"
    IRDouble -> pure "Double"
    IRBool -> pure "Boolean"
    IRString -> pure "String"
    IRClass i -> lookupClassName i

    IRArray a | isComplex a -> do
        rendered <- renderType a
        pure $ "Array<" <> rendered <> ">"

    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"

    IRMap t -> do
        rendered <- renderType t
        pure $ "Map<String, " <> rendered <> ">"

    IRUnion types -> do
        let typeSet = unionToSet types
        case nullableFromSet typeSet of
            Nothing -> renderUnion typeSet
            Just t -> do
                rendered <- renderType t
                pure $ "Maybe<" <> rendered <> ">"

classNameStyle :: Boolean -> String -> String
classNameStyle upper = Str.legalizeCharacters isPartCharacter >>> Str.camelCase >>> (Str.startWithLetter isStartCharacter upper)

upperNameStyle :: String -> String
upperNameStyle = classNameStyle true

pseudocodeDoc :: Doc Unit
pseudocodeDoc = forEachClass_ \className properties -> do
    line $ "class " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let maxWidth = props <#> fst <#> Str.length # maximum
        for_ props \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered
    line "}"
    blank

module Language.Pseudocode
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory)

import Data.Foldable (for_, intercalate, maximum)

import Data.List as L
import Data.Map as M
import Data.Map (Map)
import Data.Maybe (Maybe(Nothing, Just), maybe)
import Data.Set (Set)
import Data.String as Str
import Data.String.Util as Str
import Data.Tuple (Tuple(..), fst)

import Utils (mapM)

renderer :: Renderer
renderer =
    { name: "Pseudocode"
    , aceMode: "groovy"
    , extension: "pseudo"
    , doc: pseudocodeDoc
    , transforms:
        { nameForClass: noForbidNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        , topLevelName: simpleNamer id
        , unions: Nothing
        }
    }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = upperNameStyle $ combineNames names

isComplex :: IRType -> Boolean
isComplex = case _ of
    IRArray a -> isComplex a
    IRMap _ -> true
    IRUnion _ -> true
    _ -> false

isStartCharacter :: Char -> Boolean
isStartCharacter c = Str.isLetterOrLetterNumber c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isStartCharacter c

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> renderType x
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "Any" -- we can have arrays of nothing
    IRNull -> pure "Null"
    IRInteger -> pure "Double"
    IRDouble -> pure "Double"
    IRBool -> pure "Boolean"
    IRString -> pure "String"
    IRClass i -> lookupClassName i

    IRArray a | isComplex a -> do
        rendered <- renderType a
        pure $ "Array<" <> rendered <> ">"

    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"

    IRMap t -> do
        rendered <- renderType t
        pure $ "Map<String, " <> rendered <> ">"

    IRUnion types -> do
        let typeSet = unionToSet types
        case nullableFromSet typeSet of
            Nothing -> renderUnion typeSet
            Just t -> do
                rendered <- renderType t
                pure $ "Maybe<" <> rendered <> ">"

classNameStyle :: Boolean -> String -> String
classNameStyle upper = Str.legalizeCharacters isPartCharacter >>> Str.camelCase >>> (Str.startWithLetter isStartCharacter upper)

upperNameStyle :: String -> String
upperNameStyle = classNameStyle true

pseudocodeDoc :: Doc Unit
pseudocodeDoc = forEachClass_ \className properties -> do
    line $ "class " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let maxWidth = props <#> fst <#> Str.length # maximum
        for_ props \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered
    line "}"
    blank