Fix Foldable1 Lazy instance (#30)

Fix Foldable1 Lazy instance (#30)

module Data.Lazy where

import Prelude

import Control.Comonad (class Comonad)
import Control.Extend (class Extend)
import Control.Lazy as CL
import Data.Eq (class Eq1)
import Data.Foldable (class Foldable, foldMap, foldl, foldr)
import Data.FoldableWithIndex (class FoldableWithIndex)
import Data.Functor.Invariant (class Invariant, imapF)
import Data.FunctorWithIndex (class FunctorWithIndex)
import Data.HeytingAlgebra (implies, ff, tt)
import Data.Ord (class Ord1)
import Data.Semigroup.Foldable (class Foldable1, fold1Default)
import Data.Semigroup.Traversable (class Traversable1)
import Data.Traversable (class Traversable, traverse)
import Data.TraversableWithIndex (class TraversableWithIndex)

-- | `Lazy a` represents lazily-computed values of type `a`.
-- |
-- | A lazy value is computed at most once - the result is saved
-- | after the first computation, and subsequent attempts to read
-- | the value simply return the saved value.
-- |
-- | `Lazy` values can be created with `defer`, or by using the provided
-- | type class instances.
-- |
-- | `Lazy` values can be evaluated by using the `force` function.
foreign import data Lazy :: Type -> Type

type role Lazy representational

-- | Defer a computation, creating a `Lazy` value.
foreign import defer :: forall a. (Unit -> a) -> Lazy a

-- | Force evaluation of a `Lazy` value.
foreign import force :: forall a. Lazy a -> a

instance semiringLazy :: Semiring a => Semiring (Lazy a) where
  add a b = defer \_ -> force a + force b
  zero = defer \_ -> zero
  mul a b = defer \_ -> force a * force b
  one = defer \_ -> one

instance ringLazy :: Ring a => Ring (Lazy a) where
  sub a b = defer \_ -> force a - force b

instance commutativeRingLazy :: CommutativeRing a => CommutativeRing (Lazy a)

instance euclideanRingLazy :: EuclideanRing a => EuclideanRing (Lazy a) where
  degree = degree <<< force
  div a b = defer \_ -> force a / force b
  mod a b = defer \_ -> force a `mod` force b

instance eqLazy :: Eq a => Eq (Lazy a) where
  eq x y = (force x) == (force y)

derive instance eq1Lazy :: Eq1 Lazy

instance ordLazy :: Ord a => Ord (Lazy a) where
  compare x y = compare (force x) (force y)

derive instance ord1Lazy :: Ord1 Lazy

instance boundedLazy :: Bounded a => Bounded (Lazy a) where
  top = defer \_ -> top
  bottom = defer \_ -> bottom

instance semigroupLazy :: Semigroup a => Semigroup (Lazy a) where
  append a b = defer \_ -> force a <> force b

instance monoidLazy :: Monoid a => Monoid (Lazy a) where
  mempty = defer \_ -> mempty

instance heytingAlgebraLazy :: HeytingAlgebra a => HeytingAlgebra (Lazy a) where
  ff = defer \_ -> ff
  tt = defer \_ -> tt
  implies a b = implies <$> a <*> b
  conj a b = conj <$> a <*> b
  disj a b = disj <$> a <*> b
  not a = not <$> a

instance booleanAlgebraLazy :: BooleanAlgebra a => BooleanAlgebra (Lazy a)

instance functorLazy :: Functor Lazy where
  map f l = defer \_ -> f (force l)

instance functorWithIndexLazy :: FunctorWithIndex Unit Lazy where
  mapWithIndex f = map $ f unit

instance foldableLazy :: Foldable Lazy where
  foldr f z l = f (force l) z
  foldl f z l = f z (force l)
  foldMap f l = f (force l)

instance foldableWithIndexLazy :: FoldableWithIndex Unit Lazy where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldable1Lazy :: Foldable1 Lazy where
  foldMap1 f l = f (force l)
  fold1 = fold1Default
  foldr1 _ l = force l
  foldl1 _ l = force l

instance traversableLazy :: Traversable Lazy where
  traverse f l = defer <<< const <$> f (force l)
  sequence l = defer <<< const <$> force l

instance traversableWithIndexLazy :: TraversableWithIndex Unit Lazy where
  traverseWithIndex f = traverse $ f unit

instance traversable1Lazy :: Traversable1 Lazy where
  traverse1 f l = defer <<< const <$> f (force l)
  sequence1 l = defer <<< const <$> force l

instance invariantLazy :: Invariant Lazy where
  imap = imapF

instance applyLazy :: Apply Lazy where
  apply f x = defer \_ -> force f (force x)

instance applicativeLazy :: Applicative Lazy where
  pure a = defer \_ -> a

instance bindLazy :: Bind Lazy where
  bind l f = defer \_ -> force $ f (force l)

instance monadLazy :: Monad Lazy

instance extendLazy :: Extend Lazy where
  extend f x = defer \_ -> f x

instance comonadLazy :: Comonad Lazy where
  extract = force

instance showLazy :: Show a => Show (Lazy a) where
  show x = "(defer \\_ -> " <> show (force x) <> ")"

instance lazyLazy :: CL.Lazy (Lazy a) where
  defer f = defer \_ -> force (f unit)

module Data.Lazy where

import Prelude

import Control.Comonad (class Comonad)
import Control.Extend (class Extend)
import Control.Lazy as CL
import Data.Eq (class Eq1)
import Data.Foldable (class Foldable, foldMap, foldl, foldr)
import Data.FoldableWithIndex (class FoldableWithIndex)
import Data.Functor.Invariant (class Invariant, imapF)
import Data.FunctorWithIndex (class FunctorWithIndex)
import Data.HeytingAlgebra (implies, ff, tt)
import Data.Ord (class Ord1)
import Data.Semigroup.Foldable (class Foldable1, fold1Default)
import Data.Semigroup.Traversable (class Traversable1)
import Data.Traversable (class Traversable, traverse)
import Data.TraversableWithIndex (class TraversableWithIndex)

-- | `Lazy a` represents lazily-computed values of type `a`.
-- |
-- | A lazy value is computed at most once - the result is saved
-- | after the first computation, and subsequent attempts to read
-- | the value simply return the saved value.
-- |
-- | `Lazy` values can be created with `defer`, or by using the provided
-- | type class instances.
-- |
-- | `Lazy` values can be evaluated by using the `force` function.
foreign import data Lazy :: Type -> Type

type role Lazy representational

-- | Defer a computation, creating a `Lazy` value.
foreign import defer :: forall a. (Unit -> a) -> Lazy a

-- | Force evaluation of a `Lazy` value.
foreign import force :: forall a. Lazy a -> a

instance semiringLazy :: Semiring a => Semiring (Lazy a) where
  add a b = defer \_ -> force a + force b
  zero = defer \_ -> zero
  mul a b = defer \_ -> force a * force b
  one = defer \_ -> one

instance ringLazy :: Ring a => Ring (Lazy a) where
  sub a b = defer \_ -> force a - force b

instance commutativeRingLazy :: CommutativeRing a => CommutativeRing (Lazy a)

instance euclideanRingLazy :: EuclideanRing a => EuclideanRing (Lazy a) where
  degree = degree <<< force
  div a b = defer \_ -> force a / force b
  mod a b = defer \_ -> force a `mod` force b

instance eqLazy :: Eq a => Eq (Lazy a) where
  eq x y = (force x) == (force y)

derive instance eq1Lazy :: Eq1 Lazy

instance ordLazy :: Ord a => Ord (Lazy a) where
  compare x y = compare (force x) (force y)

derive instance ord1Lazy :: Ord1 Lazy

instance boundedLazy :: Bounded a => Bounded (Lazy a) where
  top = defer \_ -> top
  bottom = defer \_ -> bottom

instance semigroupLazy :: Semigroup a => Semigroup (Lazy a) where
  append a b = defer \_ -> force a <> force b

instance monoidLazy :: Monoid a => Monoid (Lazy a) where
  mempty = defer \_ -> mempty

instance heytingAlgebraLazy :: HeytingAlgebra a => HeytingAlgebra (Lazy a) where
  ff = defer \_ -> ff
  tt = defer \_ -> tt
  implies a b = implies <$> a <*> b
  conj a b = conj <$> a <*> b
  disj a b = disj <$> a <*> b
  not a = not <$> a

instance booleanAlgebraLazy :: BooleanAlgebra a => BooleanAlgebra (Lazy a)

instance functorLazy :: Functor Lazy where
  map f l = defer \_ -> f (force l)

instance functorWithIndexLazy :: FunctorWithIndex Unit Lazy where
  mapWithIndex f = map $ f unit

instance foldableLazy :: Foldable Lazy where
  foldr f z l = f (force l) z
  foldl f z l = f z (force l)
  foldMap f l = f (force l)

instance foldableWithIndexLazy :: FoldableWithIndex Unit Lazy where
  foldrWithIndex f = foldr $ f unit
  foldlWithIndex f = foldl $ f unit
  foldMapWithIndex f = foldMap $ f unit

instance foldable1Lazy :: Foldable1 Lazy where
  foldMap1 f l = f (force l)
  fold1 = fold1Default

instance traversableLazy :: Traversable Lazy where
  traverse f l = defer <<< const <$> f (force l)
  sequence l = defer <<< const <$> force l

instance traversableWithIndexLazy :: TraversableWithIndex Unit Lazy where
  traverseWithIndex f = traverse $ f unit

instance traversable1Lazy :: Traversable1 Lazy where
  traverse1 f l = defer <<< const <$> f (force l)
  sequence1 l = defer <<< const <$> force l

instance invariantLazy :: Invariant Lazy where
  imap = imapF

instance applyLazy :: Apply Lazy where
  apply f x = defer \_ -> force f (force x)

instance applicativeLazy :: Applicative Lazy where
  pure a = defer \_ -> a

instance bindLazy :: Bind Lazy where
  bind l f = defer \_ -> force $ f (force l)

instance monadLazy :: Monad Lazy

instance extendLazy :: Extend Lazy where
  extend f x = defer \_ -> f x

instance comonadLazy :: Comonad Lazy where
  extract = force

instance showLazy :: Show a => Show (Lazy a) where
  show x = "(defer \\_ -> " <> show (force x) <> ")"

instance lazyLazy :: CL.Lazy (Lazy a) where
  defer f = defer \_ -> force (f unit)


Refer to `void` as a keyword and fix comma mistake

module Data.Void (Void, absurd) where

import Data.Show (class Show)

-- | An uninhabited data type. In other words, one can never create
-- | a runtime value of type `Void` becaue no such value exists.
-- |
-- | `Void` is useful to eliminate the possibility of a value being created.
-- | For example, a value of type `Either Void Boolean` can never have
-- | a Left value created in PureScript.
-- |
-- | This should not be confused with the keyword `void` that commonly appears in
-- | C-family languages, such as Java:
-- | ```
-- | public class Foo {
-- |   void doSomething() { System.out.println("hello world!"); }
-- | }
-- | ```
-- |
-- | In PureScript, one often uses `Unit` to achieve similar effects as
-- | the lowercased `void` above.
newtype Void = Void Void

instance showVoid :: Show Void where
  show = absurd

-- | Eliminator for the `Void` type.
-- | Useful for stating that some code branch is impossible because you've
-- | "acquired" a value of type `Void` (which you can't).
-- |
-- | ```purescript
-- | rightOnly :: forall t . Either Void t -> t
-- | rightOnly (Left v) = absurd v
-- | rightOnly (Right t) = t
-- | ```
absurd :: forall a. Void -> a
absurd a = spin a
  where
  spin (Void b) = spin b

module Data.Void (Void, absurd) where

import Data.Show (class Show)

-- | An uninhabited data type. In other words, one can never create
-- | a runtime value of type `Void` becaue no such value exists.
-- |
-- | `Void` is useful to eliminate the possibility of a value being created.
-- | For example, a value of type `Either Void Boolean` can never have
-- | a Left value created in PureScript.
-- |
-- | This should not be confused with the word, `void,` that commonly appears in
-- | C-family languages, such as Java:
-- | ```
-- | public class Foo {
-- |   void doSomething() { System.out.println("hello world!"); }
-- | }
-- | ```
-- |
-- | In PureScript, one often uses `Unit` to achieve similar effects as
-- | the lowercased `void` above.
newtype Void = Void Void

instance showVoid :: Show Void where
  show = absurd

-- | Eliminator for the `Void` type.
-- | Useful for stating that some code branch is impossible because you've
-- | "acquired" a value of type `Void` (which you can't).
-- |
-- | ```purescript
-- | rightOnly :: forall t . Either Void t -> t
-- | rightOnly (Left v) = absurd v
-- | rightOnly (Right t) = t
-- | ```
absurd :: forall a. Void -> a
absurd a = spin a
  where
  spin (Void b) = spin b


Updates for canvas library updates

Updates for canvas library updates

module Rendering where

import CanvasM
import Data.Array hiding ((..))
import Data.Foldable
import Data.Function
import Data.Maybe
import Data.Tuple
import Effect
import Game
import LevelMap
import Prelude
import Style
import Types
import Utils

import Control.Monad (when)
import Data.Int as Int
import Data.Lens.At (at)
import Data.Lens.Getter ((^.))
import Data.Lens.Prism.Maybe (_Just)
import Data.Map as M
import Data.Profunctor.Strong ((***))
import Data.Tuple.Nested ((/\))
import Effect.Exception (throw)
import Graphics.Canvas (Arc, Context2D, LineCap(..), TextAlign(..), Rectangle, getCanvasElementById, getContext2D, setCanvasHeight, setCanvasWidth)
import Math (pi, floor, ceil)

halfBlock     = floor (pxPerBlock / 2.0)
halfPxPerTile = floor (pxPerTile / 2.0)
halfCanvas    = floor (canvasSize / 2.0)

scaleRect :: Number -> Position -> Rectangle
scaleRect scale (Position p) =
  {x: p.x * scale, y: p.y * scale, height: scale, width: scale}

toPosition :: Rectangle -> Position
toPosition r = Position {x:r.x, y:r.y}

getRectAt :: Position -> Rectangle
getRectAt = scaleRect pxPerBlock

getCentredRectAt :: Position -> Rectangle
getCentredRectAt p =
  let r = getRectAt p
  in  r {x = r.x + halfBlock, y = r.y + halfBlock}

getRectAt' :: Number -> Number -> Rectangle
getRectAt' x y = getRectAt (Position {x: x, y: y})

getTileRectAt :: Position -> Rectangle
getTileRectAt = scaleRect pxPerTile

getTileRectAt' :: Number -> Number -> Rectangle
getTileRectAt' x y = getTileRectAt (Position {x: x, y: y})

setupRendering :: Effect RenderingContext
setupRendering = do
  fg <- setupRenderingById "foreground"
  bg <- setupRenderingById "background"
  pure { foreground: fg, background: bg }

-- set up a canvas with the correct dimensions and return its context
setupRenderingById :: String -> Effect Context2D
setupRenderingById elId = do
  el <- getCanvasElementById elId >>= justOrErr
  setCanvasHeight el canvasSize
  setCanvasWidth el canvasSize
  getContext2D el

  where
  justOrErr :: forall a. Maybe a -> Effect a
  justOrErr (Just x) = pure x
  justOrErr Nothing = throw $ "no canvas element found with id = " <> elId

clearBackground :: forall e. CanvasM e Unit
clearBackground = do
  setFillStyle backgroundColor
  fillRect wholeCanvas

data CornerType
  = CRO -- rounded outer
  | CRI -- rounded inner
  | CSH -- straight horizontal
  | CSV -- straight vertical
  | NON -- nothing (inside a block)

instance showCornerType :: Show CornerType where
  show CRO = "CRO"
  show CRI = "CRI"
  show CSH = "CSH"
  show CSV = "CSV"
  show NON = "NON"

type Corners =
  { tl :: CornerType, tr :: CornerType, bl :: CornerType, br :: CornerType }

toBasic :: Tile -> BasicTile
toBasic Inaccessible = W
toBasic _ = E

renderMap :: forall e. LevelMap -> CanvasM e Unit
renderMap map = do
  setStrokeStyle tileColor

  let tileIndices = range 0 (tilesAlongSide - 1)
  let getTile i j = map.tiles !! i >>= (\r -> r !! j)
  let t i j = toBasic <$> getTile i j

  for_ tileIndices $ \i ->
    for_ tileIndices $ \j -> do
      let above      = fromMaybe W $ t i (j-1)
      let aboveRight = fromMaybe W $ t (i+1) (j-1)
      let right      = fromMaybe W $ t (i+1) j
      let belowRight = fromMaybe W $ t (i+1) (j+1)
      let below      = fromMaybe W $ t i (j+1)
      let belowLeft  = fromMaybe W $ t (i-1) (j+1)
      let left       = fromMaybe W $ t (i-1) j
      let aboveLeft  = fromMaybe W $ t (i-1) (j-1)

      case t i j of
        Just W -> do
          let cs = getCorners above aboveRight right belowRight
                              below belowLeft left aboveLeft
          let es = getEdges above right below left
          withContext $ do
            translate { translateX: (Int.toNumber i + 0.5) * pxPerTile
                      , translateY: (Int.toNumber j + 0.5) * pxPerTile
                      }
            renderCorners cs
            renderEdges es
        _ ->
          pure unit

showCorners :: Corners -> String
showCorners cs =
  showRecord "Corners"
    ["tl" `assoc` cs.tl, "tr" `assoc` cs.tr, "br" `assoc` cs.br, "bl" `assoc` cs.bl]
  where
  assoc k v = k <> ": " <> show v

getCorners above aboveRight right belowRight below belowLeft left aboveLeft =
  { tl: getCorner left above aboveLeft
  , tr: getCorner right above aboveRight
  , br: getCorner right below belowRight
  , bl: getCorner left below belowLeft
  }

-- order is: horizontal vertical corner
getCorner W W E = CRI
getCorner W W W = NON
getCorner W E _ = CSH
getCorner E W _ = CSV
getCorner E E _ = CRO

renderCorners :: forall e.  Corners -> CanvasM e Unit
renderCorners cs = do
  let renderCorner c a t = case c of
        CRO ->
          { prep: do
              translate t
              rotate a
          , go:
              arc { start:  pi
                  , end:    1.5 * pi
                  , x:      cornerMid
                  , y:      cornerMid
                  , radius: cornerRadius
                  }
          }
        CRI ->
          { prep: do
              translate t
              rotate a
          , go:
              arc { start:  0.0
                  , end:    pi/2.0
                  , x:      -cornerMid
                  , y:      -cornerMid
                  , radius: cornerRadius
                  }
          }
        CSH ->
          { prep: translate t
          , go: do
              moveTo (-cornerMid -1.0) 0.0
              lineTo (cornerMid + 1.0) 0.0
          }
        CSV ->
          { prep: translate t
          , go: do
              moveTo 0.0 (-cornerMid - 1.0)
              lineTo 0.0 (cornerMid + 1.0)
          }
        NON ->
          { prep: pure unit
          , go: pure unit
          }

  let s = (pxPerTile - cornerSize) / 2.0
  let cs' =
        [ { c: cs.tl
          , a: 0.0
          , t: {translateX: -s, translateY: -s}
          },

          { c: cs.tr
          , a: pi/2.0
          , t: {translateX: s, translateY: -s}
          },

          { c: cs.br
          , a: pi
          , t: {translateX: s, translateY: s}
          },

          { c: cs.bl
          , a: 1.5*pi
          , t: {translateX: -s, translateY: s}
          }
        ]

  for_ cs' $ \c -> do
    withContext $ do
      setLineCap Square
      let r = renderCorner c.c c.a c.t
      r.prep
      beginPath
      r.go
      stroke

getEdges above right below left =
  { t: above, r: right, b: below, l: left }

renderEdges es =
  let s = (pxPerTile / 2.0) - cornerSize
      x1 = -s - 1.0
      y1 = -s - (cornerSize / 2.0)
      x2 = s
      y2 = y1

      renderEdge e =
        when (e == E) $ do
          moveTo x1 y1
          lineTo x2 y2

      es' =
        [ { e: es.t, a: 0.0 }
        , { e: es.r, a: pi/2.0 }
        , { e: es.b, a: pi }
        , { e: es.l, a: 1.5*pi }
        ]

  in
  for_ es' $ \e ->
    withContext $ do
      rotate e.a
      beginPath
      renderEdge e.e
      stroke

renderPlayer :: forall e.
  (PlayerId -> Boolean)
  -> (PlayerId -> Boolean)
  -> PlayerId
  -> Player
  -> CanvasM e Unit
renderPlayer isRampaging isFleeing pId player = do
  setFillStyle $ if isFleeing pId then fleeingFlashColor else playerColor pId
  let r = playerRenderParameters player
  let centre = getCentredRectAt (player ^. pPosition)
  beginPath
  moveTo r.start.x r.start.y
  arc r.arc
  lineTo r.start.x r.start.y
  fill

  when (isRampaging pId) $ do
    setLineWidth 2.0
    setStrokeStyle rampagePlayerColor
    stroke

playerRenderParameters player =
  let centre = getCentredRectAt (player ^. pPosition)
      direction = fromMaybe Left (player ^. pDirection)

      baseAngle = directionToRadians direction
      index = player ^. pNomIndex
      half = nomIndexMax / 2
      maxAngle = pi / 2.0
      halfAngle = maxAngle / 2.0
      multiplier = Int.toNumber nomIndexMax / maxAngle
      delta =
        case player ^. pRespawnCounter of
          Just ctr ->
            let
              ratio = Int.toNumber ctr / Int.toNumber respawnLength
            in
              halfAngle + ((1.0 - ratio) * (pi - halfAngle))
          Nothing ->
            let
              x = if index <= half
                    then index
                    else nomIndexMax - index
            in
              multiplier * Int.toNumber x + 0.001

      op = dirToPos $ opposite direction
      start = addPos (scalePos (playerRadius / 2.0) op) (toPosition centre)
  in
    { arc: { x: centre.x
           , y: centre.y
           , start: (baseAngle + delta)
           , end: (baseAngle - delta)
           , radius: playerRadius
           }
    , start: { x: start ^. pX
             , y: start ^. pY
             }
    }

enlargeRect :: Number -> Rectangle -> Rectangle
enlargeRect delta r =
  { x: r.x - delta
  , y: r.y - delta
  , width: r.width + (2.0 * delta)
  , height: r.height + (2.0 * delta)
  }

renderItems :: forall e. Game -> CanvasM e Unit
renderItems game = do
  setFillStyle dotColor
  let rampaging = isJust game.rampage
  eachItem' game (renderItem rampaging)

renderItem :: forall e. Boolean -> Item -> CanvasM e Unit
renderItem rampaging item = do
  let centre = getCentredRectAt (item ^. iPosition)
  when (not (item ^. iType == BigDot && rampaging)) $ do
    beginPath
    arc { x: centre.x
        , y: centre.y
        , start: 0.0
        , end: 2.0 * pi
        , radius: dotRadiusFor (item ^. iType)
        }
    fill

renderPlayers :: forall e. Game -> CanvasM e Unit
renderPlayers game = do
  let isRampaging =
        maybe (const false)
              (\r -> case r of
                  Rampaging pId _ -> (==) pId
                  _ -> const false)
              game.rampage
  let isFleeing =
        maybe (const false)
              (\r -> case r of
                  Rampaging pId ctr ->
                    \pId' -> pId /= pId' && elem ctr flashCounts
                  _ ->
                    const false)
              game.rampage

  eachPlayer' game (renderPlayer isRampaging isFleeing)

  where
  flashCounts = concatMap (uncurry range) flashes

  initial = rampageLength /\ (rampageLength - step)
  f x = x - (2 * step)
  step = 8
  flashes = iterateN 5 initial (f *** f)

wholeCanvas :: Rectangle
wholeCanvas =
  {x: 0.0, y: 0.0, height: canvasSize, width: canvasSize}

clearCanvas :: forall e. CanvasM e Unit
clearCanvas =
  clearRect wholeCanvas

renderCountdown :: forall e. Game -> PlayerId -> CanvasM e Unit
renderCountdown game pId = do
  whenJust game.countdown $ \cd -> do
    renderCounter cd
    renderReminderArrow game pId

setFontSize :: forall e. Number -> CanvasM e Unit
setFontSize x =
  setFont $ show x <> "pt " <> fontName

renderCounter cd = do
  setFontSize (pxPerTile * 3.0)
  setTextAlign AlignCenter
  setLineWidth 3.0
  setFillStyle fontColor
  setStrokeStyle "black"
  let text = show (cd / 30)
  let x = halfCanvas
  let y = halfCanvas
  fillText   text x y
  strokeText text x y

renderReminderArrow :: forall e. Game -> PlayerId -> CanvasM e Unit
renderReminderArrow game pId = do
  whenJust (game ^. (players <<< at pId)) $ \pl ->
    withContext $ do
      let pos = pl ^. pPosition
      let playerX = pos ^. pX
      let y = pos ^. pY

      let greater = playerX > Int.toNumber (mapSize / 2)
      let d = 1.5 * Int.toNumber tileSize
      let x = playerX + (if greater then d else -d)

      let centre = getCentredRectAt (Position {x:x, y:y})

      setLineWidth 1.0
      beginPath
      arrowPath greater centre.x centre.y 30 10
      fill
      stroke

arrowPath toRight x y length width = do
  let halfLen = Int.toNumber (length / 2)
  let halfWid = Int.toNumber (width / 2)
  let f z = if toRight then x + z else x - z

  moveTo (f halfLen)             (y - halfWid)
  lineTo (f (- halfLen))         (y - halfWid)
  lineTo (f (- halfLen))         (y - (2.0 * halfWid))
  lineTo (f (- (2.0 * halfLen))) (y)
  lineTo (f (- halfLen))         (y + (2.0 * halfWid))
  lineTo (f (- halfLen))         (y + halfWid)
  lineTo (f halfLen)             (y + halfWid)
  lineTo (f halfLen)             (y - halfWid)

render :: forall e.
  RenderingContext
  -> Game
  -> PlayerId
  -> Boolean
  -> Effect Unit
render ctx game pId redrawMap = do
  when redrawMap $ do
    runCanvasM ctx.background $
      renderMap (unwrapLevelMap game.map)

  runCanvasM ctx.foreground $ do
    clearCanvas
    renderItems game
    renderPlayers game
    renderCountdown game pId

clearBoth :: forall e.
  RenderingContext
  -> Effect Unit
clearBoth ctx = do
  runCanvasM ctx.background clearCanvas
  runCanvasM ctx.foreground clearCanvas

setTextStyle = do
  setFontSize $ floor (0.6 * pxPerTile)
  setFillStyle fontColor

module Rendering where

import Prelude
import Data.Array hiding ((..))
import Data.Function
import Data.Map as M
import Data.Int as Int
import Data.Profunctor.Strong ((***))
import Data.Tuple
import Data.Tuple.Nested ((/\))
import Data.Maybe
import Data.Foldable
import Graphics.Canvas
  (getContext2D, setCanvasHeight, setCanvasWidth, Rectangle, Arc,
  Context2D, getCanvasElementById, TextAlign(..), LineCap(..))
import Effect
import Effect.Exception.Unsafe (unsafeThrow)
import Control.Monad (when)
import Data.Lens.Getter ((^.))
import Data.Lens.At (at)
import Data.Lens.Prism.Maybe (_Just)
import Math (pi, floor, ceil)

import LevelMap
import Types
import CanvasM
import Utils
import Game
import Style

halfBlock     = floor (pxPerBlock / 2.0)
halfPxPerTile = floor (pxPerTile / 2.0)
halfCanvas    = floor (canvasSize / 2.0)

scaleRect :: Number -> Position -> Rectangle
scaleRect scale (Position p) =
  {x: p.x * scale, y: p.y * scale, h: scale, w: scale}

toPosition :: Rectangle -> Position
toPosition r = Position {x:r.x, y:r.y}

getRectAt :: Position -> Rectangle
getRectAt = scaleRect pxPerBlock

getCentredRectAt :: Position -> Rectangle
getCentredRectAt p =
  let r = getRectAt p
  in  r {x = r.x + halfBlock, y = r.y + halfBlock}

getRectAt' :: Number -> Number -> Rectangle
getRectAt' x y = getRectAt (Position {x: x, y: y})

getTileRectAt :: Position -> Rectangle
getTileRectAt = scaleRect pxPerTile

getTileRectAt' :: Number -> Number -> Rectangle
getTileRectAt' x y = getTileRectAt (Position {x: x, y: y})

setupRendering :: Effect RenderingContext
setupRendering = do
  fg <- setupRenderingById "foreground"
  bg <- setupRenderingById "background"
  pure { foreground: fg, background: bg }

-- set up a canvas with the correct dimensions and return its context
setupRenderingById :: String -> Effect Context2D
setupRenderingById elId =
  getCanvasElementById elId
    >>= justOrErr
    >>= flip setCanvasHeight canvasSize
    >>= flip setCanvasWidth canvasSize
    >>= getContext2D

  where
  justOrErr :: forall a f. Applicative f => Maybe a -> f a
  justOrErr (Just x) = pure x
  justOrErr Nothing = unsafeThrow $ "no canvas element found with id = " <> elId

clearBackground :: forall e. CanvasM e Unit
clearBackground = do
  setFillStyle backgroundColor
  fillRect wholeCanvas

data CornerType
  = CRO -- rounded outer
  | CRI -- rounded inner
  | CSH -- straight horizontal
  | CSV -- straight vertical
  | NON -- nothing (inside a block)

instance showCornerType :: Show CornerType where
  show CRO = "CRO"
  show CRI = "CRI"
  show CSH = "CSH"
  show CSV = "CSV"
  show NON = "NON"

type Corners =
  { tl :: CornerType, tr :: CornerType, bl :: CornerType, br :: CornerType }

toBasic :: Tile -> BasicTile
toBasic Inaccessible = W
toBasic _ = E

renderMap :: forall e. LevelMap -> CanvasM e Unit
renderMap map = do
  setStrokeStyle tileColor

  let tileIndices = range 0 (tilesAlongSide - 1)
  let getTile i j = map.tiles !! i >>= (\r -> r !! j)
  let t i j = toBasic <$> getTile i j

  for_ tileIndices $ \i ->
    for_ tileIndices $ \j -> do
      let above      = fromMaybe W $ t i (j-1)
      let aboveRight = fromMaybe W $ t (i+1) (j-1)
      let right      = fromMaybe W $ t (i+1) j
      let belowRight = fromMaybe W $ t (i+1) (j+1)
      let below      = fromMaybe W $ t i (j+1)
      let belowLeft  = fromMaybe W $ t (i-1) (j+1)
      let left       = fromMaybe W $ t (i-1) j
      let aboveLeft  = fromMaybe W $ t (i-1) (j-1)

      case t i j of
        Just W -> do
          let cs = getCorners above aboveRight right belowRight
                              below belowLeft left aboveLeft
          let es = getEdges above right below left
          withContext $ do
            translate { translateX: (Int.toNumber i + 0.5) * pxPerTile
                      , translateY: (Int.toNumber j + 0.5) * pxPerTile
                      }
            renderCorners cs
            renderEdges es
        _ ->
          pure unit

showCorners :: Corners -> String
showCorners cs =
  showRecord "Corners"
    ["tl" `assoc` cs.tl, "tr" `assoc` cs.tr, "br" `assoc` cs.br, "bl" `assoc` cs.bl]
  where
  assoc k v = k <> ": " <> show v

getCorners above aboveRight right belowRight below belowLeft left aboveLeft =
  { tl: getCorner left above aboveLeft
  , tr: getCorner right above aboveRight
  , br: getCorner right below belowRight
  , bl: getCorner left below belowLeft
  }

-- order is: horizontal vertical corner
getCorner W W E = CRI
getCorner W W W = NON
getCorner W E _ = CSH
getCorner E W _ = CSV
getCorner E E _ = CRO

renderCorners :: forall e.  Corners -> CanvasM e Unit
renderCorners cs = do
  let renderCorner c a t = case c of
        CRO ->
          { prep: do
              translate t
              rotate a
          , go:
              arc { start: pi
                  , end:   1.5 * pi
                  , x:     cornerMid
                  , y:     cornerMid
                  , r:     cornerRadius
                  }
          }
        CRI ->
          { prep: do
              translate t
              rotate a
          , go:
              arc { start: 0.0
                  , end:   pi/2.0
                  , x:     -cornerMid
                  , y:     -cornerMid
                  , r:     cornerRadius
                  }
          }
        CSH ->
          { prep: translate t
          , go: do
              moveTo (-cornerMid -1.0) 0.0
              lineTo (cornerMid + 1.0) 0.0
          }
        CSV ->
          { prep: translate t
          , go: do
              moveTo 0.0 (-cornerMid - 1.0)
              lineTo 0.0 (cornerMid + 1.0)
          }
        NON ->
          { prep: pure unit
          , go: pure unit
          }

  let s = (pxPerTile - cornerSize) / 2.0
  let cs' =
        [ { c: cs.tl
          , a: 0.0
          , t: {translateX: -s, translateY: -s}
          },

          { c: cs.tr
          , a: pi/2.0
          , t: {translateX: s, translateY: -s}
          },

          { c: cs.br
          , a: pi
          , t: {translateX: s, translateY: s}
          },

          { c: cs.bl
          , a: 1.5*pi
          , t: {translateX: -s, translateY: s}
          }
        ]

  for_ cs' $ \c -> do
    withContext $ do
      setLineCap Square
      let r = renderCorner c.c c.a c.t
      r.prep
      beginPath
      r.go
      stroke

getEdges above right below left =
  { t: above, r: right, b: below, l: left }

renderEdges es =
  let s = (pxPerTile / 2.0) - cornerSize
      x1 = -s - 1.0
      y1 = -s - (cornerSize / 2.0)
      x2 = s
      y2 = y1

      renderEdge e =
        when (e == E) $ do
          moveTo x1 y1
          lineTo x2 y2

      es' =
        [ { e: es.t, a: 0.0 }
        , { e: es.r, a: pi/2.0 }
        , { e: es.b, a: pi }
        , { e: es.l, a: 1.5*pi }
        ]

  in
  for_ es' $ \e ->
    withContext $ do
      rotate e.a
      beginPath
      renderEdge e.e
      stroke

renderPlayer :: forall e.
  (PlayerId -> Boolean)
  -> (PlayerId -> Boolean)
  -> PlayerId
  -> Player
  -> CanvasM e Unit
renderPlayer isRampaging isFleeing pId player = do
  setFillStyle $ if isFleeing pId then fleeingFlashColor else playerColor pId
  let r = playerRenderParameters player
  let centre = getCentredRectAt (player ^. pPosition)
  beginPath
  moveTo r.start.x r.start.y
  arc r.arc
  lineTo r.start.x r.start.y
  fill

  when (isRampaging pId) $ do
    setLineWidth 2.0
    setStrokeStyle rampagePlayerColor
    stroke

playerRenderParameters player =
  let centre = getCentredRectAt (player ^. pPosition)
      direction = fromMaybe Left (player ^. pDirection)

      baseAngle = directionToRadians direction
      index = player ^. pNomIndex
      half = nomIndexMax / 2
      maxAngle = pi / 2.0
      halfAngle = maxAngle / 2.0
      multiplier = Int.toNumber nomIndexMax / maxAngle
      delta =
        case player ^. pRespawnCounter of
          Just ctr ->
            let
              ratio = Int.toNumber ctr / Int.toNumber respawnLength
            in
              halfAngle + ((1.0 - ratio) * (pi - halfAngle))
          Nothing ->
            let
              x = if index <= half
                    then index
                    else nomIndexMax - index
            in
              multiplier * Int.toNumber x + 0.001

      op = dirToPos $ opposite direction
      start = addPos (scalePos (playerRadius / 2.0) op) (toPosition centre)
  in
    { arc: { x: centre.x
           , y: centre.y
           , start: (baseAngle + delta)
           , end: (baseAngle - delta)
           , r: playerRadius
           }
    , start: { x: start ^. pX
             , y: start ^. pY
             }
    }

enlargeRect :: Number -> Rectangle -> Rectangle
enlargeRect delta r =
  { x: r.x - delta
  , y: r.y - delta
  , w: r.w + (2.0 * delta)
  , h: r.h + (2.0 * delta)
  }

renderItems :: forall e. Game -> CanvasM e Unit
renderItems game = do
  setFillStyle dotColor
  let rampaging = isJust game.rampage
  eachItem' game (renderItem rampaging)

renderItem :: forall e. Boolean -> Item -> CanvasM e Unit
renderItem rampaging item = do
  let centre = getCentredRectAt (item ^. iPosition)
  when (not (item ^. iType == BigDot && rampaging)) $ do
    beginPath
    arc { x: centre.x
        , y: centre.y
        , start: 0.0
        , end: 2.0 * pi
        , r: dotRadiusFor (item ^. iType)
        }
    fill

renderPlayers :: forall e. Game -> CanvasM e Unit
renderPlayers game = do
  let isRampaging =
        maybe (const false)
              (\r -> case r of
                  Rampaging pId _ -> (==) pId
                  _ -> const false)
              game.rampage
  let isFleeing =
        maybe (const false)
              (\r -> case r of
                  Rampaging pId ctr ->
                    \pId' -> pId /= pId' && elem ctr flashCounts
                  _ ->
                    const false)
              game.rampage

  eachPlayer' game (renderPlayer isRampaging isFleeing)

  where
  flashCounts = concatMap (uncurry range) flashes

  initial = rampageLength /\ (rampageLength - step)
  f x = x - (2 * step)
  step = 8
  flashes = iterateN 5 initial (f *** f)

wholeCanvas =
  {x: 0.0, y: 0.0, h: canvasSize, w: canvasSize}

clearCanvas :: forall e. CanvasM e Unit
clearCanvas =
  clearRect wholeCanvas

renderCountdown :: forall e. Game -> PlayerId -> CanvasM e Unit
renderCountdown game pId = do
  whenJust game.countdown $ \cd -> do
    renderCounter cd
    renderReminderArrow game pId

setFontSize :: forall e. Number -> CanvasM e Unit
setFontSize x =
  setFont $ show x <> "pt " <> fontName

renderCounter cd = do
  setFontSize (pxPerTile * 3.0)
  setTextAlign AlignCenter
  setLineWidth 3.0
  setFillStyle fontColor
  setStrokeStyle "black"
  let text = show (cd / 30)
  let x = halfCanvas
  let y = halfCanvas
  fillText   text x y
  strokeText text x y

renderReminderArrow :: forall e. Game -> PlayerId -> CanvasM e Unit
renderReminderArrow game pId = do
  whenJust (game ^. (players <<< at pId)) $ \pl ->
    withContext $ do
      let pos = pl ^. pPosition
      let playerX = pos ^. pX
      let y = pos ^. pY

      let greater = playerX > Int.toNumber (mapSize / 2)
      let d = 1.5 * Int.toNumber tileSize
      let x = playerX + (if greater then d else -d)

      let centre = getCentredRectAt (Position {x:x, y:y})

      setLineWidth 1.0
      beginPath
      arrowPath greater centre.x centre.y 30 10
      fill
      stroke

arrowPath toRight x y length width = do
  let halfLen = Int.toNumber (length / 2)
  let halfWid = Int.toNumber (width / 2)
  let f z = if toRight then x + z else x - z

  moveTo (f halfLen)             (y - halfWid)
  lineTo (f (- halfLen))         (y - halfWid)
  lineTo (f (- halfLen))         (y - (2.0 * halfWid))
  lineTo (f (- (2.0 * halfLen))) (y)
  lineTo (f (- halfLen))         (y + (2.0 * halfWid))
  lineTo (f (- halfLen))         (y + halfWid)
  lineTo (f halfLen)             (y + halfWid)
  lineTo (f halfLen)             (y - halfWid)

render :: forall e.
  RenderingContext
  -> Game
  -> PlayerId
  -> Boolean
  -> Effect Unit
render ctx game pId redrawMap = do
  when redrawMap $ do
    runCanvasM ctx.background $
      renderMap (unwrapLevelMap game.map)

  runCanvasM ctx.foreground $ do
    clearCanvas
    renderItems game
    renderPlayers game
    renderCountdown game pId

clearBoth :: forall e.
  RenderingContext
  -> Effect Unit
clearBoth ctx = do
  runCanvasM ctx.background clearCanvas
  runCanvasM ctx.foreground clearCanvas

setTextStyle = do
  setFontSize $ floor (0.6 * pxPerTile)
  setFillStyle fontColor


After being eaten, direction should reset

module Game where

import Data.Tuple
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import Data.Array ((!!), range, filter, length, take)
import qualified Data.Map as M
import Data.Foldable
import Control.Arrow
import Control.Alt
import Control.Monad
import Control.Monad.Reader.Class
import Control.Lens (LensP(), TraversalP(), lens, at, _Just, _1, _2,
                     (.~), (..), (^.), (%~), (~))
import Math (ceil, floor, pi)

import Types
import LevelMap
import Utils

minPlayers = 2
rampageLength = 180
cooldownLength = 120
respawnLength = 60

-- minimum squared distance that a player needs to be from another player in
-- order to eat them, in blocks.
minEatingQuadrance = 4

-- update signalling

player :: PlayerId -> TraversalP Game Player
player pId = players .. at pId .. _Just

item :: ItemId -> TraversalP Game Item
item iId = items .. at iId .. _Just

applyGameUpdate :: GameUpdate -> Game -> Game
applyGameUpdate u =
  case u of
    GUPU pId PlayerLeft ->
      removePlayer pId
    GUPU pId x ->
      player pId %~ applyPlayerUpdate x
    GUIU iId x ->
      items .. at iId %~ applyItemUpdate x
    ChangedCountdown x ->
      setCountdown x
    GameEnded _ ->
      id
    ChangedRampage r ->
      \g -> g { rampage = r }
  where
  setCountdown x game = game {countdown = x}

applyGameUpdates :: [GameUpdate] -> Game -> Game
applyGameUpdates updates game = foldr applyGameUpdate game updates

removePlayer :: PlayerId -> Game -> Game
removePlayer pId = players .. at pId .~ Nothing

applyPlayerUpdate :: PlayerUpdate -> Player -> Player
applyPlayerUpdate u =
  case u of
    (ChangedPosition p)          -> pPosition .~ p
    (ChangedDirection d)         -> pDirection .~ d
    (ChangedIntendedDirection d) -> pIntendedDirection .~ d
    (ChangedScore s)             -> pScore .~ s
    (ChangedNomIndex a)          -> pNomIndex .~ a
    (ChangedRespawnCounter x)    -> pRespawnCounter .~ x

applyItemUpdate :: ItemUpdate -> Maybe Item -> Maybe Item
applyItemUpdate u =
  case u of
    Eaten -> const Nothing

applyGameUpdateM :: GameUpdate -> GameUpdateM Unit
applyGameUpdateM update = do
  tellGameUpdate update
  modifyGame (applyGameUpdate update)

changePosition :: PlayerId -> Position -> GameUpdateM Unit
changePosition pId p =
  applyGameUpdateM (GUPU pId (ChangedPosition p))

changeDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedDirection d))

changeIntendedDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeIntendedDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedIntendedDirection d))

