Added keyboard tracking to Main module.

Added keyboard tracking to Main module.

-- | The application entry point
module Main where

import Prelude
import Jundo.Rendering
import Jundo.Simulation
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.ST
import Data.Date (Now(), nowEpochMilliseconds)
import Data.Time (Milliseconds(..))
import Data.Maybe
import Data.Nullable
import qualified DOM as D
import qualified DOM.Event.EventTarget as D
import qualified DOM.Event.Experimental as D
import qualified DOM.Event.KeyboardEvent as D
import qualified DOM.Event.MouseEvent as D
import qualified DOM.Event.Types (KeyboardEvent(), MouseEvent()) as D
import qualified DOM.HTML as D
import qualified DOM.HTML.Types as D
import qualified DOM.HTML.Window as D
import qualified DOM.Node.Document.Experimental as D
import qualified DOM.Node.Element as D
import qualified DOM.Node.Element.Experimental as D
import qualified DOM.Node.Types as D
import qualified DOM.RequestAnimationFrame as D
import Graphics.Canvas (Canvas(), getCanvasElementById)
import Graphics.Canvas.Element

-- | Type for tracking which keys are currently depressed
type KeyboardState = {w :: Boolean, a :: Boolean, s :: Boolean, d :: Boolean}

-- Type for passing application state between event listeners and the render loop
type AppState = {keyboard :: KeyboardState, simulation :: SimulationState}

modifyKeyboardState :: (KeyboardState -> KeyboardState) -> AppState -> AppState
modifyKeyboardState f state = {keyboard: f state.keyboard, simulation: state.simulation}

modifySimulationState :: (SimulationState -> SimulationState) -> AppState -> AppState
modifySimulationState f state = {keyboard: state.keyboard, simulation: f state.simulation}

-- | Handle canvas mousemove events by updating the simulation state.
canvasMousemove :: forall eff h. STRef h AppState -> D.MouseEvent -> Eff (dom :: D.DOM, st :: ST h | eff) Unit
canvasMousemove stateRef e = do
  return unit

-- | Monitor canvas keydown events so we can track which keys are depressed
canvasKeyDown :: forall eff h. STRef h AppState -> D.KeyboardEvent -> Eff (dom :: D.DOM, st :: ST h | eff) Unit
canvasKeyDown stateRef e | D.keyCode e == D.wKeyCode = do
  modifySTRef stateRef $ modifyKeyboardState \ks -> {w: true, a : ks.a, d: ks.d, s: ks.s}
  return unit
canvasKeyDown stateRef e | D.keyCode e == D.aKeyCode = do
  modifySTRef stateRef $ modifyKeyboardState \ks -> {w: ks.w, a : true, d: ks.d, s: ks.s}
  return unit
canvasKeyDown stateRef e | D.keyCode e == D.dKeyCode = do
  modifySTRef stateRef $ modifyKeyboardState \ks -> {w: ks.w, a : ks.a, d: true, s: ks.s}
  return unit
canvasKeyDown stateRef e | D.keyCode e == D.sKeyCode = do
  modifySTRef stateRef $ modifyKeyboardState \ks -> {w: ks.w, a : ks.a, d: ks.d, s: true}
  return unit
canvasKeyDown stateRef _ = return unit

-- | Monitor canvas keyup events so we can track which keys are depressed
canvasKeyUp :: forall eff h. STRef h AppState -> D.KeyboardEvent -> Eff (dom :: D.DOM, st :: ST h | eff) Unit
canvasKeyUp stateRef e | D.keyCode e == D.wKeyCode = do
  modifySTRef stateRef $ modifyKeyboardState \ks -> {w: false, a : ks.a, d: ks.d, s: ks.s}
  return unit
canvasKeyUp stateRef e | D.keyCode e == D.aKeyCode = do
  modifySTRef stateRef $ modifyKeyboardState \ks -> {w: ks.w, a : false, d: ks.d, s: ks.s}
  return unit
canvasKeyUp stateRef e | D.keyCode e == D.dKeyCode = do
  modifySTRef stateRef $ modifyKeyboardState \ks -> {w: ks.w, a : ks.a, d: false, s: ks.s}
  return unit
canvasKeyUp stateRef e | D.keyCode e == D.sKeyCode = do
  modifySTRef stateRef $ modifyKeyboardState \ks -> {w: ks.w, a : ks.a, d: ks.d, s: false}
  return unit
canvasKeyUp stateRef _ = return unit

-- | Handle canvas clicks. If we are not in full screen, open the canvas in full screen.
-- | Otherwise, toggle the direction of the cube's rotation.
canvasClick :: forall eff h. STRef h AppState -> D.Element -> D.MouseEvent -> Eff (dom :: D.DOM, st :: ST h | eff) Unit
canvasClick stateRef el _ = do
  maybeFullscreenEl <- D.window >>= D.document >>= pure <<< D.htmlDocumentToDocument >>= D.fullscreenElement >>= pure <<< toMaybe
  case maybeFullscreenEl of
    Nothing -> do
      D.requestFullscreen el
      D.requestPointerLock el
    -- TODO: Check that the fullscreen element is our canvas
    Just fullscreenEl -> do
      modifySTRef stateRef $ modifySimulationState toggleDirection
      return unit

-- | Main loop. Steps the simulation state forwards in time then renders the new state.
tick :: forall eff h. RenderingContext -> STRef h AppState -> Milliseconds -> Eff (canvas :: Canvas, dom :: D.DOM, now :: Now, st :: ST h | eff) Unit
tick ctx stateRef time = do
  newTime <- nowEpochMilliseconds
  state <- modifySTRef stateRef $ modifySimulationState (timestep (newTime - time))
  render ctx state.simulation
  D.requestAnimationFrame $ tick ctx stateRef newTime

-- | Start the application: set up the canvas and start the render loop
main :: Eff (canvas :: Canvas, dom :: D.DOM, err :: EXCEPTION, now :: Now) Unit
main = do
  Just canvas <- getCanvasElementById "easel"
  el <- pure $ toElement canvas
  renderingContext <- initialiseWebGL el canvas
  time <- nowEpochMilliseconds
  elEventTarget <- pure $ D.elementToEventTarget el

  -- Aaa mutable state!
  -- The event listeners need to update the state read by the render loop somehow, so let's use a mutable reference cell
  runST do
    stateRef <- newSTRef {simulation: initialSimulationState, keyboard: {w: false, a: false, s: false, d: false}}
    mousemoveEventListener <- pure $ D.mouseEventListener (canvasMousemove stateRef)
    clickEventListener <- pure $ D.mouseEventListener (canvasClick stateRef el)
    D.addMouseEventListener D.click clickEventListener false elEventTarget
    tick renderingContext stateRef time

-- | The application entry point
module Main where

import Prelude
import Jundo.Rendering
import Jundo.Simulation
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.ST
import Data.Date (Now(), nowEpochMilliseconds)
import Data.Time (Milliseconds(..))
import Data.Maybe
import Data.Nullable
import qualified DOM as D
import qualified DOM.Event.EventTarget as D
import qualified DOM.Event.Experimental as D
import qualified DOM.Event.MouseEvent as D
import qualified DOM.Event.Types (MouseEvent()) as D
import qualified DOM.HTML as D
import qualified DOM.HTML.Types as D
import qualified DOM.HTML.Window as D
import qualified DOM.Node.Document.Experimental as D
import qualified DOM.Node.Element as D
import qualified DOM.Node.Element.Experimental as D
import qualified DOM.Node.Types as D
import qualified DOM.RequestAnimationFrame as D
import Graphics.Canvas (Canvas(), getCanvasElementById)
import Graphics.Canvas.Element

-- | Handle canvas clicks. If we are not in full screen, open the canvas in full screen.
-- | Otherwise, toggle the direction of the cube's rotation.
canvasClick :: forall eff h. STRef h SimulationState -> D.Element -> D.MouseEvent -> Eff (dom :: D.DOM, st :: ST h | eff) Unit
canvasClick stateRef el _ = do
  maybeFullscreenEl <- D.window >>= D.document >>= pure <<< D.htmlDocumentToDocument >>= D.fullscreenElement >>= pure <<< toMaybe
  case maybeFullscreenEl of
    Nothing -> do
      D.requestFullscreen el
      D.requestPointerLock el
    -- TODO: Check that the fullscreen element is our canvas
    Just fullscreenEl -> do
      modifySTRef stateRef toggleDirection
      return unit

-- | Main loop. Steps the simulation state forwards in time then renders the new state.
tick :: forall eff h. RenderingContext -> STRef h SimulationState -> Milliseconds -> Eff (canvas :: Canvas, dom :: D.DOM, now :: Now, st :: ST h | eff) Unit
tick ctx stateRef time = do
  newTime <- nowEpochMilliseconds
  state <- modifySTRef stateRef $ timestep (newTime - time)
  render ctx state
  D.requestAnimationFrame $ tick ctx stateRef newTime

-- | Start the application: set up the canvas and start the render loop
main :: Eff (canvas :: Canvas, dom :: D.DOM, err :: EXCEPTION, now :: Now) Unit
main = do
  Just canvas <- getCanvasElementById "easel"
  el <- pure $ toElement canvas
  renderingContext <- initialiseWebGL el canvas
  time <- nowEpochMilliseconds
  elEventTarget <- pure $ D.elementToEventTarget $ el

  -- Aaa mutable state!
  -- The event listener needs to update the state read by the render loop somehow, so let's use a mutable reference cell
  runST do
    stateRef <- newSTRef initialSimulationState
    D.addMouseEventListener D.click (D.mouseEventListener $ canvasClick stateRef el) false elEventTarget
    tick renderingContext stateRef time


Added message buffer

Added message buffer

module Main where

import Data.Char
import Data.String hiding (length, drop)
import Data.Maybe
import Data.Tuple
import Data.Array ((!!), (..), map, updateAt, modifyAt, range, length, head, filter, drop)
import Data.Foldable
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace

import Graphics.CanvasConsole
import GameData
import Utils
import Level

strlen = Data.String.length

data GameState = Game { level         :: Level
                      , player        :: Creature
                      , npcs          :: [Creature]
                      , items         :: [Item]
                      , playerName    :: String
                      , points        :: Number
                      , inventory     :: [Item]
                      , freeFallTimer :: Number
                      , messageBuf    :: [String]
                      }
               | MainMenu
               | NameCreation { playerName :: String }
               | CharCreation { playerName :: String }

initialState :: String -> GameState
initialState pname = Game
        { level: stringToLevel testLevel
        , player: pl
        , npcs: [testGuard]
        , items: [testItem1, testItem2]
        , playerName: pname
        , points: 0
        , inventory: []
        , freeFallTimer: 0
        , messageBuf: map ((++) "Line" <<< show) (1 .. 4)
        }
    where
        pl :: Creature
        pl = { pos: {x: 4, y: 3}, ctype: Player, stats: defaultStats, speed: 1000, time: 0, vel: zero }

        testGuard = { pos: {x: 10, y: 4}, ctype: Guard, stats: defaultStats, speed: 500, time: 0, vel: zero }
        testItem1 = { itemType: Weapon { dmg: 1, attackBonus: 1 }, pos: {x: 6, y: 4}, vel: {x: 0, y: 0}, weight: 4 }
        testItem2 = { itemType: Loot { value: 3 }, pos: {x: 6, y: 3}, vel: {x: 0, y: 0}, weight: 1 }

messageBufSize :: Number
messageBufSize = 4

addMsg :: String -> GameState -> GameState
addMsg msg (Game state) | length state.messageBuf >= messageBufSize =
    Game state { messageBuf = drop 1 state.messageBuf ++ [msg] }
addMsg msg (Game state) | otherwise =Game state { messageBuf = state.messageBuf ++ [msg] }

onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt g@(Game state) | inFreeFall state.level state.player && state.freeFallTimer > 0.1 =
    drawGame console <<< updateWorld (calcSpeed g state.player) $ Game state { freeFallTimer = 0 }
onUpdate console dt g@(Game state) | otherwise =
    drawGame console $ Game state { freeFallTimer = state.freeFallTimer + dt }
onUpdate console _ g = drawGame console g

drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console g@(Game state) = do
    clear console
    mapM_ (\p -> drawTile p (getTile state.level p)) (levelPoints state.level)
    mapM_ drawCreature state.npcs
    mapM_ drawItem state.items
    drawCreature state.player
    drawString console (state.playerName) "FF0000" 2 23
    drawString console ("HP: " ++ (show (state.player.stats.hp))) "FF0000" 2 24
    drawString console ("Points: " ++ (show (state.points))) "FF0000" 10 24
    drawStrings {x: 1, y: 20} "FFFFFF" state.messageBuf
    return g
    where
        drawStrings :: Point -> String -> [String] -> ConsoleEff Unit
        drawStrings p col (x:xs) = drawString console x col p.x p.y
                                >> drawStrings {x: p.x, y: p.y + 1} col xs
        drawStrings _  _  []     = return unit

        drawCreature :: Creature -> ConsoleEff Unit
        drawCreature c = drawCreatureType c.pos c.ctype

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

        drawItem :: Item -> ConsoleEff Unit
        drawItem i = drawItemType i.pos i.itemType

        drawItemType :: Point -> ItemType -> ConsoleEff Unit
        drawItemType p (Loot _)   = drawChar console "$" "FFAA00" p.x p.y
        drawItemType p (Weapon _) = drawChar console "/" "AAAAAA" p.x p.y

        drawTile :: Point -> Maybe Tile -> ConsoleEff Unit
        drawTile p (Just Air)        = drawChar console "." "FFFFFF" p.x p.y
        drawTile p (Just Ground)     = drawChar console "#" "AAAAAA" p.x p.y
        drawTile p (Just Wall)       = drawChar console "#" "331A00" p.x p.y
        drawTile p (Just DoorLocked) = drawChar console "+" "331A00" p.x p.y
        drawTile p (Just DoorClosed) = drawChar console "+" "331A00" p.x p.y
        drawTile p (Just DoorOpen)   = drawChar console "|" "331A00" p.x p.y
        drawTile p _                 = drawChar console "?" "FFFFFF" p.x p.y
drawGame console MainMenu = do
    clear console
    drawString console "RobberyRL" "FFFFFF" 12 5
    drawString console "Press enter to start your adventure" "AAAAAA" 6 12
    return MainMenu
drawGame console (NameCreation {playerName = pname}) = do
    clear console
    drawString console "What is your name? (max 15 characters):" "FF0000" 4 4
    drawString console pname "FF0000" 6 6
    drawString console "Press enter to continue" "FF0000" 4 8
    return (NameCreation {playerName: pname})
drawGame console (CharCreation {playerName = pname}) = do
    clear console
    drawString console ("Character Creation:   " ++ pname) "FF0000" 2 2

    drawString console "Press a to enter game" "FF0000" 2 20

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

    --drawString console "Prefix:" "FF0000" 46 13
    --drawString console "j) Strong (+1 str)" "336600" 47 15
    --drawString console "k) Weak   (-1 str)" "FF0000" 47 16
    --drawString console "l) Agile  (+1 dex)" "336600" 47 17
    --drawString console "m) Clumsy (-1 dex)" "FF0000" 47 18
    --drawString console "n) Wise   (+1 int)" "336600" 47 19
    --drawString console "q) Dumb   (-1 int)" "FF0000" 47 20
    return (CharCreation {playerName: pname})