changeScore :: PlayerId -> Number -> GameUpdateM Unit
changeScore pId s =
  applyGameUpdateM (GUPU pId (ChangedScore s))

changeCountdown :: Maybe Number -> GameUpdateM Unit
changeCountdown =
  applyGameUpdateM <<< ChangedCountdown

changeNomIndex :: PlayerId -> Number -> GameUpdateM Unit
changeNomIndex pId i =
  applyGameUpdateM (GUPU pId (ChangedNomIndex i))

eat :: ItemId -> GameUpdateM Unit
eat iId =
  applyGameUpdateM (GUIU iId Eaten)

changeRespawnCounter :: PlayerId -> Maybe Number -> GameUpdateM Unit
changeRespawnCounter pId x =
  applyGameUpdateM (GUPU pId (ChangedRespawnCounter x))

endGame :: GameEndReason -> GameUpdateM Unit
endGame =
  applyGameUpdateM <<< GameEnded

changeRampage :: Maybe Rampage -> GameUpdateM Unit
changeRampage =
  applyGameUpdateM <<< ChangedRampage

initialGame :: Game
initialGame =
  { map: levelmap
  , players: M.fromList $ f <$> starts
  , items:   M.fromList $ zipNumbers $ makeItems levelmap safeZone bigDots
  , countdown: Just 90
  , rampage: Nothing
  , safeZone: safeZone
  }
  where
  levelmap = basicMap2
  f (Tuple pId position) = Tuple pId (mkPlayer position)
  starts =
    [ P1 ~ tilePositionToBlock (Position {x:7, y:7})
    , P2 ~ tilePositionToBlock (Position {x:9, y:7})
    , P3 ~ tilePositionToBlock (Position {x:7, y:8})
    , P4 ~ tilePositionToBlock (Position {x:9, y:8})
    ]
  safeZone = do
    x <- [7,8,9]
    y <- [6,7,8,9]
    return (tilePositionToBlock (Position {x:x, y:y}))
  bigDots = do
    x <- [3, tilesAlongSide - 4]
    y <- [3, tilesAlongSide - 4]
    return (tilePositionToBlock (Position {x:x, y:y}))

stepGame :: Input -> Game -> Tuple Game [GameUpdate]
stepGame input game =
  let actions = [handleInput input, doLogic]
      action = foldl (>>) (return unit) actions
  in  execGameUpdateM game action

handleInput :: Input -> GameUpdateM Unit
handleInput input =
  for_ (M.toList input) $ \(Tuple pId maybeDir) ->
    whenJust maybeDir $ \newDirection ->
      changeIntendedDirection pId (Just newDirection)

doLogic :: GameUpdateM Unit
doLogic = do
  g <- getGame
  case g.countdown of
    Just x -> changeCountdown (decrementOrNothing x)
    Nothing -> do
      eachPlayer updateDirection
      eachPlayer movePlayer
      eachPlayer eatItems
      eachPlayer eatOtherPlayers
      eachPlayer attemptRespawn
      decrementRampageCounter
      checkForGameEnd

decrementOrNothing x =
  let x' = x - 1
  in if x' <= 0
        then Nothing
        else Just x'

updateDirection :: PlayerId -> Player -> GameUpdateM Unit
updateDirection pId p =
  whenJust (p ^.pIntendedDirection) $ tryChangeDirection pId p

movePlayer :: PlayerId -> Player -> GameUpdateM Unit
movePlayer pId p =
  whenJust (p ^. pDirection) $ \dir -> do
    ok <- canMoveInDirection pId p dir
    when ok $ do
      changePosition pId $ moveInDirection dir (p ^. pPosition)
      changeNomIndex pId $ ((p ^. pNomIndex) + 1) % nomIndexMax