-- Updates all npcs.
updateCreatures :: Number -> GameState -> GameState
updateCreatures advance g@(Game state') =
    foldl (\g' i -> updateCreature i (advTime i g')) g (0 .. (length state'.npcs - 1))
    where
        -- Updaters are not allowed to remove creatures.
        -- Dead creatures will be cleaned up later.

        -- Advances game time for creature at index i.
        advTime :: Number -> GameState -> GameState
        advTime i game = modifyCreatureAt i game $ \c -> c { time = c.time + advance }

        -- Gets creature information from creature at index i.
        get :: forall a. Number -> GameState -> a -> (Creature -> a) -> a
        get i (Game state) d getter = fromMaybe d $ getter <$> state.npcs !! i

        -- Modify creature at index i with a function.
        modifyCreatureAt :: Number -> GameState -> (Creature -> Creature) -> GameState
        modifyCreatureAt i (Game state) f = Game state { npcs = modifyAt i f state.npcs }

        -- Updates creature at index i until it runs out of time.
        updateCreature :: Number -> GameState -> GameState
        updateCreature i game | get i game 0 (\c -> c.time) >= get i game 0 (calcSpeed game) =
            updateCreature i (modifyCreatureAt i (updateCreatureOnce i game) (\c -> c { time = c.time - calcSpeed game c }))
        updateCreature i game | otherwise = game

        -- Creature at index i does a single action.
        updateCreatureOnce :: Number -> GameState -> GameState
        updateCreatureOnce i game = modifyCreatureAt i game $ updatePhysics game

updatePhysics :: forall r. GameState -> { pos :: Point, vel :: Point | r } -> { pos :: Point, vel :: Point | r }
updatePhysics g@(Game state) c | inFreeFall state.level c = move g fc (unitp fc.vel)
    where
        projectedMovement p = p.pos .+. unitp p.vel

        -- 1. update gravity
        gc = c { vel = { x: c.vel.x, y: c.vel.y + 1 } }

        -- 2. check collision
        newpos = projectedMovement gc
        blocked = not $ isValidMove state.level newpos
        finalVelX = if blocked then 0 else gc.vel.x

        -- 3. calculate final velocity
        fc = c { vel = { x: finalVelX, y: gc.vel.y } }

updatePhysics _ c = c { vel = zero}

move :: forall r. GameState -> { pos :: Point | r } -> Point -> { pos :: Point | r }
move (Game state) c delta =
    if blocked then c else c { pos = newpos }
    where
        newpos  = clampPos $ c.pos .+. delta
        blocked = not $ isValidMove state.level newpos

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

updateWorld :: Number -> GameState -> GameState
updateWorld advance = updateCreatures advance
    >>> (\(Game state) -> Game state { player = updatePhysics (Game state) state.player })
    >>> (\(Game state) -> Game state { items = map (updatePhysics (Game state)) state.items })

inFreeFall :: forall r. Level -> { pos :: Point | r } -> Boolean
inFreeFall level c = isValidMove level (c.pos .+. {x:0, y: 1})

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

-- todo: item weight should affect player
calcSpeed :: GameState -> Creature -> Number
calcSpeed (Game state) c | inFreeFall state.level c = 500
calcSpeed (Game state) c | otherwise                = c.speed

movePlayer :: Point -> GameState -> GameState
movePlayer delta g@(Game state) =
    if canMove then
        updateWorld (calcSpeed g state.player) $ Game state { player = move (Game state) state.player delta }
        else Game state
    where
        newpos  = state.player.pos .+. delta
        canMove = isValidMove state.level newpos

jump :: GameState -> Number -> Creature -> Creature
jump g xdir c = move g (c { vel = {x: xdir, y: -2} }) {x: xdir, y: -1}

movementkeys :: M.Map Number Point
movementkeys = M.fromList [numpad 8 // {x:  0, y: -1}
                          ,numpad 2 // {x:  0, y:  1}
                          ,numpad 4 // {x: -1, y:  0}
                          ,numpad 6 // {x:  1, y:  0}
                          ,numpad 5 // {x:  0, y:  0}]

pickUp :: Point -> GameState -> GameState
pickUp point (Game state) =
    case head (filter (\i -> i.pos .==. point) state.items) of
        Just item -> Game state { items = deleteItem state.items point, inventory = addItem state.inventory item }
        Nothing   -> Game state
    where
        deleteItem :: [Item] -> Point -> [Item]
        deleteItem (x:xs) delPos | x.pos .==. delPos = xs
        deleteItem (x:xs) delPos | otherwise = x : deleteItem xs delPos
        deleteItem [] _ = []

        addItem :: [Item] -> Item -> [Item]
        addItem xs { itemType = Loot { value = num } } = xs
        addItem xs x = x:xs

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console g@(Game state) _ | inFreeFall state.level state.player = return g
onKeyPress console g@(Game state) key                      | key == numpad 7 = return $ Game state { player = jump g (-1) state.player }
onKeyPress console g@(Game state) key                      | key == numpad 9 = return $ Game state { player = jump g 1 state.player }
onKeyPress console g@(Game state) key                      | key == 80       = return g
onKeyPress console g@(Game state) key =
    case M.lookup key movementkeys of
        Just delta -> drawGame console $ movePlayer delta g
        Nothing    -> return g

onKeyPress console MainMenu key                            | key == 13       = return $ NameCreation { playerName: "" }
onKeyPress console (NameCreation {playerName = pname}) key | key == 13       = return $ CharCreation { playerName: pname }
onKeyPress console (NameCreation {playerName = xs}) key    | key == 8        = return $ NameCreation { playerName: (take (strlen xs - 1) xs) }
onKeyPress console (NameCreation {playerName = ""}) key                      = return $ NameCreation { playerName: (fromCharArray [fromCharCode key]) }
onKeyPress console (NameCreation {playerName = xs}) key    | strlen xs > 15  = return $ NameCreation { playerName: xs }
onKeyPress console (NameCreation {playerName = xs}) key                      = return $ NameCreation { playerName: (xs ++ (fromCharArray [fromCharCode key])) }
onKeyPress console (CharCreation {playerName = xs}) key    | key == 65       = return $ initialState xs
onKeyPress _ st _ = return st

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

module Main where

import Data.Char
import Data.String hiding (length)
import Data.Maybe
import Data.Tuple
import Data.Array ((!!), (..), map, updateAt, modifyAt, range, length, head, filter)
import Data.Foldable
import qualified Data.Map as M
import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import Debug.Trace

import Graphics.CanvasConsole
import GameData
import Utils
import Level

strlen = Data.String.length

data GameState = Game { level         :: Level
                      , player        :: Creature
                      , npcs          :: [Creature]
                      , items         :: [Item]
                      , playerName    :: String
                      , points        :: Number
                      , inventory     :: [Item]
                      , freeFallTimer :: Number
                      }
               | MainMenu
               | NameCreation { playerName :: String }
               | CharCreation { playerName :: String }

initialState :: String -> GameState
initialState pname = Game
        { level: stringToLevel testLevel
        , player: pl
        , npcs: [testGuard]
        , items: [testItem1, testItem2]
        , playerName: pname
        , points: 0
        , inventory: []
        , freeFallTimer: 0
        }
    where
        pl :: Creature
        pl = { pos: {x: 4, y: 3}, ctype: Player, stats: defaultStats, speed: 1000, time: 0, vel: zero }

        testGuard = { pos: {x: 10, y: 4}, ctype: Guard, stats: defaultStats, speed: 500, time: 0, vel: zero }
        testItem1 = { itemType: Weapon { dmg: 1, attackBonus: 1 }, pos: {x: 6, y: 4}, vel: {x: 0, y: 0}, weight: 4 }
        testItem2 = { itemType: Loot { value: 3 }, pos: {x: 6, y: 3}, vel: {x: 0, y: 0}, weight: 1 }

onUpdate :: Console -> Number -> GameState -> ConsoleEff GameState
onUpdate console dt g@(Game state) | inFreeFall state.level state.player && state.freeFallTimer > 0.1 =
    drawGame console <<< updateWorld (calcSpeed g state.player) $ Game state { freeFallTimer = 0 }
onUpdate console dt g@(Game state) | otherwise =
    drawGame console $ Game state { freeFallTimer = state.freeFallTimer + dt }
onUpdate console _ g = drawGame console g

drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console g@(Game state) = do
    clear console
    mapM_ (\p -> drawTile p (getTile state.level p)) (levelPoints state.level)
    mapM_ drawCreature state.npcs
    mapM_ drawItem state.items
    drawCreature state.player
    drawString console (state.playerName) "FF0000" 2 23
    drawString console ("HP: " ++ (show (state.player.stats.hp))) "FF0000" 2 24
    drawString console ("Points: " ++ (show (state.points))) "FF0000" 10 24
    return g
    where
        drawCreature :: Creature -> ConsoleEff Unit
        drawCreature c = drawCreatureType c.pos c.ctype

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

        drawItem :: Item -> ConsoleEff Unit
        drawItem i = drawItemType i.pos i.itemType

        drawItemType :: Point -> ItemType -> ConsoleEff Unit
        drawItemType p (Loot _)   = drawChar console "$" "FFAA00" p.x p.y
        drawItemType p (Weapon _) = drawChar console "/" "AAAAAA" p.x p.y

        drawTile :: Point -> Maybe Tile -> ConsoleEff Unit
        drawTile p (Just Air)        = drawChar console "." "FFFFFF" p.x p.y
        drawTile p (Just Ground)     = drawChar console "#" "AAAAAA" p.x p.y
        drawTile p (Just Wall)       = drawChar console "#" "331A00" p.x p.y
        drawTile p (Just DoorLocked) = drawChar console "+" "331A00" p.x p.y
        drawTile p (Just DoorClosed) = drawChar console "+" "331A00" p.x p.y
        drawTile p (Just DoorOpen)   = drawChar console "|" "331A00" p.x p.y
        drawTile p _                 = drawChar console "?" "FFFFFF" p.x p.y
drawGame console MainMenu = do
    clear console
    drawString console "RobberyRL" "FFFFFF" 12 5
    drawString console "Press enter to start your adventure" "AAAAAA" 6 12
    return MainMenu
drawGame console (NameCreation {playerName = pname}) = do
    clear console
    drawString console "What is your name? (max 15 characters):" "FF0000" 4 4
    drawString console pname "FF0000" 6 6
    drawString console "Press enter to continue" "FF0000" 4 8
    return (NameCreation {playerName: pname})
drawGame console (CharCreation {playerName = pname}) = do
    clear console
    drawString console ("Character Creation:   " ++ pname) "FF0000" 2 2

    drawString console "Press a to enter game" "FF0000" 2 20

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

    --drawString console "Prefix:" "FF0000" 46 13
    --drawString console "j) Strong (+1 str)" "336600" 47 15
    --drawString console "k) Weak   (-1 str)" "FF0000" 47 16
    --drawString console "l) Agile  (+1 dex)" "336600" 47 17
    --drawString console "m) Clumsy (-1 dex)" "FF0000" 47 18
    --drawString console "n) Wise   (+1 int)" "336600" 47 19
    --drawString console "q) Dumb   (-1 int)" "FF0000" 47 20
    return (CharCreation {playerName: pname})

-- Updates all npcs.
updateCreatures :: Number -> GameState -> GameState
updateCreatures advance g@(Game state') =
    foldl (\g' i -> updateCreature i (advTime i g')) g (0 .. (length state'.npcs - 1))
    where
        -- Updaters are not allowed to remove creatures.
        -- Dead creatures will be cleaned up later.

        -- Advances game time for creature at index i.
        advTime :: Number -> GameState -> GameState
        advTime i game = modifyCreatureAt i game $ \c -> c { time = c.time + advance }

        -- Gets creature information from creature at index i.
        get :: forall a. Number -> GameState -> a -> (Creature -> a) -> a
        get i (Game state) d getter = fromMaybe d $ getter <$> state.npcs !! i

        -- Modify creature at index i with a function.
        modifyCreatureAt :: Number -> GameState -> (Creature -> Creature) -> GameState
        modifyCreatureAt i (Game state) f = Game state { npcs = modifyAt i f state.npcs }

        -- Updates creature at index i until it runs out of time.
        updateCreature :: Number -> GameState -> GameState
        updateCreature i game | get i game 0 (\c -> c.time) >= get i game 0 (calcSpeed game) =
            updateCreature i (modifyCreatureAt i (updateCreatureOnce i game) (\c -> c { time = c.time - calcSpeed game c }))
        updateCreature i game | otherwise = game

        -- Creature at index i does a single action.
        updateCreatureOnce :: Number -> GameState -> GameState
        updateCreatureOnce i game = modifyCreatureAt i game $ updatePhysics game

updatePhysics :: forall r. GameState -> { pos :: Point, vel :: Point | r } -> { pos :: Point, vel :: Point | r }
updatePhysics g@(Game state) c | inFreeFall state.level c = move g fc (unitp fc.vel)
    where
        projectedMovement p = p.pos .+. unitp p.vel

        -- 1. update gravity
        gc = c { vel = { x: c.vel.x, y: c.vel.y + 1 } }

        -- 2. check collision
        newpos = projectedMovement gc
        blocked = not $ isValidMove state.level newpos
        finalVelX = if blocked then 0 else gc.vel.x

        -- 3. calculate final velocity
        fc = c { vel = { x: finalVelX, y: gc.vel.y } }

updatePhysics _ c = c { vel = zero}

move :: forall r. GameState -> { pos :: Point | r } -> Point -> { pos :: Point | r }
move (Game state) c delta =
    if blocked then c else c { pos = newpos }
    where
        newpos  = clampPos $ c.pos .+. delta
        blocked = not $ isValidMove state.level newpos

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

updateWorld :: Number -> GameState -> GameState
updateWorld advance = updateCreatures advance
    >>> (\(Game state) -> Game state { player = updatePhysics (Game state) state.player })
    >>> (\(Game state) -> Game state { items = map (updatePhysics (Game state)) state.items })

inFreeFall :: forall r. Level -> { pos :: Point | r } -> Boolean
inFreeFall level c = isValidMove level (c.pos .+. {x:0, y: 1})

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

-- todo: item weight should affect player
calcSpeed :: GameState -> Creature -> Number
calcSpeed (Game state) c | inFreeFall state.level c = 500
calcSpeed (Game state) c | otherwise                = c.speed

movePlayer :: Point -> GameState -> GameState
movePlayer delta g@(Game state) =
    if canMove then
        updateWorld (calcSpeed g state.player) $ Game state { player = move (Game state) state.player delta }
        else Game state
    where
        newpos  = state.player.pos .+. delta
        canMove = isValidMove state.level newpos

jump :: GameState -> Number -> Creature -> Creature
jump g xdir c = move g (c { vel = {x: xdir, y: -2} }) {x: xdir, y: -1}

movementkeys :: M.Map Number Point
movementkeys = M.fromList [numpad 8 // {x:  0, y: -1}
                          ,numpad 2 // {x:  0, y:  1}
                          ,numpad 4 // {x: -1, y:  0}
                          ,numpad 6 // {x:  1, y:  0}
                          ,numpad 5 // {x:  0, y:  0}]

pickUp :: Point -> GameState -> GameState
pickUp point (Game state) =
    case head (filter (\i -> i.pos .==. point) state.items) of
        Just item -> Game state { items = deleteItem state.items point, inventory = addItem state.inventory item }
        Nothing   -> Game state
    where
        deleteItem :: [Item] -> Point -> [Item]
        deleteItem (x:xs) delPos | x.pos .==. delPos = xs
        deleteItem (x:xs) delPos | otherwise = x : deleteItem xs delPos
        deleteItem [] _ = []

        addItem :: [Item] -> Item -> [Item]
        addItem xs { itemType = Loot { value = num } } = xs
        addItem xs x = x:xs

onKeyPress :: Console -> GameState -> Number -> ConsoleEff GameState
onKeyPress console g@(Game state) _ | inFreeFall state.level state.player = return g
onKeyPress console g@(Game state) key                      | key == numpad 7 = return $ Game state { player = jump g (-1) state.player }
onKeyPress console g@(Game state) key                      | key == numpad 9 = return $ Game state { player = jump g 1 state.player }
onKeyPress console g@(Game state) key                      | key == 80       = return g
onKeyPress console g@(Game state) key =
    case M.lookup key movementkeys of
        Just delta -> drawGame console $ movePlayer delta g
        Nothing    -> return g

onKeyPress console MainMenu key                            | key == 13       = return $ NameCreation { playerName: "" }
onKeyPress console (NameCreation {playerName = pname}) key | key == 13       = return $ CharCreation { playerName: pname }
onKeyPress console (NameCreation {playerName = xs}) key    | key == 8        = return $ NameCreation { playerName: (take (strlen xs - 1) xs) }
onKeyPress console (NameCreation {playerName = ""}) key                      = return $ NameCreation { playerName: (fromCharArray [fromCharCode key]) }
onKeyPress console (NameCreation {playerName = xs}) key    | strlen xs > 15  = return $ NameCreation { playerName: xs }
onKeyPress console (NameCreation {playerName = xs}) key                      = return $ NameCreation { playerName: (xs ++ (fromCharArray [fromCharCode key])) }
onKeyPress console (CharCreation {playerName = xs}) key    | key == 65       = return $ initialState xs
onKeyPress _ st _ = return st

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


Slightly cleaner

Slightly cleaner

Original commit a4fadb5fd56b1251329c254ee142cad3c673bcad

module Main where

import Prelude

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

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

import Data.StrMap (StrMap, foldMap) as StrMap

import Doc

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

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

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

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

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

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

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

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

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

module Main where

import Prelude

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

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

import Data.StrMap (StrMap, foldMap) as StrMap

import Doc

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

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

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

mapProperties :: StrMap.StrMap Json -> L.List IRProperty
mapProperties sm = StrMap.foldMap toProperty sm
  where toProperty name json = L.singleton { name, typ: makeTypeFromJson name json }

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

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

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

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

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

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


Render consecutive form fields as a form set (#41)

-- | This module defines a component for rendering SlamDown documents to HTML
module Text.Markdown.SlamDown.Halogen.Component
  ( SlamDownConfig(..)
  , defaultBrowserFeatures
  , SlamDownMessage(..)
  , slamDownComponent
  , renderSlamDown
  , evalSlamDownQuery

  , module SDS
  , module SDQ
  ) where

import Prelude

import Control.Alt ((<|>))

import Data.Array as A
import Data.BrowserFeatures (BrowserFeatures)
import Data.Either as E
import Data.Foldable as F
import Data.Functor.Compose (Compose(..))
import Data.Identity (Identity(..))
import Data.List as L
import Data.Maybe as M
import Data.Newtype (unwrap)
import Data.Set as Set
import Data.String as S
import Data.StrMap as SM
import Data.Traversable (traverse)
import Data.Validation.Semigroup as V

import DOM.HTML.Indexed.StepValue (StepValue(..))

import Halogen as H
import Halogen.HTML.Core as HC
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

import Text.Markdown.SlamDown as SD
import Text.Markdown.SlamDown.Halogen.Component.Query as SDQ
import Text.Markdown.SlamDown.Halogen.Component.State as SDS
import Text.Markdown.SlamDown.Halogen.Fresh as Fresh
import Text.Markdown.SlamDown.Halogen.InputType as SDIT
import Text.Markdown.SlamDown.Parser.Inline as SDPI
import Text.Markdown.SlamDown.Pretty as SDPR
import Text.Parsing.Parser as P

data SlamDownMessage v
  = TextBoxChanged String (SD.TextBox M.Maybe)
  | CheckBoxChanged String v Boolean
  | RadioButtonChanged String v
  | DropDownChanged String (M.Maybe v)

-- | By default, no features are enabled.
defaultBrowserFeatures ∷ BrowserFeatures
defaultBrowserFeatures =
  { inputTypeSupported : const false
  }

evalSlamDownQuery
  ∷ ∀ m v
  . (SD.Value v)
  ⇒ SDQ.SlamDownQuery v
  ~> H.ComponentDSL (SDS.SlamDownState v) (SDQ.SlamDownQuery v) (SlamDownMessage v) m
evalSlamDownQuery e =
  case e of
    SDQ.ChangeTextBox key tb next → do
      H.modify <<< SDS.modifyFormState $
        SM.insert key (SD.TextBox $ SD.transTextBox (Compose <<< map pure) tb)
      H.raise $ TextBoxChanged key tb
      pure next

    SDQ.ChangeRadioButton key val next → do
      H.modify \state →
        flip SDS.modifyFormState state <<< SM.insert key $
          case SDS.getFormFieldValue key state of
            M.Just rb @ (SD.RadioButtons (Identity _) (Identity vals)) →
              case L.elemIndex val vals of
                M.Just _ → SD.RadioButtons (pure val) (pure vals)
                M.Nothing → rb
            _ → SD.RadioButtons (pure val) (pure (L.singleton val))
      H.raise $ RadioButtonChanged key val
      pure next

    SDQ.ChangeDropDown key mval next → do
      H.modify \state →
        flip SDS.modifyFormState state <<< SM.insert key $
          case SDS.getFormFieldValue key state of
            M.Just rb @ (SD.DropDown _ (Identity vals)) →
              case mval of
                M.Just val →
                  if F.elem val vals
                  then SD.DropDown (M.Just $ pure val) (pure vals)
                  else rb
                M.Nothing → SD.DropDown M.Nothing (pure vals)
            _ → SD.DropDown (pure <$> mval) (pure $ M.maybe L.Nil L.singleton mval)
      H.raise $ DropDownChanged key mval
      pure next

    SDQ.ChangeCheckBox key val checked next → do
      let
        updateSel ∷ Set.Set v → Set.Set v
        updateSel =
          if checked
          then Set.insert val
          else Set.delete val

        update ∷ M.Maybe (SDS.FormFieldValue v) → SDS.FormFieldValue v
        update (M.Just cb @ (SD.CheckBoxes (Identity sel) (Identity vals))) =
          SD.CheckBoxes (pure $ sel') (pure vals)
          where
            sel' = L.fromFoldable $ Set.intersection (Set.fromFoldable vals) $ updateSel $ Set.fromFoldable sel
        update _ = SD.CheckBoxes (pure $ L.fromFoldable $ updateSel Set.empty) (pure $ L.singleton val)

      H.modify \state →
        SDS.modifyFormState
          (SM.insert key <<< update $ SDS.getFormFieldValue key state)
          state
      H.raise $ CheckBoxChanged key val checked
      pure next

    SDQ.GetFormState k → do
      SDS.SlamDownState state ← H.get
      let defaultFormState = SDS.formStateFromDocument state.document
      pure $ k $ SM.union state.formState defaultFormState

    SDQ.PopulateForm values next → do
      H.modify \(SDS.SlamDownState { document }) →
        let
          desc = SDS.formDescFromDocument document
          keysToPrune = L.filter (\newKey → not (newKey `SM.member` desc)) (L.fromFoldable (SM.keys values))
          prunedValues = F.foldr SM.delete values keysToPrune
        in
          SDS.SlamDownState
            { document
            , formState: prunedValues
            }
      pure next

    SDQ.SetDocument doc next → do
      H.modify $ SDS.replaceDocument doc
      pure next

type SlamDownConfig =
  { formName ∷ String
  , browserFeatures ∷ BrowserFeatures
  }

type FreshRenderer p v a = a → Fresh.Fresh (H.HTML p (SDQ.SlamDownQuery v))

type FormFieldDef a =
  { label ∷ String
  , required ∷ Boolean
  , field ∷ SD.FormField a
  }

type FormFieldBaked p v =
  { label ∷ String
  , required ∷ Boolean
  , field ∷ H.HTML p (SDQ.SlamDownQuery v)
  , ident ∷ M.Maybe String
  }

-- | Render a `SlamDown` document into an HTML form.
renderSlamDown
  ∷ ∀ v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → SDS.SlamDownState v
  → H.ComponentHTML (SDQ.SlamDownQuery v)
renderSlamDown config (SDS.SlamDownState state) =
  case state.document of
    SD.SlamDown bs →
      HH.div_
        $ Fresh.runFresh config.formName
        $ renderBlocks bs

  where
    defaultFormState ∷ SDS.SlamDownFormState v
    defaultFormState = SDS.formStateFromDocument state.document

    h_ ∷ ∀ p a. Int → Array (H.HTML p a) → H.HTML p a
    h_ 1 = HH.h1_
    h_ 2 = HH.h2_
    h_ 3 = HH.h3_
    h_ 4 = HH.h4_
    h_ 5 = HH.h5_
    h_ _ = HH.h6_

    el_ ∷ ∀ p a. SD.ListType → Array (H.HTML p a) → H.HTML p a
    el_ (SD.Bullet _)  = HH.ul_
    el_ (SD.Ordered _) = HH.ol_

    renderInline ∷ ∀ p. FreshRenderer p v (SD.Inline v)
    renderInline i =
      case i of
        SD.Str s → pure $ HH.text s
        SD.Entity s → pure $ HH.text s
        SD.Space → pure $ HH.text " "
        SD.SoftBreak → pure $ HH.text "\n"
        SD.LineBreak → pure $ HH.br_
        SD.Emph is → HH.em_ <$> traverse renderInline (A.fromFoldable is)
        SD.Strong is → HH.strong_ <$> traverse renderInline (A.fromFoldable is)
        SD.Code _ c → pure $ HH.code_ [ HH.text c ]
        SD.Link body tgt → do
          let
            href (SD.InlineLink url) = url
            href (SD.ReferenceLink tgt') = M.maybe "" ("#" <> _) tgt'
          HH.a [ HP.href $ href tgt ] <$> traverse renderInline (A.fromFoldable body)
        SD.Image body url →
          pure $ HH.img
            [ HP.src url
            , HP.alt $ F.foldMap stripInline body
            ]
        SD.FormField label required field →
          renderInlineFormField <$> bakeFormField { label, required, field }

    bakeFormField ∷ ∀ p. FormFieldDef v → Fresh.Fresh (FormFieldBaked p v)
    bakeFormField { label, required, field } = do
      ident ← Fresh.fresh
      let
        unquote = SD.traverseFormField (SD.getLiteral >>> map pure)
        quote = SD.transFormField (unwrap >>> SD.Literal)
        field' =
          unquote <<< ensureValidField <<< M.maybe field quote $
            SM.lookup label state.formState <|> SM.lookup label defaultFormState
      el ←
        case field' of
          M.Nothing → pure $ HH.text "Unsupported form element"
          M.Just fv → renderFormElement config state ident label fv

      let
        requiresId =
          case field' of
            M.Just (SD.CheckBoxes _ _) → false
            M.Just (SD.RadioButtons _ _) → false
            _ → true
      pure
        { label
        , required
        , field: el
        , ident: if requiresId then M.Just ident else M.Nothing
        }

    renderInlineFormField ∷ ∀ p. FormFieldBaked p v → H.HTML p (SDQ.SlamDownQuery v)
    renderInlineFormField { field, label, required, ident } =
      HH.span
        [ HP.class_ (HH.ClassName "slamdown-field") ]
        [ HH.label
            (M.maybe [] (pure <<< HP.for) ident)
            [ HH.text (label <> if required then "*" else "") ]
        , field
        ]

    renderFormSetFormField ∷ ∀ p. FormFieldBaked p v → H.HTML p (SDQ.SlamDownQuery v)
    renderFormSetFormField { field, label, required, ident } =
      HH.tr_
        [ HH.th_
            [ HH.label
                (M.maybe [] (pure <<< HP.for) ident)
                [ HH.text (label <> if required then "*" else "") ]
            ]
        , HH.td_
            [ field ]
        ]

    renderFormSet ∷ ∀ p. FreshRenderer p v (L.List (FormFieldDef v))
    renderFormSet fs =
      HH.table [ HP.class_ (HH.ClassName "slamdown-formset") ]
        <$> traverse (map renderFormSetFormField <<< bakeFormField) (A.fromFoldable fs)

    stripInline ∷ SD.Inline v → String
    stripInline i =
      case i of
        SD.Str s → s
        SD.Entity s → s
        SD.Space → " "
        SD.SoftBreak → "\n"
        SD.LineBreak → "\n"
        SD.Emph is → F.foldMap stripInline is
        SD.Strong is → F.foldMap stripInline is
        SD.Code _ c → c
        SD.Link body _ → F.foldMap stripInline body
        _ → ""

    renderBlock ∷ ∀ p. FreshRenderer p v (SD.Block v)
    renderBlock b =
      case b of
        SD.Paragraph is →
          HH.p_ <$> traverse renderInline (A.fromFoldable is)
        SD.Header lvl is →
          h_ lvl <$> traverse renderInline (A.fromFoldable is)
        SD.Blockquote bs →
          HH.blockquote_ <$> renderBlocks bs
        SD.Lst lt bss → do
          let
            item ∷ FreshRenderer p v (L.List (SD.Block v))
            item bs = HH.li_ <$> renderBlocks bs
          el_ lt <$> traverse item (A.fromFoldable bss)
        SD.CodeBlock _ ss →
          pure $ HH.pre_ [ HH.code_ [ HH.text (S.joinWith "\n" $ A.fromFoldable ss) ] ]
        SD.LinkReference l url →
          pure $ HH.p_
            [ HH.text (l <> ": ")
            , HH.a [ HP.id_ l, HP.href url ] [ HH.text url ]
            ]
        SD.Rule →
          pure HH.hr_

    renderBlocks ∷ ∀ p. L.List (SD.Block v) → Fresh.Fresh (Array (H.HTML p (SDQ.SlamDownQuery v)))
    renderBlocks = go [] L.Nil
      where
      go html fs bs =
        case bs of
          L.Cons (SD.Paragraph (L.Cons (SD.FormField label required field) L.Nil)) bs' →
            go html (L.Cons { label, required, field } fs) bs'
          L.Cons b bs' → do
            bHtml ← renderBlock b
            if L.null fs
              then go (html <> pure bHtml) L.Nil bs'
              else do
                fsHtml ← renderFormSet (L.reverse fs)
                go (html <> pure fsHtml <> pure bHtml) L.Nil bs'
          L.Nil →
            if L.null fs
              then pure html
              else do
                fsHtml ← renderFormSet (L.reverse fs)
                pure (html <> pure fsHtml)

    -- | Make sure that the default value of a form field is valid, and if it is not, strip it out.
    ensureValidField ∷ SD.FormField v → SD.FormField v
    ensureValidField field =
      V.unV
        (const $ stripDefaultValue field)
        id
        (SDPI.validateFormField field)
      where
        stripDefaultValue ∷ SD.FormField v → SD.FormField v
        stripDefaultValue =
          case _ of
             SD.TextBox tb → SD.TextBox $ SD.transTextBox (\_ → Compose M.Nothing) tb
             SD.DropDown _ ls → SD.DropDown M.Nothing ls
             field' → field'

renderRadioButton
  ∷ ∀ p v
  . (SD.Value v)
  ⇒ String  -- label
  → v       -- value
  → FreshRenderer p v Boolean
renderRadioButton label value checked = do
  id ← Fresh.fresh
  let renderedValue = SD.renderValue value
  pure $ HH.li_
    [ HH.input
        [ HP.checked checked
        , HP.type_ HP.InputRadio
        , HP.id_ id
        , HP.name label
        , HP.value renderedValue
        , HE.onValueChange (HE.input_ (SDQ.ChangeRadioButton label value))
        ]
    , HH.label [ HP.for id ] [ HH.text renderedValue ]
    ]

renderCheckBox
  ∷ ∀ p v
  . (SD.Value v)
  ⇒ String  -- label
  → v       -- value
  → FreshRenderer p v Boolean
renderCheckBox label value checked = do
  id ← Fresh.fresh
  let renderedValue = SD.renderValue value
  pure $ HH.li_
    [ HH.input
        [ HP.checked checked
        , HP.type_ HP.InputCheckbox
        , HP.id_ id
        , HP.name label
        , HP.value renderedValue
        , HE.onChecked (HE.input (SDQ.ChangeCheckBox label value))
        ]
    , HH.label [ HP.for id ] [ HH.text renderedValue ]
    ]

renderDropDown
  ∷ ∀ p v
  . (SD.Value v)
  ⇒ String    -- id
  → String    -- label
  → L.List v  -- choices
  → M.Maybe v -- value
  → H.HTML p (SDQ.SlamDownQuery v)
renderDropDown id label ls sel =
  HH.select
    [ HP.id_ id
    , HP.name label
    , HE.onSelectedIndexChange (HE.input (SDQ.ChangeDropDown label <<< L.index ls))
    ]
    $ A.fromFoldable $ M.maybe option option' sel <$> ls
  where
    option ∷ v → H.HTML p (SDQ.SlamDownQuery v)
    option value =
      let renderedValue = SD.renderValue value
      in HH.option [ HP.value renderedValue ] [ HH.text renderedValue ]

    option' ∷ v → v → H.HTML p (SDQ.SlamDownQuery v)
    option' sel' value =
      let renderedValue = SD.renderValue value
      in HH.option [ HP.selected (value == sel'), HP.value renderedValue ] [ HH.text renderedValue ]

renderFormElement
  ∷ ∀ p v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → SDS.SlamDownStateR v
  → String -- element id
  → String -- label
  → FreshRenderer p v (SDS.FormFieldValue v)
renderFormElement config st id label field =
  case field of
    SD.TextBox tb →
      pure $ renderTextInput tb
    SD.RadioButtons (Identity sel) (Identity ls) → do
      let
        renderRadioButton' val = renderRadioButton label val $ sel == val
        options = A.fromFoldable $ if sel `F.elem` ls then ls else L.Cons sel ls
      radios ← traverse renderRadioButton' options
      pure $ HH.ul [ HP.class_ (HH.ClassName "slamdown-radios") ] radios
    SD.CheckBoxes (Identity sel) (Identity ls) → do
      let
        sel' = Set.fromFoldable sel
        renderCheckBox' val = renderCheckBox label val (Set.member val sel')
      checkBoxes ← traverse renderCheckBox' ls
      pure $ HH.ul [ HP.class_ (HH.ClassName "slamdown-checkboxes") ] $ A.fromFoldable checkBoxes
    SD.DropDown msel (Identity ls) →
      pure $
        case msel of
          M.Nothing → renderDropDown id label ls M.Nothing
          M.Just (Identity sel) →
            let options = if sel `F.elem` ls then ls else L.Cons sel ls
            in renderDropDown id label options $ M.Just sel

  where
    renderTextInput
      ∷ SD.TextBox (Compose M.Maybe Identity)
      → H.HTML p (SDQ.SlamDownQuery v)
    renderTextInput tb =
      HH.input $
        [ HP.type_ compatibleInputType
        , HP.id_ id
        , HP.name label
        , HE.onValueInput (HE.input (SDQ.ChangeTextBox label <<< parseInput))
        ]
        <> typeSettings
        <> M.maybe [] (\x → [HP.value x]) renderedValue
      where
        renderedValue =
          SDPR.prettyPrintTextBoxValue <$>
            SD.traverseTextBox unwrap tb

        parser ∷ P.Parser String (SD.TextBox Identity)
        parser = SDPI.parseTextBox (\_ → true) (map pure) tb

        parseInput ∷ String → SD.TextBox M.Maybe
        parseInput str =
          case P.runParser str parser of
            E.Right tb' → SD.transTextBox (unwrap >>> pure) tb'
            E.Left err → SD.transTextBox (\_ → M.Nothing) tb

        typeSettings :: forall r i. Array (HP.IProp (step ∷ StepValue | r) i)
        typeSettings = case compatibleInputType, tb of
          HP.InputTime, SD.Time SD.Seconds _ → [ step (Step 1.0) ]
          HP.InputDatetimeLocal, SD.DateTime SD.Seconds _ → [ step (Step 1.0) ]
          _, _ → []

        compatibleInputType =
          SDIT.inputTypeToHalogenInputType $
            SDIT.availableInputType config.browserFeatures tb

step ∷ ∀ r i. StepValue → HP.IProp (step ∷ StepValue | r) i
step = HP.prop (HC.PropName "step")

-- | Bundles up the SlamDown renderer and state machine into a Halogen component.
slamDownComponent
  ∷ ∀ m v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → H.Component HH.HTML (SDQ.SlamDownQuery v) Unit (SlamDownMessage v) m
slamDownComponent config =
  H.component
    { render: renderSlamDown config
    , eval: evalSlamDownQuery
    , initialState: const SDS.emptySlamDownState
    , receiver: const M.Nothing
    }

-- | This module defines a component for rendering SlamDown documents to HTML
module Text.Markdown.SlamDown.Halogen.Component
  ( SlamDownConfig(..)
  , defaultBrowserFeatures
  , SlamDownMessage(..)
  , slamDownComponent
  , renderSlamDown
  , evalSlamDownQuery

  , module SDS
  , module SDQ
  ) where

import Prelude

import Control.Alt ((<|>))

import Data.Array as A
import Data.BrowserFeatures (BrowserFeatures)
import Data.Either as E
import Data.Foldable as F
import Data.Functor.Compose (Compose(..))
import Data.Identity (Identity(..))
import Data.List as L
import Data.Maybe as M
import Data.Newtype (unwrap)
import Data.Set as Set
import Data.String as S
import Data.StrMap as SM
import Data.Traversable (traverse)
import Data.Validation.Semigroup as V

import DOM.HTML.Indexed.StepValue (StepValue(..))

import Halogen as H
import Halogen.HTML.Core as HC
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

import Text.Markdown.SlamDown as SD
import Text.Markdown.SlamDown.Halogen.Component.Query as SDQ
import Text.Markdown.SlamDown.Halogen.Component.State as SDS
import Text.Markdown.SlamDown.Halogen.Fresh as Fresh
import Text.Markdown.SlamDown.Halogen.InputType as SDIT
import Text.Markdown.SlamDown.Parser.Inline as SDPI
import Text.Markdown.SlamDown.Pretty as SDPR
import Text.Parsing.Parser as P

data SlamDownMessage v
  = TextBoxChanged String (SD.TextBox M.Maybe)
  | CheckBoxChanged String v Boolean
  | RadioButtonChanged String v
  | DropDownChanged String (M.Maybe v)

-- | By default, no features are enabled.
defaultBrowserFeatures ∷ BrowserFeatures
defaultBrowserFeatures =
  { inputTypeSupported : const false
  }

evalSlamDownQuery
  ∷ ∀ m v
  . (SD.Value v)
  ⇒ SDQ.SlamDownQuery v
  ~> H.ComponentDSL (SDS.SlamDownState v) (SDQ.SlamDownQuery v) (SlamDownMessage v) m
evalSlamDownQuery e =
  case e of
    SDQ.ChangeTextBox key tb next → do
      H.modify <<< SDS.modifyFormState $
        SM.insert key (SD.TextBox $ SD.transTextBox (Compose <<< map pure) tb)
      H.raise $ TextBoxChanged key tb
      pure next

    SDQ.ChangeRadioButton key val next → do
      H.modify \state →
        flip SDS.modifyFormState state <<< SM.insert key $
          case SDS.getFormFieldValue key state of
            M.Just rb @ (SD.RadioButtons (Identity _) (Identity vals)) →
              case L.elemIndex val vals of
                M.Just _ → SD.RadioButtons (pure val) (pure vals)
                M.Nothing → rb
            _ → SD.RadioButtons (pure val) (pure (L.singleton val))
      H.raise $ RadioButtonChanged key val
      pure next

    SDQ.ChangeDropDown key mval next → do
      H.modify \state →
        flip SDS.modifyFormState state <<< SM.insert key $
          case SDS.getFormFieldValue key state of
            M.Just rb @ (SD.DropDown _ (Identity vals)) →
              case mval of
                M.Just val →
                  if F.elem val vals
                  then SD.DropDown (M.Just $ pure val) (pure vals)
                  else rb
                M.Nothing → SD.DropDown M.Nothing (pure vals)
            _ → SD.DropDown (pure <$> mval) (pure $ M.maybe L.Nil L.singleton mval)
      H.raise $ DropDownChanged key mval
      pure next

    SDQ.ChangeCheckBox key val checked next → do
      let
        updateSel ∷ Set.Set v → Set.Set v
        updateSel =
          if checked
          then Set.insert val
          else Set.delete val

        update ∷ M.Maybe (SDS.FormFieldValue v) → SDS.FormFieldValue v
        update (M.Just cb @ (SD.CheckBoxes (Identity sel) (Identity vals))) =
          SD.CheckBoxes (pure $ sel') (pure vals)
          where
            sel' = L.fromFoldable $ Set.intersection (Set.fromFoldable vals) $ updateSel $ Set.fromFoldable sel
        update _ = SD.CheckBoxes (pure $ L.fromFoldable $ updateSel Set.empty) (pure $ L.singleton val)

      H.modify \state →
        SDS.modifyFormState
          (SM.insert key <<< update $ SDS.getFormFieldValue key state)
          state
      H.raise $ CheckBoxChanged key val checked
      pure next

    SDQ.GetFormState k → do
      SDS.SlamDownState state ← H.get
      let defaultFormState = SDS.formStateFromDocument state.document
      pure $ k $ SM.union state.formState defaultFormState

    SDQ.PopulateForm values next → do
      H.modify \(SDS.SlamDownState { document }) →
        let
          desc = SDS.formDescFromDocument document
          keysToPrune = L.filter (\newKey → not (newKey `SM.member` desc)) (L.fromFoldable (SM.keys values))
          prunedValues = F.foldr SM.delete values keysToPrune
        in
          SDS.SlamDownState
            { document
            , formState: prunedValues
            }
      pure next

    SDQ.SetDocument doc next → do
      H.modify $ SDS.replaceDocument doc
      pure next

type SlamDownConfig =
  { formName ∷ String
  , browserFeatures ∷ BrowserFeatures
  }

type FreshRenderer p v a = a → Fresh.Fresh (H.HTML p (SDQ.SlamDownQuery v))

-- | Render a `SlamDown` document into an HTML form.
renderSlamDown
  ∷ ∀ v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → SDS.SlamDownState v
  → H.ComponentHTML (SDQ.SlamDownQuery v)
renderSlamDown config (SDS.SlamDownState state) =
  case state.document of
    SD.SlamDown bs →
      HH.div_
        <<< Fresh.runFresh config.formName
        <<< traverse renderBlock
          $ A.fromFoldable bs

  where
    defaultFormState ∷ SDS.SlamDownFormState v
    defaultFormState = SDS.formStateFromDocument state.document

    h_ ∷ ∀ p a. Int → Array (H.HTML p a) → H.HTML p a
    h_ 1 = HH.h1_
    h_ 2 = HH.h2_
    h_ 3 = HH.h3_
    h_ 4 = HH.h4_
    h_ 5 = HH.h5_
    h_ _ = HH.h6_

    el_ ∷ ∀ p a. SD.ListType → Array (H.HTML p a) → H.HTML p a
    el_ (SD.Bullet _)  = HH.ul_
    el_ (SD.Ordered _) = HH.ol_

    renderInline ∷ ∀ p. FreshRenderer p v (SD.Inline v)
    renderInline i =
      case i of
        SD.Str s → pure $ HH.text s
        SD.Entity s → pure $ HH.text s
        SD.Space → pure $ HH.text " "
        SD.SoftBreak → pure $ HH.text "\n"
        SD.LineBreak → pure $ HH.br_
        SD.Emph is → HH.em_ <$> traverse renderInline (A.fromFoldable is)
        SD.Strong is → HH.strong_ <$> traverse renderInline (A.fromFoldable is)
        SD.Code _ c → pure $ HH.code_ [ HH.text c ]
        SD.Link body tgt → do
          let
            href (SD.InlineLink url) = url
            href (SD.ReferenceLink tgt') = M.maybe "" ("#" <> _) tgt'
          HH.a [ HP.href $ href tgt ] <$> traverse renderInline (A.fromFoldable body)
        SD.Image body url →
          pure $ HH.img
            [ HP.src url
            , HP.alt $ F.foldMap stripInline body
            ]
        SD.FormField label req def → do
          ident ← Fresh.fresh
          let
            unquote = SD.traverseFormField (SD.getLiteral >>> map pure)
            quote = SD.transFormField (unwrap >>> SD.Literal)
            field =
              unquote <<< ensureValidField <<< M.maybe def quote $
                SM.lookup label state.formState <|> SM.lookup label defaultFormState
          el ←
            case field of
              M.Nothing → pure $ HH.text "Unsupported form element"
              M.Just fv → renderFormElement config state ident label fv

          let
            requiredLabel = if req then "*" else ""
            requiresId =
              case field of
                M.Just (SD.CheckBoxes _ _) → false
                M.Just (SD.RadioButtons _ _) → false
                _ → true

          pure $ HH.span
            [ HP.class_ (HH.ClassName "slamdown-field") ]
            [ HH.label
              (if requiresId then [ HP.for ident ] else [])
              [ HH.text (label <> requiredLabel) ]
            , el
            ]

    stripInline ∷ SD.Inline v → String
    stripInline i =
      case i of
        SD.Str s → s
        SD.Entity s → s
        SD.Space → " "
        SD.SoftBreak → "\n"
        SD.LineBreak → "\n"
        SD.Emph is → F.foldMap stripInline is
        SD.Strong is → F.foldMap stripInline is
        SD.Code _ c → c
        SD.Link body _ → F.foldMap stripInline body
        _ → ""

    renderBlock ∷ ∀ p. FreshRenderer p v (SD.Block v)
    renderBlock b =
      case b of
        SD.Paragraph is →
          HH.p_ <$> traverse renderInline (A.fromFoldable is)
        SD.Header lvl is →
          h_ lvl <$> traverse renderInline (A.fromFoldable is)
        SD.Blockquote bs →
          HH.blockquote_ <$> traverse renderBlock (A.fromFoldable bs)
        SD.Lst lt bss → do
          let
            item ∷ FreshRenderer p v (L.List (SD.Block v))
            item bs = HH.li_ <$> traverse renderBlock (A.fromFoldable bs)
          el_ lt <$> traverse item (A.fromFoldable bss)
        SD.CodeBlock _ ss →
          pure $ HH.pre_ [ HH.code_ [ HH.text (S.joinWith "\n" $ A.fromFoldable ss) ] ]
        SD.LinkReference l url →
          pure $ HH.p_
            [ HH.text (l <> ": ")
            , HH.a [ HP.id_ l, HP.href url ] [ HH.text url ]
            ]
        SD.Rule →
          pure HH.hr_

    -- | Make sure that the default value of a form field is valid, and if it is not, strip it out.
    ensureValidField ∷ SD.FormField v → SD.FormField v
    ensureValidField field =
      V.unV
        (const $ stripDefaultValue field)
        id
        (SDPI.validateFormField field)
      where
        stripDefaultValue ∷ SD.FormField v → SD.FormField v
        stripDefaultValue =
          case _ of
             SD.TextBox tb → SD.TextBox $ SD.transTextBox (\_ → Compose M.Nothing) tb
             SD.DropDown _ ls → SD.DropDown M.Nothing ls
             field' → field'

renderRadioButton
  ∷ ∀ p v
  . (SD.Value v)
  ⇒ String  -- label
  → v       -- value
  → FreshRenderer p v Boolean
renderRadioButton label value checked = do
  id ← Fresh.fresh
  let renderedValue = SD.renderValue value
  pure $ HH.li_
    [ HH.input
        [ HP.checked checked
        , HP.type_ HP.InputRadio
        , HP.id_ id
        , HP.name label
        , HP.value renderedValue
        , HE.onValueChange (HE.input_ (SDQ.ChangeRadioButton label value))
        ]
    , HH.label [ HP.for id ] [ HH.text renderedValue ]
    ]

renderCheckBox
  ∷ ∀ p v
  . (SD.Value v)
  ⇒ String  -- label
  → v       -- value
  → FreshRenderer p v Boolean
renderCheckBox label value checked = do
  id ← Fresh.fresh
  let renderedValue = SD.renderValue value
  pure $ HH.li_
    [ HH.input
        [ HP.checked checked
        , HP.type_ HP.InputCheckbox
        , HP.id_ id
        , HP.name label
        , HP.value renderedValue
        , HE.onChecked (HE.input (SDQ.ChangeCheckBox label value))
        ]
    , HH.label [ HP.for id ] [ HH.text renderedValue ]
    ]

renderDropDown
  ∷ ∀ p v
  . (SD.Value v)
  ⇒ String    -- id
  → String    -- label
  → L.List v  -- choices
  → M.Maybe v -- value
  → H.HTML p (SDQ.SlamDownQuery v)
renderDropDown id label ls sel =
  HH.select
    [ HP.id_ id
    , HP.name label
    , HE.onSelectedIndexChange (HE.input (SDQ.ChangeDropDown label <<< L.index ls))
    ]
    $ A.fromFoldable $ M.maybe option option' sel <$> ls
  where
    option ∷ v → H.HTML p (SDQ.SlamDownQuery v)
    option value =
      let renderedValue = SD.renderValue value
      in HH.option [ HP.value renderedValue ] [ HH.text renderedValue ]

    option' ∷ v → v → H.HTML p (SDQ.SlamDownQuery v)
    option' sel' value =
      let renderedValue = SD.renderValue value
      in HH.option [ HP.selected (value == sel'), HP.value renderedValue ] [ HH.text renderedValue ]

renderFormElement
  ∷ ∀ p v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → SDS.SlamDownStateR v
  → String -- element id
  → String -- label
  → FreshRenderer p v (SDS.FormFieldValue v)
renderFormElement config st id label field =
  case field of
    SD.TextBox tb →
      pure $ renderTextInput tb
    SD.RadioButtons (Identity sel) (Identity ls) → do
      let
        renderRadioButton' val = renderRadioButton label val $ sel == val
        options = A.fromFoldable $ if sel `F.elem` ls then ls else L.Cons sel ls
      radios ← traverse renderRadioButton' options
      pure $ HH.ul [ HP.class_ (HH.ClassName "slamdown-radios") ] radios
    SD.CheckBoxes (Identity sel) (Identity ls) → do
      let
        sel' = Set.fromFoldable sel
        renderCheckBox' val = renderCheckBox label val (Set.member val sel')
      checkBoxes ← traverse renderCheckBox' ls
      pure $ HH.ul [ HP.class_ (HH.ClassName "slamdown-checkboxes") ] $ A.fromFoldable checkBoxes
    SD.DropDown msel (Identity ls) →
      pure $
        case msel of
          M.Nothing → renderDropDown id label ls M.Nothing
          M.Just (Identity sel) →
            let options = if sel `F.elem` ls then ls else L.Cons sel ls
            in renderDropDown id label options $ M.Just sel

  where
    renderTextInput
      ∷ SD.TextBox (Compose M.Maybe Identity)
      → H.HTML p (SDQ.SlamDownQuery v)
    renderTextInput tb =
      HH.input $
        [ HP.type_ compatibleInputType
        , HP.id_ id
        , HP.name label
        , HE.onValueInput (HE.input (SDQ.ChangeTextBox label <<< parseInput))
        ]
        <> typeSettings
        <> M.maybe [] (\x → [HP.value x]) renderedValue
      where
        renderedValue =
          SDPR.prettyPrintTextBoxValue <$>
            SD.traverseTextBox unwrap tb

        parser ∷ P.Parser String (SD.TextBox Identity)
        parser = SDPI.parseTextBox (\_ → true) (map pure) tb

        parseInput ∷ String → SD.TextBox M.Maybe
        parseInput str =
          case P.runParser str parser of
            E.Right tb' → SD.transTextBox (unwrap >>> pure) tb'
            E.Left err → SD.transTextBox (\_ → M.Nothing) tb

        typeSettings :: forall r i. Array (HP.IProp (step ∷ StepValue | r) i)
        typeSettings = case compatibleInputType, tb of
          HP.InputTime, SD.Time SD.Seconds _ → [ step (Step 1.0) ]
          HP.InputDatetimeLocal, SD.DateTime SD.Seconds _ → [ step (Step 1.0) ]
          _, _ → []

        compatibleInputType =
          SDIT.inputTypeToHalogenInputType $
            SDIT.availableInputType config.browserFeatures tb

step ∷ ∀ r i. StepValue → HP.IProp (step ∷ StepValue | r) i
step = HP.prop (HC.PropName "step")

-- | Bundles up the SlamDown renderer and state machine into a Halogen component.
slamDownComponent
  ∷ ∀ m v
  . (SD.Value v)
  ⇒ SlamDownConfig
  → H.Component HH.HTML (SDQ.SlamDownQuery v) Unit (SlamDownMessage v) m
slamDownComponent config =
  H.component
    { render: renderSlamDown config
    , eval: evalSlamDownQuery
    , initialState: const SDS.emptySlamDownState
    , receiver: const M.Nothing
    }


Add test for closing over an outer variable in a let binding

module Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.ST

test1 x = let
            y :: Number
            y = x + 1
          in y

test2 x y =
  let x' = x + 1 in
  let y' = y + 1 in
  x' + y'

test3 = let f x y z = x + y + z in
        f 1 2 3

test4 = let f x [y, z] = x y z in
        f (+) [1, 2]

test5 = let
          f x | x > 0 = g (x / 2) + 1
          f x = 0
          g x = f (x - 1) + 1
        in g 10

test6 = runPure (runST (do
          r <- newSTRef 0
          (let
            go [] = readSTRef r
            go (n : ns) = do
              modifySTRef r ((+) n)
              go ns
           in go [1, 2, 3, 4, 5])
        ))

test7 = let
          f :: forall a. a -> a
          f x = x
        in if f true then f 1 else f 2

test8 :: Number -> Number
test8 x = let
            go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y
            go y = go $ (y + x / y) / 2
          in go x

main = do
  Debug.Trace.print (test1 1)
  Debug.Trace.print (test2 1 2)
  Debug.Trace.print test3
  Debug.Trace.print test4
  Debug.Trace.print test5
  Debug.Trace.print test6
  Debug.Trace.print test7
  Debug.Trace.print (test8 100)

module Main where

import Prelude
import Control.Monad.Eff
import Control.Monad.ST

test1 x = let
            y :: Number
            y = x + 1
          in y

test2 x y =
  let x' = x + 1 in
  let y' = y + 1 in
  x' + y'

test3 = let f x y z = x + y + z in
        f 1 2 3

test4 = let f x [y, z] = x y z in
        f (+) [1, 2]

test5 = let
          f x | x > 0 = g (x / 2) + 1
          f x = 0
          g x = f (x - 1) + 1
        in g 10

test6 = runPure (runST (do
          r <- newSTRef 0
          (let
            go [] = readSTRef r
            go (n : ns) = do
              modifySTRef r ((+) n)
              go ns
           in go [1, 2, 3, 4, 5])
        ))

test7 = let
          f :: forall a. a -> a
          f x = x
        in if f true then f 1 else f 2

main = do
  Debug.Trace.print (test1 1)
  Debug.Trace.print (test2 1 2)
  Debug.Trace.print test3
  Debug.Trace.print test4
  Debug.Trace.print test5
  Debug.Trace.print test6
  Debug.Trace.print test7


Fix stash merging when a file has errors instead of warnings

module Main where

import Prelude (Unit, pure, bind, otherwise, void, show, id, flip, const, (>>=), (<$>), (<>), ($), (-), (||), (==))
import Data.Argonaut.Printer (printJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Encode (encodeJson)
import Data.Array as Array
import Data.Array.Unsafe (unsafeIndex)
import Data.Either (Either(..), either)
import Data.Foldable (foldr, for_)
import Data.Traversable (traverse)
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)
import Control.Monad.ST (ST)
import Control.Monad.ST as ST
import Control.Apply ((*>))
import Control.Monad (when)
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.Buffer as Buffer
import Node.Encoding as Encoding
import Node.FS (FS)
import Node.FS.Sync as File
import Psa (PsaOptions, parsePsaResult, parsePsaError, encodePsaError, output)
import Psa.Printer.Default as DefaultPrinter

foreign import version :: String

usage :: String
usage = """psa - Error/Warning reporting frontend for psc

Usage: psa [--censor-lib] [--censor-src]
           [--censor-codes=CODES] [--filter-codes=CODES]
           [--no-colors] [--no-source]
           [--lib-dir=DIR] [--psc=PSC] [--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-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
  --stash                Enable persistent warnings
  --stash=FILE           Enable persistent warnings using a specific stash file
  --lib-dir=DIR          Distinguishing key for lib sources (defaults to 'bower_components')
  --psc=PSC              Name of psc executable (defaults to 'psc')

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

defaultOptions :: PsaOptions
defaultOptions =
  { ansi: true
  , censorWarnings: false
  , censorLib: false
  , censorSrc: false
  , censorCodes: Set.empty
  , filterCodes: Set.empty
  , verboseStats: false
  , libDir: "bower_components"
  , cwd: ""
  }

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

parseOptions
  :: forall eff
   . PsaOptions
  -> Array String
  -> Eff (console :: CONSOLE, process :: PROCESS | eff) ParseOptions
parseOptions opts =
  Array.foldM parse
    { extra: []
    , psc: "psc"
    , showSource: true
    , stash: false
    , stashFile: ".psa-stash"
    , opts
    }
  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 == "--no-source" =
      pure p { showSource = false }

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

    | arg == "--verbose-stats" =
      pure p { opts = p.opts { verboseStats = 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.drop 15 arg)) } }

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

    | isPrefix "--lib-dir=" arg =
      pure p { opts = p.opts { libDir = Str.drop 10 arg } }

    | isPrefix "--psc=" arg =
      pure p { psc = Str.drop 6 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 s str of
      Just x | x == 0 -> true
      _               -> false

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

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

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

  stashData <-
    if stash
      then either (const []) id <$> readStashFile stashFile
      else pure []

  child <- Child.spawn psc (Array.cons "--json-errors" extra) 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
        stderr <- Str.split "\n" <$> ST.readSTRef 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 out.warnings
              out' <- output loadLinesImpl opts out { warnings = merged }
              when stash $ writeStashFile stashFile merged
              DefaultPrinter.print opts out'
        Process.exit n

      Child.BySignal s -> do
        Console.error (show s)
        Process.exit 1

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

  -- 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 "\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)

  readStashFile stashFile = do
    stat <- File.exists stashFile
    if stat
      then do
        file <- File.readTextFile Encoding.UTF8 stashFile
        pure $ decodeStash file
      else
        pure $ Left (stashFile <> " does not exist")

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

  mergeWarnings filenames old new = do
    fileStat <- STMap.new
    old' <- flip Array.filterM 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
                  stat' <- File.exists f
                  STMap.poke fileStat f stat'
                  pure stat'
    pure $ old' <> new

module Main where

import Prelude (Unit, pure, bind, otherwise, void, show, id, flip, const, (>>=), (<$>), (<>), ($), (-), (||), (==))
import Data.Argonaut.Printer (printJson)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Decode (decodeJson)
import Data.Argonaut.Encode (encodeJson)
import Data.Array as Array
import Data.Array.Unsafe (unsafeIndex)
import Data.Either (Either(..), either)
import Data.Foldable (foldr, for_)
import Data.Traversable (traverse)
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)
import Control.Monad.ST (ST)
import Control.Monad.ST as ST
import Control.Apply ((*>))
import Control.Monad (when)
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.Buffer as Buffer
import Node.Encoding as Encoding
import Node.FS (FS)
import Node.FS.Sync as File
import Psa (PsaOptions, parsePsaResult, parsePsaError, encodePsaError, output)
import Psa.Printer.Default as DefaultPrinter

foreign import version :: String

usage :: String
usage = """psa - Error/Warning reporting frontend for psc

Usage: psa [--censor-lib] [--censor-src]
           [--censor-codes=CODES] [--filter-codes=CODES]
           [--no-colors] [--no-source]
           [--lib-dir=DIR] [--psc=PSC] [--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-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
  --stash                Enable persistent warnings
  --stash=FILE           Enable persistent warnings using a specific stash file
  --lib-dir=DIR          Distinguishing key for lib sources (defaults to 'bower_components')
  --psc=PSC              Name of psc executable (defaults to 'psc')

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

defaultOptions :: PsaOptions
defaultOptions =
  { ansi: true
  , censorWarnings: false
  , censorLib: false
  , censorSrc: false
  , censorCodes: Set.empty
  , filterCodes: Set.empty
  , verboseStats: false
  , libDir: "bower_components"
  , cwd: ""
  }

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

parseOptions
  :: forall eff
   . PsaOptions
  -> Array String
  -> Eff (console :: CONSOLE, process :: PROCESS | eff) ParseOptions
parseOptions opts =
  Array.foldM parse
    { extra: []
    , psc: "psc"
    , showSource: true
    , stash: false
    , stashFile: ".psa-stash"
    , opts
    }
  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 == "--no-source" =
      pure p { showSource = false }

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

    | arg == "--verbose-stats" =
      pure p { opts = p.opts { verboseStats = 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.drop 15 arg)) } }

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

    | isPrefix "--lib-dir=" arg =
      pure p { opts = p.opts { libDir = Str.drop 10 arg } }

    | isPrefix "--psc=" arg =
      pure p { psc = Str.drop 6 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 s str of
      Just x | x == 0 -> true
      _               -> false

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

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

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

  stashData <-
    if stash
      then either (const []) id <$> readStashFile stashFile
      else pure []

  child <- Child.spawn psc (Array.cons "--json-errors" extra) 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
        stderr <- Str.split "\n" <$> ST.readSTRef 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
              merged <- mergeWarnings stashData out.warnings
              out' <- output loadLinesImpl opts out { warnings = merged }
              when stash $ writeStashFile stashFile merged
              DefaultPrinter.print opts out'
        Process.exit n

      Child.BySignal s -> do
        Console.error (show s)
        Process.exit 1

  where
  stdio = [ Just Child.Pipe, unsafeIndex Child.inherit 1, Just Child.Pipe ]
  loadNothing _ _ = pure Nothing

  -- 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 "\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)

  readStashFile stashFile = do
    stat <- File.exists stashFile
    if stat
      then do
        file <- File.readTextFile Encoding.UTF8 stashFile
        pure $ decodeStash file
      else
        pure $ Left (stashFile <> " does not exist")

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

  mergeWarnings old new = do
    let filenames = foldr (\x s -> maybe s (flip Set.insert s) x.filename) Set.empty new
    fileStat <- STMap.new
    old' <- flip Array.filterM old \x ->
      case x.filename of
        Nothing -> pure false
        Just f ->
          if Set.member f filenames then do
            pure false
          else do
            stat <- STMap.peek fileStat f
            case stat of
              Just s -> pure s
              Nothing -> do
                stat' <- File.exists f
                STMap.poke fileStat f stat'
                pure stat'
    pure $ old' <> new


Deleting the old test purescript file

Deleting the old test purescript file

module Main where

import Debug.Trace

main = trace "Hello, World!"