isRampage :: PlayerId -> GameUpdateM Boolean
isRampage pId = do
  g <- getGame
  maybe (return false) isRampaging g.rampage
  where
  isRampaging rampage =
    return $ case rampage of
      Rampaging pId' _ -> pId' == pId
      Cooldown _       -> false

eatItems :: PlayerId -> Player -> GameUpdateM Unit
eatItems pId p = do
  g <- getGame
  let mItem = lookupItemByPosition (p ^. pPosition) g
  whenJust mItem $ \(Tuple iId item) -> do
    case item ^. iType of
      LittleDot -> do
        eat iId
        changeScore pId (p ^. pScore + 1)
      BigDot ->
        when (not (isJust g.rampage)) $ do
          eat iId
          changeScore pId (p ^. pScore + 5)
          startRampage pId

eatOtherPlayers :: PlayerId -> Player -> GameUpdateM Unit
eatOtherPlayers pId p = do
  ok <- isRampage pId
  when ok $ do
    eachPlayer $ \pId' p' ->
      when (pId' /= pId && not (isRespawning p')) $ do
        let q = quadrance (p ^. pPosition) (p' ^. pPosition)
        when (q <= minEatingQuadrance) $ do
          changeRespawnCounter pId' $ Just respawnLength
          takeHalfPoints pId p pId' p'
          changeDirection pId' Nothing
  where
  takeHalfPoints pId p pId' p' = do
    let delta = floor (p' ^. pScore / 2)
    changeScore pId $ p ^. pScore + delta
    changeScore pId' $ p' ^. pScore - delta

decrementRampageCounter :: GameUpdateM Unit
decrementRampageCounter = do
  g <- getGame
  whenJust g.rampage $ \rampage ->
    changeRampage $
      case rampage of
        Rampaging pId ctr ->
          Just $ fromMaybe (Cooldown cooldownLength)
                           (Rampaging pId <$> decrementOrNothing ctr)
        Cooldown ctr ->
          Cooldown <$> decrementOrNothing ctr

startRampage :: PlayerId -> GameUpdateM Unit
startRampage pId =
  changeRampage $ Just $ Rampaging pId rampageLength

checkForGameEnd :: GameUpdateM Unit
checkForGameEnd = do
  g <- getGame
  whenJust (checkEnded g) endGame

tryChangeDirection :: PlayerId -> Player -> Direction -> GameUpdateM Unit
tryChangeDirection pId p d = do
  ok <- canMoveInDirection pId p d
  when ok $ do
    changeDirection pId (Just d)
    changeIntendedDirection pId Nothing

canMoveInDirection :: PlayerId -> Player -> Direction -> GameUpdateM Boolean
canMoveInDirection pId p d =
  let newPosition = moveInDirection d (p ^. pPosition)
      destIsFree game  = isFree game.map newPosition
      immobilised game = isRespawning p || isFleeing game
      isFleeing game   =
        case game.rampage of
          Just (Rampaging pId' count) -> pId' /= pId && count % 3 == 0
          _ -> false
      both (Tuple x y) = x && y

  in  both <<< (destIsFree &&& (not <<< immobilised)) <$> getGame

isRespawning p =
  isJust $ p ^. pRespawnCounter

attemptRespawn :: PlayerId -> Player -> GameUpdateM Unit
attemptRespawn pId p = do
  g <- getGame
  whenJust (p ^. pRespawnCounter) $ \ctr -> do
    let ctr' = decrementOrNothing ctr
    changeRespawnCounter pId ctr'
    when (ctr' == Nothing) $ do
      let mPos = find (\pos -> isFree g.map pos) g.safeZone
      whenJust mPos $ changePosition pId

inSafeZone :: Game -> Position -> Boolean
inSafeZone g pos = pos `elem` g.safeZone

moveInDirection :: Direction -> Position -> Position
moveInDirection d p = add p (dirToPos d)

isFree :: LevelMap -> Position -> Boolean
isFree levelmap pos =
  let block = getBlockAt pos levelmap
  in  maybe false (not <<< isWall) block

makeItems :: LevelMap -> [Position] -> [Position] -> [Item]
makeItems levelmap safeZone bigDotPositions =
  littleDots <> bigDots
  where
  littleDots = do
    x <- r
    y <- r
    let pos = tilePositionToBlock (Position {x: x, y: y})
    if shouldHaveLittleDot pos
      then [Item { itemType: LittleDot, position: pos }]
      else []

  r = range 0 (tilesAlongSide - 1)

  shouldHaveLittleDot pos =
    isFree levelmap pos &&
      not (elem pos safeZone) &&
      not (elem pos bigDotPositions)

  bigDots =
    (\pos -> Item { itemType: BigDot, position: pos }) <$> bigDotPositions

makeGame :: [PlayerId] -> Game
makeGame pIds =
  let players' =
    deleteWhere (\pId _ -> not (elem pId pIds)) (initialGame.players)
  in initialGame { players = players' }

inCountdown :: Game -> Boolean
inCountdown g = isJust g.countdown

checkEnded :: Game -> Maybe GameEndReason
checkEnded g
  | M.isEmpty g.items                         = Just Completed
  | length (M.values g.players) < minPlayers  = Just TooManyPlayersDisconnected
  | otherwise                                 = Nothing

isEnded = isJust <<< checkEnded

-- TODO: performance
lookupItemByPosition :: Position -> Game -> Maybe (Tuple ItemId Item)
lookupItemByPosition pos g =
  case filter (\i -> (i ^. _2 ^. iPosition) == pos) (M.toList g.items) of
      [i] -> Just i
      []  -> Nothing
      x   -> error $ "lookupItemByPosition: items stacked: " <> show x

module Game where

import Data.Tuple
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import Data.Array ((!!), range, filter, length, take)
import qualified Data.Map as M
import Data.Foldable
import Control.Arrow
import Control.Alt
import Control.Monad
import Control.Monad.Reader.Class
import Control.Lens (LensP(), TraversalP(), lens, at, _Just, _1, _2,
                     (.~), (..), (^.), (%~), (~))
import Math (ceil, floor, pi)

import Types
import LevelMap
import Utils

minPlayers = 2
rampageLength = 180
cooldownLength = 120
respawnLength = 60

-- minimum squared distance that a player needs to be from another player in
-- order to eat them, in blocks.
minEatingQuadrance = 4

-- update signalling

player :: PlayerId -> TraversalP Game Player
player pId = players .. at pId .. _Just

item :: ItemId -> TraversalP Game Item
item iId = items .. at iId .. _Just

applyGameUpdate :: GameUpdate -> Game -> Game
applyGameUpdate u =
  case u of
    GUPU pId PlayerLeft ->
      removePlayer pId
    GUPU pId x ->
      player pId %~ applyPlayerUpdate x
    GUIU iId x ->
      items .. at iId %~ applyItemUpdate x
    ChangedCountdown x ->
      setCountdown x
    GameEnded _ ->
      id
    ChangedRampage r ->
      \g -> g { rampage = r }
  where
  setCountdown x game = game {countdown = x}

applyGameUpdates :: [GameUpdate] -> Game -> Game
applyGameUpdates updates game = foldr applyGameUpdate game updates

removePlayer :: PlayerId -> Game -> Game
removePlayer pId = players .. at pId .~ Nothing

applyPlayerUpdate :: PlayerUpdate -> Player -> Player
applyPlayerUpdate u =
  case u of
    (ChangedPosition p)          -> pPosition .~ p
    (ChangedDirection d)         -> pDirection .~ d
    (ChangedIntendedDirection d) -> pIntendedDirection .~ d
    (ChangedScore s)             -> pScore .~ s
    (ChangedNomIndex a)          -> pNomIndex .~ a
    (ChangedRespawnCounter x)    -> pRespawnCounter .~ x

applyItemUpdate :: ItemUpdate -> Maybe Item -> Maybe Item
applyItemUpdate u =
  case u of
    Eaten -> const Nothing

applyGameUpdateM :: GameUpdate -> GameUpdateM Unit
applyGameUpdateM update = do
  tellGameUpdate update
  modifyGame (applyGameUpdate update)

changePosition :: PlayerId -> Position -> GameUpdateM Unit
changePosition pId p =
  applyGameUpdateM (GUPU pId (ChangedPosition p))

changeDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedDirection d))

changeIntendedDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeIntendedDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedIntendedDirection d))

changeScore :: PlayerId -> Number -> GameUpdateM Unit
changeScore pId s =
  applyGameUpdateM (GUPU pId (ChangedScore s))

changeCountdown :: Maybe Number -> GameUpdateM Unit
changeCountdown =
  applyGameUpdateM <<< ChangedCountdown

changeNomIndex :: PlayerId -> Number -> GameUpdateM Unit
changeNomIndex pId i =
  applyGameUpdateM (GUPU pId (ChangedNomIndex i))

eat :: ItemId -> GameUpdateM Unit
eat iId =
  applyGameUpdateM (GUIU iId Eaten)

changeRespawnCounter :: PlayerId -> Maybe Number -> GameUpdateM Unit
changeRespawnCounter pId x =
  applyGameUpdateM (GUPU pId (ChangedRespawnCounter x))

endGame :: GameEndReason -> GameUpdateM Unit
endGame =
  applyGameUpdateM <<< GameEnded

changeRampage :: Maybe Rampage -> GameUpdateM Unit
changeRampage =
  applyGameUpdateM <<< ChangedRampage

initialGame :: Game
initialGame =
  { map: levelmap
  , players: M.fromList $ f <$> starts
  , items:   M.fromList $ zipNumbers $ makeItems levelmap safeZone bigDots
  , countdown: Just 90
  , rampage: Nothing
  , safeZone: safeZone
  }
  where
  levelmap = basicMap2
  f (Tuple pId position) = Tuple pId (mkPlayer position)
  starts =
    [ P1 ~ tilePositionToBlock (Position {x:7, y:7})
    , P2 ~ tilePositionToBlock (Position {x:9, y:7})
    , P3 ~ tilePositionToBlock (Position {x:7, y:8})
    , P4 ~ tilePositionToBlock (Position {x:9, y:8})
    ]
  safeZone = do
    x <- [7,8,9]
    y <- [6,7,8,9]
    return (tilePositionToBlock (Position {x:x, y:y}))
  bigDots = do
    x <- [3, tilesAlongSide - 4]
    y <- [3, tilesAlongSide - 4]
    return (tilePositionToBlock (Position {x:x, y:y}))

stepGame :: Input -> Game -> Tuple Game [GameUpdate]
stepGame input game =
  let actions = [handleInput input, doLogic]
      action = foldl (>>) (return unit) actions
  in  execGameUpdateM game action

handleInput :: Input -> GameUpdateM Unit
handleInput input =
  for_ (M.toList input) $ \(Tuple pId maybeDir) ->
    whenJust maybeDir $ \newDirection ->
      changeIntendedDirection pId (Just newDirection)

doLogic :: GameUpdateM Unit
doLogic = do
  g <- getGame
  case g.countdown of
    Just x -> changeCountdown (decrementOrNothing x)
    Nothing -> do
      eachPlayer updateDirection
      eachPlayer movePlayer
      eachPlayer eatItems
      eachPlayer eatOtherPlayers
      eachPlayer attemptRespawn
      decrementRampageCounter
      checkForGameEnd

decrementOrNothing x =
  let x' = x - 1
  in if x' <= 0
        then Nothing
        else Just x'

updateDirection :: PlayerId -> Player -> GameUpdateM Unit
updateDirection pId p =
  whenJust (p ^.pIntendedDirection) $ tryChangeDirection pId p

movePlayer :: PlayerId -> Player -> GameUpdateM Unit
movePlayer pId p =
  whenJust (p ^. pDirection) $ \dir -> do
    ok <- canMoveInDirection pId p dir
    when ok $ do
      changePosition pId $ moveInDirection dir (p ^. pPosition)
      changeNomIndex pId $ ((p ^. pNomIndex) + 1) % nomIndexMax

isRampage :: PlayerId -> GameUpdateM Boolean
isRampage pId = do
  g <- getGame
  maybe (return false) isRampaging g.rampage
  where
  isRampaging rampage =
    return $ case rampage of
      Rampaging pId' _ -> pId' == pId
      Cooldown _       -> false

eatItems :: PlayerId -> Player -> GameUpdateM Unit
eatItems pId p = do
  g <- getGame
  let mItem = lookupItemByPosition (p ^. pPosition) g
  whenJust mItem $ \(Tuple iId item) -> do
    case item ^. iType of
      LittleDot -> do
        eat iId
        changeScore pId (p ^. pScore + 1)
      BigDot ->
        when (not (isJust g.rampage)) $ do
          eat iId
          changeScore pId (p ^. pScore + 5)
          startRampage pId

eatOtherPlayers :: PlayerId -> Player -> GameUpdateM Unit
eatOtherPlayers pId p = do
  ok <- isRampage pId
  when ok $ do
    eachPlayer $ \pId' p' ->
      when (pId' /= pId && not (isRespawning p')) $ do
        let q = quadrance (p ^. pPosition) (p' ^. pPosition)
        when (q <= minEatingQuadrance) $ do
          changeRespawnCounter pId' $ Just respawnLength
          takeHalfPoints pId p pId' p'
  where
  takeHalfPoints pId p pId' p' = do
    let delta = floor (p' ^. pScore / 2)
    changeScore pId $ p ^. pScore + delta
    changeScore pId' $ p' ^. pScore - delta

decrementRampageCounter :: GameUpdateM Unit
decrementRampageCounter = do
  g <- getGame
  whenJust g.rampage $ \rampage ->
    changeRampage $
      case rampage of
        Rampaging pId ctr ->
          Just $ fromMaybe (Cooldown cooldownLength)
                           (Rampaging pId <$> decrementOrNothing ctr)
        Cooldown ctr ->
          Cooldown <$> decrementOrNothing ctr

startRampage :: PlayerId -> GameUpdateM Unit
startRampage pId =
  changeRampage $ Just $ Rampaging pId rampageLength

checkForGameEnd :: GameUpdateM Unit
checkForGameEnd = do
  g <- getGame
  whenJust (checkEnded g) endGame

tryChangeDirection :: PlayerId -> Player -> Direction -> GameUpdateM Unit
tryChangeDirection pId p d = do
  ok <- canMoveInDirection pId p d
  when ok $ do
    changeDirection pId (Just d)
    changeIntendedDirection pId Nothing

canMoveInDirection :: PlayerId -> Player -> Direction -> GameUpdateM Boolean
canMoveInDirection pId p d =
  let newPosition = moveInDirection d (p ^. pPosition)
      destIsFree game  = isFree game.map newPosition
      immobilised game = isRespawning p || isFleeing game
      isFleeing game   =
        case game.rampage of
          Just (Rampaging pId' count) -> pId' /= pId && count % 3 == 0
          _ -> false
      both (Tuple x y) = x && y

  in  both <<< (destIsFree &&& (not <<< immobilised)) <$> getGame

isRespawning p =
  isJust $ p ^. pRespawnCounter

attemptRespawn :: PlayerId -> Player -> GameUpdateM Unit
attemptRespawn pId p = do
  g <- getGame
  whenJust (p ^. pRespawnCounter) $ \ctr -> do
    let ctr' = decrementOrNothing ctr
    changeRespawnCounter pId ctr'
    when (ctr' == Nothing) $ do
      let mPos = find (\pos -> isFree g.map pos) g.safeZone
      whenJust mPos $ changePosition pId

inSafeZone :: Game -> Position -> Boolean
inSafeZone g pos = pos `elem` g.safeZone

moveInDirection :: Direction -> Position -> Position
moveInDirection d p = add p (dirToPos d)

isFree :: LevelMap -> Position -> Boolean
isFree levelmap pos =
  let block = getBlockAt pos levelmap
  in  maybe false (not <<< isWall) block

makeItems :: LevelMap -> [Position] -> [Position] -> [Item]
makeItems levelmap safeZone bigDotPositions =
  littleDots <> bigDots
  where
  littleDots = do
    x <- r
    y <- r
    let pos = tilePositionToBlock (Position {x: x, y: y})
    if shouldHaveLittleDot pos
      then [Item { itemType: LittleDot, position: pos }]
      else []

  r = range 0 (tilesAlongSide - 1)

  shouldHaveLittleDot pos =
    isFree levelmap pos &&
      not (elem pos safeZone) &&
      not (elem pos bigDotPositions)

  bigDots =
    (\pos -> Item { itemType: BigDot, position: pos }) <$> bigDotPositions

makeGame :: [PlayerId] -> Game
makeGame pIds =
  let players' =
    deleteWhere (\pId _ -> not (elem pId pIds)) (initialGame.players)
  in initialGame { players = players' }

inCountdown :: Game -> Boolean
inCountdown g = isJust g.countdown

checkEnded :: Game -> Maybe GameEndReason
checkEnded g
  | M.isEmpty g.items                         = Just Completed
  | length (M.values g.players) < minPlayers  = Just TooManyPlayersDisconnected
  | otherwise                                 = Nothing

isEnded = isJust <<< checkEnded

-- TODO: performance
lookupItemByPosition :: Position -> Game -> Maybe (Tuple ItemId Item)
lookupItemByPosition pos g =
  case filter (\i -> (i ^. _2 ^. iPosition) == pos) (M.toList g.items) of
      [i] -> Just i
      []  -> Nothing
      x   -> error $ "lookupItemByPosition: items stacked: " <> show x


Adjust help text

Adjust help text

module Main where

import Prelude
import Data.Argonaut.Core (stringify)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Encode (encodeJson)
import Data.Array as Array
import Data.DateTime (DateTime)
import Data.DateTime.Instant (toDateTime)
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.Traversable (traverse)
import Data.StrMap as StrMap
import Data.StrMap.ST as STMap
import Data.Maybe (Maybe(..), maybe)
import Data.Set as Set
import Data.String as Str
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Control.Monad.Eff.Exception (EXCEPTION, catchException, throw, throwException)
import Control.Monad.Eff.Now (NOW, now)
import Control.Monad.ST (ST)
import Control.Monad.ST as ST
import Node.Platform (Platform(Win32))
import Node.Process (PROCESS)
import Node.Process as Process
import Node.ChildProcess (CHILD_PROCESS)
import Node.ChildProcess as Child
import Node.Stream as Stream
import Node.Buffer (BUFFER)
import Node.Encoding as Encoding
import Node.FS (FS)
import Node.FS.Sync as File
import Node.FS.Stats as Stats
import Node.Path as Path
import Partial.Unsafe (unsafePartial)
import Psa (PsaOptions, StatVerbosity(..), parsePsaResult, parsePsaError, encodePsaError, output)
import Psa.Printer.Default as DefaultPrinter
import Psa.Printer.Json as JsonPrinter

foreign import version :: String

defaultOptions :: PsaOptions
defaultOptions =
  { ansi: true
  , censorWarnings: false
  , censorLib: false
  , censorSrc: false
  , censorCodes: Set.empty
  , filterCodes: Set.empty
  , statVerbosity: CompactStats
  , libDirs: []
  , strict: false
  , cwd: ""
  }

type ParseOptions =
  { extra :: Array String
  , opts :: PsaOptions
  , purs :: String
  , showSource :: Boolean
  , stash :: Boolean
  , stashFile :: String
  , jsonErrors :: Boolean
  }

parseOptions
  :: forall eff
   . PsaOptions
  -> Array String
  -> Eff (console :: CONSOLE, process :: PROCESS | eff) ParseOptions
parseOptions opts args =
  defaultLibDir <$>
    Array.foldM parse
      { extra: []
      , purs: "purs"
      , showSource: true
      , stash: false
      , stashFile: ".psa-stash"
      , jsonErrors: false
      , opts
      }
      args
  where
  parse p arg
    | arg == "--version" || arg == "-v" =
      Console.log version *> Process.exit 0

    | arg == "--help" || arg == "-h" =
      Console.log usage *> Process.exit 0

    | arg == "--stash" =
      pure p { stash = true }

    | arg == "--json-errors" =
      pure p { jsonErrors = true }

    | arg == "--no-source" =
      pure p { showSource = false }

    | arg == "--no-colors" || arg == "--monochrome" =
      pure p { opts = p.opts { ansi = false } }

    | arg == "--verbose-stats" =
      pure p { opts = p.opts { statVerbosity = VerboseStats } }

    | arg == "--censor-stats" =
      pure p { opts = p.opts { statVerbosity = NoStats } }

    | arg == "--strict" =
      pure p { opts = p.opts { strict = true } }

    | arg == "--censor-warnings" =
      pure p { opts = p.opts { censorWarnings = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-src" =
      pure p { opts = p.opts { censorSrc = true } }

    | isPrefix "--censor-codes=" arg =
      pure p { opts = p.opts { censorCodes = foldr Set.insert p.opts.censorCodes (Str.split (Str.Pattern ",") (Str.drop 15 arg)) } }

    | isPrefix "--filter-codes=" arg =
      pure p { opts = p.opts { filterCodes = foldr Set.insert p.opts.filterCodes (Str.split (Str.Pattern ",") (Str.drop 15 arg)) } }

    | isPrefix "--is-lib=" arg =
      pure p { opts = p.opts { libDirs = Array.snoc p.opts.libDirs (Str.drop 9 arg) } }

    | isPrefix "--purs=" arg =
      pure p { purs = Str.drop 7 arg }

    | isPrefix "--stash=" arg =
      pure p { stash = true, stashFile = Str.drop 8 arg }

    | otherwise = pure p { extra = Array.snoc p.extra arg }

  isPrefix s str =
    case Str.indexOf (Str.Pattern s) str of
      Just x | x == 0 -> true
      _               -> false

  defaultLibDir x
    | Array.length x.opts.libDirs == 0 =
      x { opts = x.opts { libDirs = [ "bower_components" ] } }
    | otherwise = x

type MainEff h eff =
  ( process :: PROCESS
  , console :: CONSOLE
  , buffer :: BUFFER
  , exception :: EXCEPTION
  , fs :: FS
  , cp :: CHILD_PROCESS
  , st :: ST h
  , now :: NOW
  | eff
  )

main :: forall h eff. Eff (MainEff h eff) Unit
main = void do
  cwd <- Process.cwd
  argv <- Array.drop 2 <$> Process.argv

  { extra
  , opts
  , purs
  , showSource
  , stash
  , stashFile
  , jsonErrors
  } <- parseOptions (defaultOptions { cwd = cwd }) argv

  let opts' = opts { libDirs = (_ <> Path.sep) <<< Path.resolve [cwd] <$> opts.libDirs }
      args  = Array.cons "compile" $ Array.cons "--json-errors" extra

  stashData <-
    if stash
      then readStashFile stashFile
      else emptyStash

  spawn' purs args \buffer -> do
    let stderr = Str.split (Str.Pattern "\n") buffer
    for_ stderr \err ->
      case jsonParser err >>= decodeJson >>= parsePsaResult of
        Left _ -> Console.error err
        Right out -> do
          files <- STMap.new
          let loadLinesImpl = if showSource then loadLines files else loadNothing
              filenames = insertFilenames (insertFilenames Set.empty out.errors) out.warnings
          merged <- mergeWarnings filenames stashData.date stashData.stash out.warnings
          when stash $ writeStashFile stashFile merged
          out' <- output loadLinesImpl opts' out { warnings = merged }
          if jsonErrors
            then JsonPrinter.print out'
            else DefaultPrinter.print opts' out'
          if StrMap.isEmpty out'.stats.allErrors
            then Process.exit 0
            else Process.exit 1

  where
  insertFilenames = foldr \x s -> maybe s (flip Set.insert s) x.filename
  stdio = [ Just Child.Pipe, unsafePartial (Array.unsafeIndex Child.inherit 1), Just Child.Pipe ]
  loadNothing _ _ = pure Nothing

  spawn' cmd args onExit = do
    child <- Child.spawn cmd args Child.defaultSpawnOptions { stdio = stdio }
    buffer <- ST.newSTRef ""
    Stream.onDataString (Child.stderr child) Encoding.UTF8 \chunk ->
      void $ ST.modifySTRef buffer (_ <> chunk)
    Child.onExit child \status ->
      case status of
        Child.Normally n -> do
          ST.readSTRef buffer >>= onExit
          Process.exit n
        Child.BySignal s -> do
          Console.error (show s)
          Process.exit 1
    Child.onError child (retryWithCmd cmd args onExit)

  retryWithCmd cmd args onExit err
    | err.code == "ENOENT" = do
     -- On windows, if the executable wasn't found, try adding .cmd
     if Process.platform == Win32
       then
         case Str.stripSuffix (Str.Pattern ".cmd") cmd of
           Nothing      -> spawn' (cmd <> ".cmd") args onExit
           Just bareCmd -> throw $ "`" <> bareCmd <> "` executable not found. (nor `" <> cmd <> "`)"
       else
         throw $ "`" <> cmd <> "` executable not found."
    | otherwise =
       throwException (Child.toStandardError err)

  -- TODO: Handle exceptions
  loadLines files filename pos = do
    contents <- STMap.peek files filename >>= \cache ->
      case cache of
        Just lines -> pure lines
        Nothing -> do
          lines <- Str.split (Str.Pattern "\n") <$> File.readTextFile Encoding.UTF8 filename
          _ <- STMap.poke files filename lines
          pure lines
    let source = Array.slice (pos.startLine - 1) (pos.endLine) contents
    pure $ Just source

  decodeStash s = jsonParser s >>= decodeJson >>= traverse parsePsaError
  encodeStash s = encodeJson (encodePsaError <$> s)

  emptyStash :: forall a e. Eff (now :: NOW | e) { date :: DateTime, stash :: Array a }
  emptyStash = { date: _ , stash: [] } <$> toDateTime <$> now

  readStashFile stashFile = catchException (const emptyStash) do
    stat <- File.stat stashFile
    file <- File.readTextFile Encoding.UTF8 stashFile
    case decodeStash file of
      Left _ -> emptyStash
      Right stash -> pure { date: Stats.modifiedTime stat, stash }

  writeStashFile stashFile warnings = do
    let file = stringify (encodeStash warnings)
    File.writeTextFile Encoding.UTF8 stashFile file

  mergeWarnings filenames date old new = do
    fileStat <- STMap.new
    old' <- flip Array.filterA old \x ->
      case x.filename of
        Nothing -> pure false
        Just f ->
          if Set.member f filenames
            then pure false
            else do
              stat <- STMap.peek fileStat f
              case stat of
                Just s -> pure s
                Nothing -> do
                  s <- catchException (\_ -> pure false) $
                    (date > _) <<< Stats.modifiedTime <$> File.stat f
                  _ <- STMap.poke fileStat f s
                  pure s
    pure $ old' <> new

usage :: String
usage = """psa - Error/Warning reporting frontend for 'purs compile'

Usage: psa [--censor-lib] [--censor-src]
           [--censor-codes=CODES] [--filter-codes=CODES]
           [--no-colors] [--no-source]
           [--is-lib=DIR] [--purs=PURS] [--stash]
           PSC_OPTIONS

Available options:
  -v,--version           Show the version number
  -h,--help              Show this help text
  --verbose-stats        Show counts for each warning type
  --censor-stats         Censor warning/error summary
  --censor-warnings      Censor all warnings
  --censor-lib           Censor warnings from library sources
  --censor-src           Censor warnings from project sources
  --censor-codes=CODES   Censor specific error codes
  --filter-codes=CODES   Only show specific error codes
  --no-colors            Disable ANSI colors
  --no-source            Disable original source code printing
  --strict               Promotes src warnings to errors
  --stash                Enable persistent warnings (defaults to .psa-stash)
  --stash=FILE           Enable persistent warnings using a specific stash file
  --is-lib=DIR           Distinguishing library path (defaults to 'bower_components')
  --purs=PURS            Name of purs executable (defaults to 'purs')

  CODES                  Comma-separated list of purs error codes
  PSC_OPTIONS            Any extra options are passed to 'purs compile'
"""

module Main where

import Prelude
import Data.Argonaut.Core (stringify)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Encode (encodeJson)
import Data.Array as Array
import Data.DateTime (DateTime)
import Data.DateTime.Instant (toDateTime)
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.Traversable (traverse)
import Data.StrMap as StrMap
import Data.StrMap.ST as STMap
import Data.Maybe (Maybe(..), maybe)
import Data.Set as Set
import Data.String as Str
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Control.Monad.Eff.Exception (EXCEPTION, catchException, throw, throwException)
import Control.Monad.Eff.Now (NOW, now)
import Control.Monad.ST (ST)
import Control.Monad.ST as ST
import Node.Platform (Platform(Win32))
import Node.Process (PROCESS)
import Node.Process as Process
import Node.ChildProcess (CHILD_PROCESS)
import Node.ChildProcess as Child
import Node.Stream as Stream
import Node.Buffer (BUFFER)
import Node.Encoding as Encoding
import Node.FS (FS)
import Node.FS.Sync as File
import Node.FS.Stats as Stats
import Node.Path as Path
import Partial.Unsafe (unsafePartial)
import Psa (PsaOptions, StatVerbosity(..), parsePsaResult, parsePsaError, encodePsaError, output)
import Psa.Printer.Default as DefaultPrinter
import Psa.Printer.Json as JsonPrinter

foreign import version :: String

defaultOptions :: PsaOptions
defaultOptions =
  { ansi: true
  , censorWarnings: false
  , censorLib: false
  , censorSrc: false
  , censorCodes: Set.empty
  , filterCodes: Set.empty
  , statVerbosity: CompactStats
  , libDirs: []
  , strict: false
  , cwd: ""
  }

type ParseOptions =
  { extra :: Array String
  , opts :: PsaOptions
  , purs :: String
  , showSource :: Boolean
  , stash :: Boolean
  , stashFile :: String
  , jsonErrors :: Boolean
  }

parseOptions
  :: forall eff
   . PsaOptions
  -> Array String
  -> Eff (console :: CONSOLE, process :: PROCESS | eff) ParseOptions
parseOptions opts args =
  defaultLibDir <$>
    Array.foldM parse
      { extra: []
      , purs: "purs"
      , showSource: true
      , stash: false
      , stashFile: ".psa-stash"
      , jsonErrors: false
      , opts
      }
      args
  where
  parse p arg
    | arg == "--version" || arg == "-v" =
      Console.log version *> Process.exit 0

    | arg == "--help" || arg == "-h" =
      Console.log usage *> Process.exit 0

    | arg == "--stash" =
      pure p { stash = true }

    | arg == "--json-errors" =
      pure p { jsonErrors = true }

    | arg == "--no-source" =
      pure p { showSource = false }

    | arg == "--no-colors" || arg == "--monochrome" =
      pure p { opts = p.opts { ansi = false } }

    | arg == "--verbose-stats" =
      pure p { opts = p.opts { statVerbosity = VerboseStats } }

    | arg == "--censor-stats" =
      pure p { opts = p.opts { statVerbosity = NoStats } }

    | arg == "--strict" =
      pure p { opts = p.opts { strict = true } }

    | arg == "--censor-warnings" =
      pure p { opts = p.opts { censorWarnings = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-src" =
      pure p { opts = p.opts { censorSrc = true } }

    | isPrefix "--censor-codes=" arg =
      pure p { opts = p.opts { censorCodes = foldr Set.insert p.opts.censorCodes (Str.split (Str.Pattern ",") (Str.drop 15 arg)) } }

    | isPrefix "--filter-codes=" arg =
      pure p { opts = p.opts { filterCodes = foldr Set.insert p.opts.filterCodes (Str.split (Str.Pattern ",") (Str.drop 15 arg)) } }

    | isPrefix "--is-lib=" arg =
      pure p { opts = p.opts { libDirs = Array.snoc p.opts.libDirs (Str.drop 9 arg) } }

    | isPrefix "--purs=" arg =
      pure p { purs = Str.drop 7 arg }

    | isPrefix "--stash=" arg =
      pure p { stash = true, stashFile = Str.drop 8 arg }

    | otherwise = pure p { extra = Array.snoc p.extra arg }

  isPrefix s str =
    case Str.indexOf (Str.Pattern s) str of
      Just x | x == 0 -> true
      _               -> false

  defaultLibDir x
    | Array.length x.opts.libDirs == 0 =
      x { opts = x.opts { libDirs = [ "bower_components" ] } }
    | otherwise = x

type MainEff h eff =
  ( process :: PROCESS
  , console :: CONSOLE
  , buffer :: BUFFER
  , exception :: EXCEPTION
  , fs :: FS
  , cp :: CHILD_PROCESS
  , st :: ST h
  , now :: NOW
  | eff
  )

main :: forall h eff. Eff (MainEff h eff) Unit
main = void do
  cwd <- Process.cwd
  argv <- Array.drop 2 <$> Process.argv

  { extra
  , opts
  , purs
  , showSource
  , stash
  , stashFile
  , jsonErrors
  } <- parseOptions (defaultOptions { cwd = cwd }) argv

  let opts' = opts { libDirs = (_ <> Path.sep) <<< Path.resolve [cwd] <$> opts.libDirs }
      args  = Array.cons "compile" $ Array.cons "--json-errors" extra

  stashData <-
    if stash
      then readStashFile stashFile
      else emptyStash

  spawn' purs args \buffer -> do
    let stderr = Str.split (Str.Pattern "\n") buffer
    for_ stderr \err ->
      case jsonParser err >>= decodeJson >>= parsePsaResult of
        Left _ -> Console.error err
        Right out -> do
          files <- STMap.new
          let loadLinesImpl = if showSource then loadLines files else loadNothing
              filenames = insertFilenames (insertFilenames Set.empty out.errors) out.warnings
          merged <- mergeWarnings filenames stashData.date stashData.stash out.warnings
          when stash $ writeStashFile stashFile merged
          out' <- output loadLinesImpl opts' out { warnings = merged }
          if jsonErrors
            then JsonPrinter.print out'
            else DefaultPrinter.print opts' out'
          if StrMap.isEmpty out'.stats.allErrors
            then Process.exit 0
            else Process.exit 1

  where
  insertFilenames = foldr \x s -> maybe s (flip Set.insert s) x.filename
  stdio = [ Just Child.Pipe, unsafePartial (Array.unsafeIndex Child.inherit 1), Just Child.Pipe ]
  loadNothing _ _ = pure Nothing

  spawn' cmd args onExit = do
    child <- Child.spawn cmd args Child.defaultSpawnOptions { stdio = stdio }
    buffer <- ST.newSTRef ""
    Stream.onDataString (Child.stderr child) Encoding.UTF8 \chunk ->
      void $ ST.modifySTRef buffer (_ <> chunk)
    Child.onExit child \status ->
      case status of
        Child.Normally n -> do
          ST.readSTRef buffer >>= onExit
          Process.exit n
        Child.BySignal s -> do
          Console.error (show s)
          Process.exit 1
    Child.onError child (retryWithCmd cmd args onExit)

  retryWithCmd cmd args onExit err
    | err.code == "ENOENT" = do
     -- On windows, if the executable wasn't found, try adding .cmd
     if Process.platform == Win32
       then
         case Str.stripSuffix (Str.Pattern ".cmd") cmd of
           Nothing      -> spawn' (cmd <> ".cmd") args onExit
           Just bareCmd -> throw $ "`" <> bareCmd <> "` executable not found. (nor `" <> cmd <> "`)"
       else
         throw $ "`" <> cmd <> "` executable not found."
    | otherwise =
       throwException (Child.toStandardError err)

  -- TODO: Handle exceptions
  loadLines files filename pos = do
    contents <- STMap.peek files filename >>= \cache ->
      case cache of
        Just lines -> pure lines
        Nothing -> do
          lines <- Str.split (Str.Pattern "\n") <$> File.readTextFile Encoding.UTF8 filename
          _ <- STMap.poke files filename lines
          pure lines
    let source = Array.slice (pos.startLine - 1) (pos.endLine) contents
    pure $ Just source

  decodeStash s = jsonParser s >>= decodeJson >>= traverse parsePsaError
  encodeStash s = encodeJson (encodePsaError <$> s)

  emptyStash :: forall a e. Eff (now :: NOW | e) { date :: DateTime, stash :: Array a }
  emptyStash = { date: _ , stash: [] } <$> toDateTime <$> now

  readStashFile stashFile = catchException (const emptyStash) do
    stat <- File.stat stashFile
    file <- File.readTextFile Encoding.UTF8 stashFile
    case decodeStash file of
      Left _ -> emptyStash
      Right stash -> pure { date: Stats.modifiedTime stat, stash }

  writeStashFile stashFile warnings = do
    let file = stringify (encodeStash warnings)
    File.writeTextFile Encoding.UTF8 stashFile file

  mergeWarnings filenames date old new = do
    fileStat <- STMap.new
    old' <- flip Array.filterA old \x ->
      case x.filename of
        Nothing -> pure false
        Just f ->
          if Set.member f filenames
            then pure false
            else do
              stat <- STMap.peek fileStat f
              case stat of
                Just s -> pure s
                Nothing -> do
                  s <- catchException (\_ -> pure false) $
                    (date > _) <<< Stats.modifiedTime <$> File.stat f
                  _ <- STMap.poke fileStat f s
                  pure s
    pure $ old' <> new

usage :: String
usage = """psa - Error/Warning reporting frontend for 'purs compile'

Usage: psa [--censor-lib] [--censor-src]
           [--censor-codes=CODES] [--filter-codes=CODES]
           [--no-colors] [--no-source]
           [--is-lib=DIR] [--purs=PURS] [--stash]
           PSC_OPTIONS

Available options:
  -v,--version           Show the version number
  -h,--help              Show this help text
  --verbose-stats        Show counts for each warning type
  --censor-stats         Hide counts for warning types
  --censor-warnings      Censor all warnings
  --censor-lib           Censor warnings from library sources
  --censor-src           Censor warnings from project sources
  --censor-codes=CODES   Censor specific error codes
  --filter-codes=CODES   Only show specific error codes
  --no-colors            Disable ANSI colors
  --no-source            Disable original source code printing
  --strict               Promotes src warnings to errors
  --stash                Enable persistent warnings (defaults to .psa-stash)
  --stash=FILE           Enable persistent warnings using a specific stash file
  --is-lib=DIR           Distinguishing library path (defaults to 'bower_components')
  --purs=PURS            Name of purs executable (defaults to 'purs')

  CODES                  Comma-separated list of purs error codes
  PSC_OPTIONS            Any extra options are passed to 'purs compile'
"""


Comparison to objects using constructor reflection to prevent browser-namespace problem.  Implementation also prevents dead code elimination of ctrs.

module Data.Foreign.Options
  ( Options()
  , toOptions
  )
where

import Data.Either
import Data.Maybe
import Data.Function

foreign import data Options :: *

foreign import toOptionsImpl
  "function toOptionsImpl(l, r, j, n, record) { \
  \\
  \  var applyArgs = function(f, args) { \
  \    return (args.length == 0) ? f : applyArgs(f(args.shift()), args); \
  \  }; \
  \\
  \  var convert = function(value) { \
  \    var ctr = value.constructor; \
  \    if (ctr === l.constructor || \
  \        ctr === r.constructor || \
  \        ctr === j.constructor) { \
  \      return convert(value.value0); \
  \    } else if (value === n) { \
  \      return null; \
  \    } else if (typeof value === \"function\") { \
  \      return function() { \
  \               var argArray = [].slice.call(arguments);\
  \               return applyArgs(value, argArray); \
  \             }; \
  \    } else if (typeof value === \"object\") { \
  \      return toOptionsImpl(l, r, j, n, value); \
  \    } else { \
  \      return value; \
  \    } \
  \  }; \
  \\
  \  var optsRecord = {}; \
  \  for (var field in record) { \
  \    var convValue = convert(record[field]); \
  \    if (convValue != null) { \
  \      optsRecord[field] = convValue; \
  \    } \
  \  } \
  \\
  \  return optsRecord; \
  \}" :: forall a b c. Fn5 (Either b b) (Either b b) (Maybe b) (Maybe b) a c

toOptions :: forall a. {|a} -> Options
toOptions record = runFn5 toOptionsImpl (Left {}) (Right {}) (Just {}) (Nothing) record

module Data.Foreign.Options
  ( Options()
  , toOptions
  )
where

import Data.Either
import Data.Maybe
import Data.Function

foreign import data Options :: *

foreign import toOptionsImpl
  "function toOptionsImpl(record) { \
  \\
  \  var applyArgs = function(f, args) { \
  \    return (args.length == 0) ? f : applyArgs(f(args.shift()), args); \
  \  }; \
  \\
  \  var convert = function(value) { \
  \\
  \    if (value instanceof PS.Data_Either.Left || \
  \        value instanceof PS.Data_Either.Right || \
  \        value instanceof PS.Data_Maybe.Just) { \
  \      return convert(value.value0); \
  \    } else if (value instanceof PS.Data_Maybe.Nothing) { \
  \      return null; \
  \    } else if (typeof value === \"function\") { \
  \      return function() { \
  \               var argArray = [].slice.call(arguments);\
  \               return applyArgs(value, argArray); \
  \             }; \
  \    } else if (typeof value === \"object\") { \
  \      return toOptionsImpl(value); \
  \    } else { \
  \      return value; \
  \    } \
  \  }; \
  \\
  \  var optsRecord = {}; \
  \  for (var field in record) { \
  \    var convValue = convert(record[field]); \
  \    if (convValue != null) { \
  \      optsRecord[field] = convValue; \
  \    } \
  \  } \
  \\
  \  return optsRecord; \
  \}" :: forall a b. Fn1 a b

toOptions :: forall a. {|a} -> Options
toOptions = runFn1 toOptionsImpl