Add tests for String indexOf' functions

Add tests for String indexOf' functions

module Test.Data.String where

import Data.String
import Debug.Trace
import Control.Monad.Eff
import Test.QuickCheck

main = do

  trace "charAt should return the character at the specified index"
  assert $ charAt 0 "abcd" == "a"
  assert $ charAt 1 "abcd" == "b"

  trace "charCodeAt should return the character at the specified index"
  print $ charCodeAt 0 "abcd" == 97
  print $ charCodeAt 1 "abcd" == 98

  trace "fromCharCode should return a character for a char code"
  assert $ fromCharCode 97 == "a"
  assert $ fromCharCode 98 == "b"

  trace "indexOf should return the index for a substring"
  assert $ indexOf "b" "abc" == 1
  assert $ indexOf "q" "abc" == -1

  trace "indexOf' should return the index for a substring starting from an offset"
  assert $ indexOf' "b" 2 "abcb" == 3
  assert $ indexOf' "q" 2 "abcb" == -1

  trace "lastIndexOf should return the last index for a substring"
  assert $ lastIndexOf "a" "abca" == 3
  assert $ lastIndexOf "q" "abca" == -1

  trace "lastIndexOf' should return the last index for a substring starting from an offset"
  assert $ lastIndexOf' "a" 1 "abca" == 0
  assert $ lastIndexOf' "q" 1 "abca" == -1

  trace "length should return the length of a string"
  assert $ length "" == 0
  assert $ length "a" == 1
  assert $ length "abdc" == 4

  trace "localeCompare should perform a locale-sensitive comparison"
  assert $ indexOf "b" "abc" == 1
  assert $ indexOf "q" "abc" == -1

  trace "replace should replace one substring with another"
  assert $ replace "bar" "baz" "foobar" == "foobaz"

  trace "take should keep the specified number of characters and drop the rest"
  assert $ take 2 "abcd" == "ab"

  trace "drop should drop the specified number of characters from the start of a string and keep the rest"
  assert $ drop 2 "abcd" == "cd"

  trace "split should split a string on a substring"
  assert $ split "," "a,b,c,d" == ["a", "b", "c", "d"]

  trace "toLower should transform a string to lower-case"
  assert $ toLower "ABCD" == "abcd"

  trace "toUpper should transform a string to upper-case"
  assert $ toUpper "abcd" == "ABCD"

  trace "trim should remove leading and trailing whitespace"
  assert $ trim " abc" == "abc"
  assert $ trim " abc " == "abc"
  assert $ trim "abc" == "abc"

  trace "joinWith should join a list of strings with a separator string"
  assert $ joinWith "," ["a", "b", "c", "d"] == "a,b,c,d"
  assert $ joinWith " " ["p", "q", "r"] == "p q r"

assert :: Boolean -> QC {}
assert = quickCheck' 1

module Test.Data.String where

import Data.String
import Debug.Trace
import Control.Monad.Eff
import Test.QuickCheck

main = do

  trace "charAt should return the character at the specified index"
  assert $ charAt 0 "abcd" == "a"
  assert $ charAt 1 "abcd" == "b"

  trace "charCodeAt should return the character at the specified index"
  print $ charCodeAt 0 "abcd" == 97
  print $ charCodeAt 1 "abcd" == 98

  trace "fromCharCode should return a character for a char code"
  assert $ fromCharCode 97 == "a"
  assert $ fromCharCode 98 == "b"

  trace "indexOf should return the index for a substring"
  assert $ indexOf "b" "abc" == 1
  assert $ indexOf "q" "abc" == -1

  trace "lastIndexOf should return the last index for a substring"
  assert $ lastIndexOf "a" "abca" == 3
  assert $ lastIndexOf "q" "abca" == -1

  trace "length should return the length of a string"
  assert $ length "" == 0
  assert $ length "a" == 1
  assert $ length "abdc" == 4

  trace "localeCompare should perform a locale-sensitive comparison"
  assert $ indexOf "b" "abc" == 1
  assert $ indexOf "q" "abc" == -1

  trace "replace should replace one substring with another"
  assert $ replace "bar" "baz" "foobar" == "foobaz"

  trace "take should keep the specified number of characters and drop the rest"
  assert $ take 2 "abcd" == "ab"

  trace "drop should drop the specified number of characters from the start of a string and keep the rest"
  assert $ drop 2 "abcd" == "cd"

  trace "split should split a string on a substring"
  assert $ split "," "a,b,c,d" == ["a", "b", "c", "d"]

  trace "toLower should transform a string to lower-case"
  assert $ toLower "ABCD" == "abcd"

  trace "toUpper should transform a string to upper-case"
  assert $ toUpper "abcd" == "ABCD"

  trace "trim should remove leading and trailing whitespace"
  assert $ trim " abc" == "abc"
  assert $ trim " abc " == "abc"
  assert $ trim "abc" == "abc"

  trace "joinWith should join a list of strings with a separator string"
  assert $ joinWith "," ["a", "b", "c", "d"] == "a,b,c,d"
  assert $ joinWith " " ["p", "q", "r"] == "p q r"

assert :: Boolean -> QC {}
assert = quickCheck' 1


Added bigger title for main menu

Added bigger title for main menu

module Drawing where

import Data.Tuple
import Data.Char
import Data.Maybe
import Data.Foldable
import Data.String hiding (length, drop)
import Data.Array ((!!), (..), map, range, length, head, filter)
import Graphics.CanvasConsole
import qualified Data.Map as M
import Math

import GameState
import GameData
import Level
import Utils
import Line

-- Draws the message buffer.
drawMessages :: Console -> Point -> Number -> [String] -> ConsoleEff Unit
drawMessages console p col (x:xs) = drawString console x (rgb col col col) p.x p.y
                                 >> drawMessages console {x: p.x, y: p.y - 1} (col - 50) xs
drawMessages _       _ _   []     = return unit

-- Draws an array of strings.
drawStrings :: Console -> Point -> String -> [String] -> ConsoleEff Unit
drawStrings console p col (x:xs) = drawString console x col p.x p.y
                                >> drawStrings console {x: p.x, y: p.y + 1} col xs
drawStrings _ _  _  []           = return unit

-- Draws the game when state.blink changes to true or false.
blinkDraw :: Console -> GameState -> ConsoleEff GameState
blinkDraw console g@(Game state) | state.blinkTimer == 0 = drawGame console g
blinkDraw console g@(Game state) | otherwise             = return g

-- Draws the game state.
drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console g@(Game state@{ window = SkillW }) = do
    clear console
    drawString console ("Name: " ++ state.playerName ++ " Points: " ++ show state.points) "AAAAAA" 2 2
    drawString console (skillsInfo state.skills) "AAAAAA" 2 6
    drawString console (statsToString state.player.stats) "AAAAAA" 3 4
    drawString console "Press ESC or A to close skill window." "AAAAAA" 1 18
    return g
drawGame console g@(Game state@{ window = EquipW }) = do
    clear console
    drawString console "Press e to continue and i to open your inventory." "AAAAAA" 1 1
    drawString console "Items equipped: " "AAAAAA" 2 4
    drawString console (equipmentsToString state.equipments) "AAAAAA" 3 6
    drawString console "Press ESC or E to close equipment window." "AAAAAA" 1 18
    drawMessages console {x: 1, y: 23} 255 state.messageBuf
    return g
drawGame console g@(Game state@{ window = InventoryW { index = page , command = com, equip = equ }, inventory = inv }) = do
    clear console
    drawString console "Press i to continue and e to open your equipments. Change page with + and -." "AAAAAA" 1 1
    drawString console ("Inventory (page " ++ show (page + 1) ++ "/" ++ show (floor ((length inv) / 10) + 1) ++ "): (Carrying: " ++ (show $ carryingWeight inv) ++ " lbs)") "AAAAAA" 2 4
    drawInventoryPage inv 0 (page * 10) 4 5
    drawString console "Press ESC or I to close inventory window, D to drop item." "AAAAAA" 1 18
    drawCommandLine com
    drawChoseEquipment equ
    drawMessages console {x: 1, y: 23} 255 state.messageBuf
    return g
        where
            drawItemInfo :: Maybe Item -> Number -> Number -> ConsoleEff Unit
            drawItemInfo (Just i) x y = drawString console (showItem i) "AAAAAA" x y
            drawItemInfo _ x y        = drawString console "empty"      "AAAAAA" x y

            drawInventoryPage :: [Item] -> Number -> Number -> Number -> Number -> ConsoleEff Unit
            drawInventoryPage [] num i x y = drawString console "--- Empty ---" "AAAAAA" x y --End recursion when list is empty.
            drawInventoryPage _ 10 _ x y        = return unit
            drawInventoryPage items num i x y  = do
                drawItemInfo ((!!) items i) (x + 5) y
                drawString console ("(" ++ show num ++ "): ") "AAAAAA" x y
                drawInventoryPage items (num + 1) (i + 1) x (y + 1)

            drawCommandLine :: InventoryCommand -> ConsoleEff Unit
            drawCommandLine Drop = drawString console "Which item do you want to drop?" "AAAAAA" 1 19
            drawCommandLine Use  = drawString console "Which item do you want to drop?" "AAAAAA" 1 19
            drawCommandLine _    = return unit

            drawChoseEquipment :: Maybe EquipmentSlot -> ConsoleEff Unit
            drawChoseEquipment (Just slot) = drawString console ("Which item do you want to equip " ++ show slot ++ "?") "AAAAAA" 1 19
            drawChoseEquipment Nothing = return unit
drawGame console g@(Game state) = do
    clear console
    let offset = {x: 40 - state.player.pos.x, y: 10 - state.player.pos.y}
    mapM_ (tileDrawer offset) viewportPoints
    mapM_ (drawItem offset) state.items
    mapM_ (drawCreature offset) state.npcs
    drawCreature offset state.player
    drawString console ("HP: " ++ show (state.player.stats.hp) ++ "/" ++ show (state.player.stats.maxHp)) "FF0000" 2 24
    drawString console ("Points: " ++ (show (state.points))) "FF0000" 14 24
    drawString console ("Movement mode: " ++ show state.move ++ "   Speed: " ++ show (calcSpeed g)) "FF0000" 30 24
    drawString console (showPoint state.player.pos) "FF0000" 70 24
    drawMessages console {x: 1, y: 23} 255 state.messageBuf
    return $ Game state { memory = updateMemory state.memory }
    where
        updateMemory :: Memory -> Memory
        updateMemory m' = foldl (\m p -> M.insert (Tuple p.x p.y) true m) m' $ filter playerCanSee (pointsAroundPlayer 12)

        viewportPoints :: [Point]
        viewportPoints = do
            x' <- 0 .. 79
            y' <- 0 .. 19
            return {x: x', y: y'}

        inViewport :: Point -> Boolean
        inViewport p = p.x >= 0 && p.y >= 0 && p.x < 80 && p.y < 20

        pointsAroundPlayer :: Number -> [Point]
        pointsAroundPlayer r = do
            x' <- (state.player.pos.x - r) .. (state.player.pos.x + r)
            y' <- (state.player.pos.y - r) .. (state.player.pos.y + r)
            return {x: x', y: y'}

        tileDrawer :: Point -> Point -> ConsoleEff Unit
        tileDrawer offset p = drawTileWithFov pInWorld (drawChar' p) (getTile state.level pInWorld)
            where
                pInWorld = p .-. offset

        drawChar' :: Point -> String -> String -> ConsoleEff Unit
        drawChar' pos c col = drawChar console c col pos.x pos.y

        drawCreature :: Point -> Creature -> ConsoleEff Unit
        drawCreature offset c | playerCanSee c.pos && inViewport (c.pos .+. offset) =
            drawAlertness (c.pos .+. offset .+. {x: 0, y: -1}) c.ai
            >> drawFacing (c.pos .+. offset) c.dir
            >> drawCreatureType (drawChar' (c.pos .+. offset)) c.ctype
        drawCreature offset c | otherwise = return unit

        drawAlertness :: Point -> AI -> ConsoleEff Unit
        drawAlertness p (AI _        Sleep)    | state.blink = drawChar' p "Z" "FFFFFF"
        drawAlertness p (AI MightSee _ )       | state.blink = drawChar' p "?" "555555"
        drawAlertness p (AI (Suspicious _) _ ) | state.blink = drawChar' p "?" "FFFF11"
        drawAlertness p (AI (Alert _) _ )      | state.blink = drawChar' p "!" "FF0000"
        drawAlertness p _ = return unit

        drawFacing :: Point -> Point -> ConsoleEff Unit
        drawFacing p dir | dir.x < 0 && state.blink = drawChar' (p .+. {x: -1, y: 0}) ">" "00FF00"
        drawFacing p dir | dir.x > 0 && state.blink = drawChar' (p .+. {x:  1, y: 0}) "<" "00FF00"
        drawFacing p dir | otherwise = return unit

        drawCreatureType :: forall a. (String -> String -> a) -> CreatureType -> a
        drawCreatureType d Player  = d (fromCode 240) "FF0000"
        drawCreatureType d Guard   = d (fromCode 240) "0000FF"
        drawCreatureType d Archer  = d (fromCode 240) "FF2EB9"
        drawCreatureType d Peasant = d (fromCode 240) "AAAAFF"
        drawCreatureType d _       = d "?" "FFFFFF"

        fromCode :: Number -> String
        fromCode = singleton <<< fromCharCode

        drawItem :: Point -> Item -> ConsoleEff Unit
        drawItem offset i | playerCanSee i.pos && inViewport (i.pos .+. offset) =
            drawItemType (drawChar' (i.pos .+. offset)) i.itemType
        drawItem offset i | otherwise = return unit

        drawItemType :: forall a. (String -> String -> a) -> ItemType -> a
        drawItemType d (Loot _)   = d "$" "FFAA00"
        drawItemType d (Weapon _) = d "/" "AAAAAA"
        drawItemType d (Armor _)  = d "[" "777777"
        drawItemType d (Shield _) = d "o" "999999"
        drawItemType d Ring       = d "," "DDDD00"
        drawItemType d _ = d "?" "FFFFFF"

        drawTileWithFov :: forall a. Point -> (String -> String -> a) -> Maybe Tile -> a
        drawTileWithFov p d t | playerCanSee p                        = drawTile false d t
        drawTileWithFov p d t | M.member (Tuple p.x p.y) state.memory = drawTile true d t
        drawTileWithFov p d t | otherwise                             = d (fromCode 178) "111111"

        playerCanSee :: Point -> Boolean
        -- playerCanSee p = true
        playerCanSee p | distanceSq state.player.pos p > 12 * 12 = false
        playerCanSee p | isTransparent state.level (state.player.pos .+. {x: 0, y: -1}) =
            lineOfSight state.level state.player.pos p
            || lineOfSight state.level (state.player.pos .+. {x: 0, y: -1}) p
        playerCanSee p | otherwise = lineOfSight state.level state.player.pos p

        drawTile :: forall a. Boolean -> (String -> String -> a) -> Maybe Tile -> a
        drawTile dr d (Just Air)        = d (fromCode 176) $ iff dr "222222" "002456"
        drawTile dr d (Just Ground)     = d (fromCode 176) $ iff dr "444444" "AAAAAA"
        drawTile dr d (Just Grass)      = d (fromCode 176) $ iff dr "444444" "009900"
        drawTile dr d (Just Wall)       = d (fromCode 219) $ iff dr "444444" "444422"
        drawTile dr d (Just SWall)      = d (fromCode 219) $ iff dr "444444" "444422"
        drawTile dr d (Just BrickWall)  = d (fromCode 220) $ iff dr "444444" "666666"
        drawTile dr d (Just DoorLocked) = d "+" $ iff dr "444444" "661111"
        drawTile dr d (Just DoorClosed) = d "+" $ iff dr "444444" "666633"
        drawTile dr d (Just DoorOpen)   = d "|" $ iff dr "444444" "666633"
        drawTile dr d (Just BgCave)     = d (fromCode 177) $ iff dr "333333" "666666"
        drawTile dr d (Just BgHouse)    = d (fromCode 219) $ iff dr "222222" "222205"
        drawTile dr d (Just Bush)       = d (fromCode 172) $ iff dr "444444" "009900"
        drawTile dr d (Just Water)      = d (fromCode 247) $ iff dr "444444" "0000FF"
        drawTile dr d (Just Stairs)     = d "<" $ iff dr "444444" "444422"
        drawTile dr d (Just Trunk)      = d "I" $ iff dr "444444" "666633"
        drawTile dr d (Just Leaves)     = d (fromCode 5) $ iff dr "444444" "005500"
        drawTile dr d _                 = d "?" $ iff dr "444444" "FFFFFF"

        -- Darker color for unseen, but remembered tiles.
        iff dr col1 col2 = if dr then col1 else col2

drawGame console MainMenu = do
    clear console
    drawString console " ______      _     _                    ______ _     " "FFFFFF" 5 5
    drawString console " | ___ \\    | |   | |                   | ___ \\ |    " "FFFFFF" 5 6
    drawString console " | |_/ /___ | |__ | |__   ___ _ __ _   _| |_/ / |    " "FFFFFF" 5 7
    drawString console " |    // _ \\| '_ \\| '_ \\ / _ \\ '__| | | |    /| |    " "FFFFFF" 5 8
    drawString console " | |\\ \\ (_) | |_) | |_) |  __/ |  | |_| | |\\ \\| |____" "FFFFFF" 5 9
    drawString console " \\_| \\_\\___/|_.__/|_.__/ \\___|_|   \\__, \\_| \\_\\_____/" "FFFFFF" 5 10
    drawString console "                                    __/ |            " "FFFFFF" 5 11
    drawString console "                                   |___/             " "FFFFFF" 5 12
    drawString console "Press enter to start your adventure" "AAAAAA" 6 16
    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 "(SP = skill point)" "AAAAAA" 3 4

    drawString console "Press 0-8 to select character class" "FF0000" 2 20

    drawString console "(0) Archer      ( +2 dex | +1 str | +2 SP )" "336600" 3 6
    drawString console "(1) Knight      ( +4 str | -1 dex | +2 SP )" "B8B8B8" 3 7
    drawString console "(2) Monk        ( +2 int | +1 dex | +2 SP )" "E6AC00" 3 8
    drawString console "(3) Ninja       ( +4 dex | -1 str | +2 SP )" "5C5C5C" 3 9
    drawString console "(4) Peasant     ( -1 all |        | +1 SP )" "00B36B" 3 10
    drawString console "(5) Rogue       ( +1 dex | +1 int | +5 SP )" "5C5C5C" 3 11
    drawString console "(6) Scholar     ( +3 int | -1 str | +5 SP )" "3D00CC" 3 12
    drawString console "(7) Skillmaster ( +1 int |        | +8 SP )" "00B336" 3 13
    drawString console "(8) Soldier     ( +2 str | +1 dex | +2 SP )" "9E9E9E" 3 14

    --drawString console "Prefix:" "FF0000" 46 13---------------------- TODO (if time)
    --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})
drawGame console (UseSkillPoints { playerName = pname, skillPoints = sp, skills = s, player = p }) = do
    clear console
    drawString console ("Name: " ++ pname) "FF0000" 2 2
    drawString console (statsToString p.stats) "FF0000" 2 3
    drawString console ((drawSkillsInfo 0) $ M.toList s) "FF0000" 3 5

    drawString console ("Skill points left: " ++ show sp) "FF0000" 2 18
    drawString console "Press 0-3 to select skill. Used skill points can't be taken back!" "FF0000" 2 20
    return (UseSkillPoints { playerName: pname, skillPoints: sp, skills: s, player: p })
        where
            drawSkillInfo :: Number -> Tuple SkillType Skill -> String
            drawSkillInfo i (Tuple sType { level = l, prog = p }) = fill ("(" ++ show i ++ "): " ++ show sType ++ " skill. ") 25 ++ " Level: " ++ show l ++ "."

            drawSkillsInfo :: Number -> [Tuple SkillType Skill] -> String
            drawSkillsInfo i [] = ""
            drawSkillsInfo i (x:xs) = drawSkillInfo i x ++ ("\n") ++ drawSkillsInfo (i + 1) xs

drawGame console (Death { playerName = pname, points = p }) = do
    clear console
    drawString console (pname ++ " has died.\n\nScore: " ++ show p ++ "\n\n\n\nPress Enter to start again.") "990000" 5 4
    return (Death { playerName: pname, points: p })

module Drawing where

import Data.Tuple
import Data.Char
import Data.Maybe
import Data.Foldable
import Data.String hiding (length, drop)
import Data.Array ((!!), (..), map, range, length, head, filter)
import Graphics.CanvasConsole
import qualified Data.Map as M
import Math

import GameState
import GameData
import Level
import Utils
import Line

-- Draws the message buffer.
drawMessages :: Console -> Point -> Number -> [String] -> ConsoleEff Unit
drawMessages console p col (x:xs) = drawString console x (rgb col col col) p.x p.y
                                 >> drawMessages console {x: p.x, y: p.y - 1} (col - 50) xs
drawMessages _       _ _   []     = return unit

-- Draws an array of strings.
drawStrings :: Console -> Point -> String -> [String] -> ConsoleEff Unit
drawStrings console p col (x:xs) = drawString console x col p.x p.y
                                >> drawStrings console {x: p.x, y: p.y + 1} col xs
drawStrings _ _  _  []           = return unit

-- Draws the game when state.blink changes to true or false.
blinkDraw :: Console -> GameState -> ConsoleEff GameState
blinkDraw console g@(Game state) | state.blinkTimer == 0 = drawGame console g
blinkDraw console g@(Game state) | otherwise             = return g

-- Draws the game state.
drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console g@(Game state@{ window = SkillW }) = do
    clear console
    drawString console ("Name: " ++ state.playerName ++ " Points: " ++ show state.points) "AAAAAA" 2 2
    drawString console (skillsInfo state.skills) "AAAAAA" 2 6
    drawString console (statsToString state.player.stats) "AAAAAA" 3 4
    drawString console "Press ESC or A to close skill window." "AAAAAA" 1 18
    return g
drawGame console g@(Game state@{ window = EquipW }) = do
    clear console
    drawString console "Press e to continue and i to open your inventory." "AAAAAA" 1 1
    drawString console "Items equipped: " "AAAAAA" 2 4
    drawString console (equipmentsToString state.equipments) "AAAAAA" 3 6
    drawString console "Press ESC or E to close equipment window." "AAAAAA" 1 18
    drawMessages console {x: 1, y: 23} 255 state.messageBuf
    return g
drawGame console g@(Game state@{ window = InventoryW { index = page , command = com, equip = equ }, inventory = inv }) = do
    clear console
    drawString console "Press i to continue and e to open your equipments. Change page with + and -." "AAAAAA" 1 1
    drawString console ("Inventory (page " ++ show (page + 1) ++ "/" ++ show (floor ((length inv) / 10) + 1) ++ "): (Carrying: " ++ (show $ carryingWeight inv) ++ " lbs)") "AAAAAA" 2 4
    drawInventoryPage inv 0 (page * 10) 4 5
    drawString console "Press ESC or I to close inventory window, D to drop item." "AAAAAA" 1 18
    drawCommandLine com
    drawChoseEquipment equ
    drawMessages console {x: 1, y: 23} 255 state.messageBuf
    return g
        where
            drawItemInfo :: Maybe Item -> Number -> Number -> ConsoleEff Unit
            drawItemInfo (Just i) x y = drawString console (showItem i) "AAAAAA" x y
            drawItemInfo _ x y        = drawString console "empty"      "AAAAAA" x y

            drawInventoryPage :: [Item] -> Number -> Number -> Number -> Number -> ConsoleEff Unit
            drawInventoryPage [] num i x y = drawString console "--- Empty ---" "AAAAAA" x y --End recursion when list is empty.
            drawInventoryPage _ 10 _ x y        = return unit
            drawInventoryPage items num i x y  = do
                drawItemInfo ((!!) items i) (x + 5) y
                drawString console ("(" ++ show num ++ "): ") "AAAAAA" x y
                drawInventoryPage items (num + 1) (i + 1) x (y + 1)

            drawCommandLine :: InventoryCommand -> ConsoleEff Unit
            drawCommandLine Drop = drawString console "Which item do you want to drop?" "AAAAAA" 1 19
            drawCommandLine Use  = drawString console "Which item do you want to drop?" "AAAAAA" 1 19
            drawCommandLine _    = return unit

            drawChoseEquipment :: Maybe EquipmentSlot -> ConsoleEff Unit
            drawChoseEquipment (Just slot) = drawString console ("Which item do you want to equip " ++ show slot ++ "?") "AAAAAA" 1 19
            drawChoseEquipment Nothing = return unit
drawGame console g@(Game state) = do
    clear console
    let offset = {x: 40 - state.player.pos.x, y: 10 - state.player.pos.y}
    mapM_ (tileDrawer offset) viewportPoints
    mapM_ (drawItem offset) state.items
    mapM_ (drawCreature offset) state.npcs
    drawCreature offset state.player
    drawString console ("HP: " ++ show (state.player.stats.hp) ++ "/" ++ show (state.player.stats.maxHp)) "FF0000" 2 24
    drawString console ("Points: " ++ (show (state.points))) "FF0000" 14 24
    drawString console ("Movement mode: " ++ show state.move ++ "   Speed: " ++ show (calcSpeed g)) "FF0000" 30 24
    drawString console (showPoint state.player.pos) "FF0000" 70 24
    drawMessages console {x: 1, y: 23} 255 state.messageBuf
    return $ Game state { memory = updateMemory state.memory }
    where
        updateMemory :: Memory -> Memory
        updateMemory m' = foldl (\m p -> M.insert (Tuple p.x p.y) true m) m' $ filter playerCanSee (pointsAroundPlayer 12)

        viewportPoints :: [Point]
        viewportPoints = do
            x' <- 0 .. 79
            y' <- 0 .. 19
            return {x: x', y: y'}

        inViewport :: Point -> Boolean
        inViewport p = p.x >= 0 && p.y >= 0 && p.x < 80 && p.y < 20

        pointsAroundPlayer :: Number -> [Point]
        pointsAroundPlayer r = do
            x' <- (state.player.pos.x - r) .. (state.player.pos.x + r)
            y' <- (state.player.pos.y - r) .. (state.player.pos.y + r)
            return {x: x', y: y'}

        tileDrawer :: Point -> Point -> ConsoleEff Unit
        tileDrawer offset p = drawTileWithFov pInWorld (drawChar' p) (getTile state.level pInWorld)
            where
                pInWorld = p .-. offset

        drawChar' :: Point -> String -> String -> ConsoleEff Unit
        drawChar' pos c col = drawChar console c col pos.x pos.y

        drawCreature :: Point -> Creature -> ConsoleEff Unit
        drawCreature offset c | playerCanSee c.pos && inViewport (c.pos .+. offset) =
            drawAlertness (c.pos .+. offset .+. {x: 0, y: -1}) c.ai
            >> drawFacing (c.pos .+. offset) c.dir
            >> drawCreatureType (drawChar' (c.pos .+. offset)) c.ctype
        drawCreature offset c | otherwise = return unit

        drawAlertness :: Point -> AI -> ConsoleEff Unit
        drawAlertness p (AI _        Sleep)    | state.blink = drawChar' p "Z" "FFFFFF"
        drawAlertness p (AI MightSee _ )       | state.blink = drawChar' p "?" "555555"
        drawAlertness p (AI (Suspicious _) _ ) | state.blink = drawChar' p "?" "FFFF11"
        drawAlertness p (AI (Alert _) _ )      | state.blink = drawChar' p "!" "FF0000"
        drawAlertness p _ = return unit

        drawFacing :: Point -> Point -> ConsoleEff Unit
        drawFacing p dir | dir.x < 0 && state.blink = drawChar' (p .+. {x: -1, y: 0}) ">" "00FF00"
        drawFacing p dir | dir.x > 0 && state.blink = drawChar' (p .+. {x:  1, y: 0}) "<" "00FF00"
        drawFacing p dir | otherwise = return unit

        drawCreatureType :: forall a. (String -> String -> a) -> CreatureType -> a
        drawCreatureType d Player  = d (fromCode 240) "FF0000"
        drawCreatureType d Guard   = d (fromCode 240) "0000FF"
        drawCreatureType d Archer  = d (fromCode 240) "FF2EB9"
        drawCreatureType d Peasant = d (fromCode 240) "AAAAFF"
        drawCreatureType d _       = d "?" "FFFFFF"

        fromCode :: Number -> String
        fromCode = singleton <<< fromCharCode

        drawItem :: Point -> Item -> ConsoleEff Unit
        drawItem offset i | playerCanSee i.pos && inViewport (i.pos .+. offset) =
            drawItemType (drawChar' (i.pos .+. offset)) i.itemType
        drawItem offset i | otherwise = return unit

        drawItemType :: forall a. (String -> String -> a) -> ItemType -> a
        drawItemType d (Loot _)   = d "$" "FFAA00"
        drawItemType d (Weapon _) = d "/" "AAAAAA"
        drawItemType d (Armor _)  = d "[" "777777"
        drawItemType d (Shield _) = d "o" "999999"
        drawItemType d Ring       = d "," "DDDD00"
        drawItemType d _ = d "?" "FFFFFF"

        drawTileWithFov :: forall a. Point -> (String -> String -> a) -> Maybe Tile -> a
        drawTileWithFov p d t | playerCanSee p                        = drawTile false d t
        drawTileWithFov p d t | M.member (Tuple p.x p.y) state.memory = drawTile true d t
        drawTileWithFov p d t | otherwise                             = d (fromCode 178) "111111"

        playerCanSee :: Point -> Boolean
        -- playerCanSee p = true
        playerCanSee p | distanceSq state.player.pos p > 12 * 12 = false
        playerCanSee p | isTransparent state.level (state.player.pos .+. {x: 0, y: -1}) =
            lineOfSight state.level state.player.pos p
            || lineOfSight state.level (state.player.pos .+. {x: 0, y: -1}) p
        playerCanSee p | otherwise = lineOfSight state.level state.player.pos p

        drawTile :: forall a. Boolean -> (String -> String -> a) -> Maybe Tile -> a
        drawTile dr d (Just Air)        = d (fromCode 176) $ iff dr "222222" "002456"
        drawTile dr d (Just Ground)     = d (fromCode 176) $ iff dr "444444" "AAAAAA"
        drawTile dr d (Just Grass)      = d (fromCode 176) $ iff dr "444444" "009900"
        drawTile dr d (Just Wall)       = d (fromCode 219) $ iff dr "444444" "444422"
        drawTile dr d (Just SWall)      = d (fromCode 219) $ iff dr "444444" "444422"
        drawTile dr d (Just BrickWall)  = d (fromCode 220) $ iff dr "444444" "666666"
        drawTile dr d (Just DoorLocked) = d "+" $ iff dr "444444" "661111"
        drawTile dr d (Just DoorClosed) = d "+" $ iff dr "444444" "666633"
        drawTile dr d (Just DoorOpen)   = d "|" $ iff dr "444444" "666633"
        drawTile dr d (Just BgCave)     = d (fromCode 177) $ iff dr "333333" "666666"
        drawTile dr d (Just BgHouse)    = d (fromCode 219) $ iff dr "222222" "222205"
        drawTile dr d (Just Bush)       = d (fromCode 172) $ iff dr "444444" "009900"
        drawTile dr d (Just Water)      = d (fromCode 247) $ iff dr "444444" "0000FF"
        drawTile dr d (Just Stairs)     = d "<" $ iff dr "444444" "444422"
        drawTile dr d (Just Trunk)      = d "I" $ iff dr "444444" "666633"
        drawTile dr d (Just Leaves)     = d (fromCode 5) $ iff dr "444444" "005500"
        drawTile dr d _                 = d "?" $ iff dr "444444" "FFFFFF"

        -- Darker color for unseen, but remembered tiles.
        iff dr col1 col2 = if dr then col1 else col2

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 "(SP = skill point)" "AAAAAA" 3 4

    drawString console "Press 0-8 to select character class" "FF0000" 2 20

    drawString console "(0) Archer      ( +2 dex | +1 str | +2 SP )" "336600" 3 6
    drawString console "(1) Knight      ( +4 str | -1 dex | +2 SP )" "B8B8B8" 3 7
    drawString console "(2) Monk        ( +2 int | +1 dex | +2 SP )" "E6AC00" 3 8
    drawString console "(3) Ninja       ( +4 dex | -1 str | +2 SP )" "5C5C5C" 3 9
    drawString console "(4) Peasant     ( -1 all |        | +1 SP )" "00B36B" 3 10
    drawString console "(5) Rogue       ( +1 dex | +1 int | +5 SP )" "5C5C5C" 3 11
    drawString console "(6) Scholar     ( +3 int | -1 str | +5 SP )" "3D00CC" 3 12
    drawString console "(7) Skillmaster ( +1 int |        | +8 SP )" "00B336" 3 13
    drawString console "(8) Soldier     ( +2 str | +1 dex | +2 SP )" "9E9E9E" 3 14

    --drawString console "Prefix:" "FF0000" 46 13---------------------- TODO (if time)
    --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})
drawGame console (UseSkillPoints { playerName = pname, skillPoints = sp, skills = s, player = p }) = do
    clear console
    drawString console ("Name: " ++ pname) "FF0000" 2 2
    drawString console (statsToString p.stats) "FF0000" 2 3
    drawString console ((drawSkillsInfo 0) $ M.toList s) "FF0000" 3 5

    drawString console ("Skill points left: " ++ show sp) "FF0000" 2 18
    drawString console "Press 0-3 to select skill. Used skill points can't be taken back!" "FF0000" 2 20
    return (UseSkillPoints { playerName: pname, skillPoints: sp, skills: s, player: p })
        where
            drawSkillInfo :: Number -> Tuple SkillType Skill -> String
            drawSkillInfo i (Tuple sType { level = l, prog = p }) = fill ("(" ++ show i ++ "): " ++ show sType ++ " skill. ") 25 ++ " Level: " ++ show l ++ "."

            drawSkillsInfo :: Number -> [Tuple SkillType Skill] -> String
            drawSkillsInfo i [] = ""
            drawSkillsInfo i (x:xs) = drawSkillInfo i x ++ ("\n") ++ drawSkillsInfo (i + 1) xs

drawGame console (Death { playerName = pname, points = p }) = do
    clear console
    drawString console (pname ++ " has died.\n\nScore: " ++ show p ++ "\n\n\n\nPress Enter to start again.") "990000" 5 4
    return (Death { playerName: pname, points: p })


Use cleaner pipeline in demo, test bumping

module Genetics.Browser.Track.UI where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, tryPeekVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (take, zip)
import Data.Array as Array
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Filterable as Filterable
import Data.Foldable (class Foldable, for_, length)
import Data.Int (round)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.List (List(..), (:))
import Data.List as List
import Data.Map (Map)
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), snd)
import Debug.Trace (traceShow)
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (GWASFeature, Gene, drawDemo, getDataDemo, mouseChrIds)
import Genetics.Browser.Types (ChrId(..))
import Genetics.Browser.View (Pixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, TranslateTransform, Transform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, transform, translate, withContext)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
-- foreign import scrollCanvas :: forall eff.
--                                CanvasElement
--                             -> CanvasElement
--                             -> Point
--                             -> Eff eff Unit

-- creates a new CanvasElement, not attached to the DOM and thus not visible
-- foreign import newCanvas :: forall eff.
--                             { w :: Number, h :: Number }
--                          -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

-- foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
--                                                         , total :: Nullable Point }

-- foreign import canvasEvent :: String -> CanvasElement -> Event Point

foreign import setViewUI :: forall eff. String -> Eff eff Unit

type View = { lHand :: ChrId, rHand :: ChrId }

type ZipperRange a =
  { left  :: List a
  , focus :: List a
  , right :: List a
  }

zipSlideLeft :: forall a.
                ZipperRange a
             -> ZipperRange a
zipSlideLeft zr@{left, focus, right} = case List.uncons left, List.unsnoc focus of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just l, Just f ->
      let left'  = l.tail
          focus' = l.head : f.init
          right' = f.last : right
      in {left: left', focus: focus', right: right'}

zipSlideRight :: forall a.
                 ZipperRange a
              -> ZipperRange a
zipSlideRight zr@{left, focus, right} = case List.uncons focus, List.uncons right of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just f, Just r ->
      let left'  = f.head : left
          focus' = f.tail <> List.singleton r.head
          right' = r.tail
      in {left: left', focus: focus', right: right'}

zipZoomIn :: forall a.
             ZipperRange a
          -> ZipperRange a
zipZoomIn zr@{left, focus, right} = case List.uncons focus of
  Nothing -> zr
  Just {head, tail} -> case List.unsnoc tail of
    Nothing -> zr
    Just {init, last} ->
      let left'  = head : left
          focus' = init
          right' = last : right
      in {left: left', focus: focus', right: right'}

zipZoomOut :: forall a.
              ZipperRange a
           -> ZipperRange a
zipZoomOut zr@{left, focus, right} = case List.uncons left, List.uncons right of
  Nothing, Nothing -> zr
  Nothing, Just r ->
    let focus' = focus <> List.singleton r.head
        right' = r.tail
    in zr { focus = focus', right = right' }
  Just l, Nothing ->
    let left' = l.tail
        focus' = l.head : focus
    in zr { focus = focus', left = left' }
  Just l, Just r ->
    let left' = l.tail
        focus' = l.head : focus <> List.singleton r.head
        right' = r.tail
    in { left: left', focus: focus', right: right' }

focusArray :: forall a.
              ZipperRange a
           -> Array a
focusArray {focus} = Array.fromFoldable focus

unfocusArray :: forall a.
                Array a
             -> ZipperRange a
unfocusArray arr = { left: Nil
                   , focus: List.fromFoldable arr
                   , right: Nil
                   }

data UpdateView =
    GoLeft
  | GoRight
  | Out
  | In
  | NoOp

btnScroll :: Event UpdateView
btnScroll = const GoLeft  <$> buttonEvent "scrollLeft" <|>
            const GoRight <$> buttonEvent "scrollRight"

btnZoom :: Event UpdateView
btnZoom = const Out <$> buttonEvent "zoomOut" <|>
          const In  <$> buttonEvent "zoomIn"

btnUpdateView :: Event UpdateView
btnUpdateView = btnScroll <|> btnZoom

mkFoldView :: UpdateView
           -> ZipperRange ChrId
           -> ZipperRange ChrId
mkFoldView uv zr = case uv of
  GoLeft  -> zipSlideLeft zr
  GoRight -> zipSlideRight zr
  Out     -> zipZoomOut zr
  In      -> zipZoomIn zr
  NoOp    -> zr

chrZREvent :: Array ChrId
           -> Event UpdateView
           -> Event (ZipperRange ChrId)
chrZREvent chrs uv = Event.fold mkFoldView uv (unfocusArray chrs)

chrsArrayEvent :: Event (ZipperRange ChrId)
               -> Event (Array ChrId)
chrsArrayEvent = map (Array.fromFoldable <<< _.focus)

drawingEvent :: { min :: Number, max :: Number }
             -> { width :: Pixels, height :: Pixels, padding :: Pixels, yOffset :: Pixels }
             -> { gwas  :: Map ChrId (List _)
                , genes :: Map ChrId (List _) }
             -> Event (Array ChrId)
             -> Event (Drawing)
drawingEvent s box dat chrs = drawDemo s box dat <$> chrs

main :: Eff _ _
main = launchAff do

  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      chrIds = mouseChrIds

  let viewEvent = chrsArrayEvent $ chrZREvent mouseChrIds btnUpdateView

  void $ liftEff $ Event.subscribe viewEvent
       (\arr -> do
           let l = fromMaybe "N/A" $ show <$> Array.head arr
               r = fromMaybe "N/A" $ show <$> Array.last arr
           setViewUI $ l <> "\tto\t" <> r)

  dat <- getDataDemo { gwas: "./gwas.json"
                     , genes: "./sample_genes_chr.json" }

  let sizes = {width: w, height: h, padding: 4.0, yOffset: 10.0}
      score = {min: 0.1, max: 0.45}

  let ev' = drawingEvent score sizes dat viewEvent
      bg = filled (fillColor white) $ rectangle 0.0 0.0 w h

  void $ liftEff $ Event.subscribe ev' (\d -> Drawing.render ctx (bg <> d))

module Genetics.Browser.Track.UI where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, tryPeekVar)
import Control.Monad.Eff (Eff, foreachE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array (take, zip)
import Data.Array as Array
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Filterable as Filterable
import Data.Foldable (class Foldable, for_, length)
import Data.Int (round)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.List (List(..), (:))
import Data.List as List
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (Tuple(..), snd)
import Debug.Trace (traceShow)
import FRP.Event (Event)
import FRP.Event as Event
import FRP.Event as FRP
import Genetics.Browser.Track.Backend (GWASFeature, Gene, drawGemma, drawGenes, fetchGemmaJSON, fetchGene'JSON, fetchGeneJSON, geneFetchChrId, mouseChrIds)
import Genetics.Browser.Types (ChrId(..))
import Genetics.Browser.View (Pixels)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, TranslateTransform, Transform, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth, transform, translate, withContext)
import Graphics.Drawing (Drawing, fillColor, filled, rectangle, white)
import Graphics.Drawing as Drawing
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
-- foreign import scrollCanvas :: forall eff.
--                                CanvasElement
--                             -> CanvasElement
--                             -> Point
--                             -> Eff eff Unit

-- creates a new CanvasElement, not attached to the DOM and thus not visible
-- foreign import newCanvas :: forall eff.
--                             { w :: Number, h :: Number }
--                          -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

-- foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
--                                                         , total :: Nullable Point }

-- foreign import canvasEvent :: String -> CanvasElement -> Event Point

foreign import setViewUI :: forall eff. String -> Eff eff Unit

type View = { lHand :: ChrId, rHand :: ChrId }

type ZipperRange a =
  { left  :: List a
  , focus :: List a
  , right :: List a
  }

zipSlideLeft :: forall a.
                ZipperRange a
             -> ZipperRange a
zipSlideLeft zr@{left, focus, right} = case List.uncons left, List.unsnoc focus of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just l, Just f ->
      let left'  = l.tail
          focus' = l.head : f.init
          right' = f.last : right
      in {left: left', focus: focus', right: right'}

zipSlideRight :: forall a.
                 ZipperRange a
              -> ZipperRange a
zipSlideRight zr@{left, focus, right} = case List.uncons focus, List.uncons right of
    Nothing, _  -> zr
    _ , Nothing -> zr
    Just f, Just r ->
      let left'  = f.head : left
          focus' = f.tail <> List.singleton r.head
          right' = r.tail
      in {left: left', focus: focus', right: right'}

zipZoomIn :: forall a.
             ZipperRange a
          -> ZipperRange a
zipZoomIn zr@{left, focus, right} = case List.uncons focus of
  Nothing -> zr
  Just {head, tail} -> case List.unsnoc tail of
    Nothing -> zr
    Just {init, last} ->
      let left'  = head : left
          focus' = init
          right' = last : right
      in {left: left', focus: focus', right: right'}

zipZoomOut :: forall a.
              ZipperRange a
           -> ZipperRange a
zipZoomOut zr@{left, focus, right} = case List.uncons left, List.uncons right of
  Nothing, Nothing -> zr
  Nothing, Just r ->
    let focus' = focus <> List.singleton r.head
        right' = r.tail
    in zr { focus = focus', right = right' }
  Just l, Nothing ->
    let left' = l.tail
        focus' = l.head : focus
    in zr { focus = focus', left = left' }
  Just l, Just r ->
    let left' = l.tail
        focus' = l.head : focus <> List.singleton r.head
        right' = r.tail
    in { left: left', focus: focus', right: right' }

focusArray :: forall a.
              ZipperRange a
           -> Array a
focusArray {focus} = Array.fromFoldable focus

unfocusArray :: forall a.
                Array a
             -> ZipperRange a
unfocusArray arr = { left: Nil
                   , focus: List.fromFoldable arr
                   , right: Nil
                   }

data UpdateView =
    GoLeft
  | GoRight
  | Out
  | In
  | NoOp

btnScroll :: Event UpdateView
btnScroll = const GoLeft  <$> buttonEvent "scrollLeft" <|>
            const GoRight <$> buttonEvent "scrollRight"

btnZoom :: Event UpdateView
btnZoom = const Out <$> buttonEvent "zoomOut" <|>
          const In  <$> buttonEvent "zoomIn"

btnUpdateView :: Event UpdateView
btnUpdateView = btnScroll <|> btnZoom

mkFoldView :: UpdateView
           -> ZipperRange ChrId
           -> ZipperRange ChrId
mkFoldView uv zr = case uv of
  GoLeft  -> zipSlideLeft zr
  GoRight -> zipSlideRight zr
  Out     -> zipZoomOut zr
  In      -> zipZoomIn zr
  NoOp    -> zr

chrZREvent :: Array ChrId
           -> Event UpdateView
           -> Event (ZipperRange ChrId)
chrZREvent chrs uv = Event.fold mkFoldView uv (unfocusArray chrs)

chrsArrayEvent :: Event (ZipperRange ChrId)
               -> Event (Array ChrId)
chrsArrayEvent = map (Array.fromFoldable <<< _.focus)

gemmaDrawingEvent :: forall r.
                     { w :: Pixels, h :: Pixels, p :: Pixels, y :: Pixels }
                  -> { min :: Number, max :: Number }
                  -> List (GWASFeature r)
                  -> Event (Array ChrId)
                  -> Event Drawing
gemmaDrawingEvent pos s gemma evChrs = drawing <$> evChrs
  where drawing chrs = drawGemma pos s gemma chrs

geneDrawingEvent :: forall r.
                    { w :: Pixels, h :: Pixels, p :: Pixels, y :: Pixels }
                 -> { min :: Number, max :: Number }
                 -> List (Gene r)
                 -> Event (Array ChrId)
                 -> Event Drawing
geneDrawingEvent pos s genes evChrs = drawing <$> evChrs
  where drawing chrs = drawGenes pos genes chrs

-- geneDrawingEvent' :: forall r.
--                      { w :: Pixels, h :: Pixels, p :: Pixels, y :: Pixels }
--                   -> { min :: Number, max :: Number }
--                   -> Event (List (Gene r))
--                   -> Event (Array ChrId)
--                   -> Event Drawing
-- geneDrawingEvent' pos s evGenes evChrs = drawGenes pos s <$> evGenes <*> evChrs

main :: Eff _ _
main = launchAff do

  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  let height = h
      offset = 0.0
      yInfo = { height, offset }

      chrIds = mouseChrIds

  gwasData <- List.fromFoldable <$> fetchGemmaJSON "./gwas.json"

  liftEff $ log $ "parsed " <> show (length gwasData :: Int)

  let sizes = {w, h, p: 4.0, y: 10.0}
      score = {min: 0.1, max: 0.45}

  let viewEvent = chrsArrayEvent $ chrZREvent mouseChrIds btnUpdateView

  genes <- List.fromFoldable <$> fetchGeneJSON "./sample_genes_chr.json"
  -- for_ genes' \gene -> liftEff do
  --   log $ "Gene: " <> gene.geneID

  -- liftEff $ log "fetching chrIds"
  -- genes <- List.fromFoldable <$> traverse geneFetchChrId genes'
  -- for_ genes \gene -> liftEff do
  --   log $ "Gene: " <> gene.geneID
  --   log $ "ChrId: " <> show gene.chrId
  --   log $ "Start: " <> show gene.start <> "\tEnd: " <> show gene.end

  let ev' :: Event Drawing
      ev' = (gemmaDrawingEvent sizes score gwasData viewEvent) <>
            (geneDrawingEvent sizes score genes viewEvent) <|> (pure mempty)

  let bg = filled (fillColor white) $ rectangle 0.0 0.0 w h

  void $ liftEff $ Event.subscribe viewEvent
       (\arr -> do
           let l = fromMaybe "N/A" $ show <$> Array.head arr
               r = fromMaybe "N/A" $ show <$> Array.last arr
           setViewUI $ show arr)

  -- TODO combine drawings by using layers -- keep the latest drawing per-layer until it gets updated
  liftEff $ log "drawing1"
  void $ liftEff $ Event.subscribe ev' (\d -> Drawing.render ctx (bg <> d))


Fix: whitespace after attributes breaks parsing.

module Text.HTML.Parser.Internal where

import Prelude
import Control.Alt
import Control.Apply
import Data.Either
import Data.List (List(..))
import Data.Maybe
import Data.Tuple

import Text.Parsing.StringParser
import Text.Parsing.StringParser.Combinators
import Text.Parsing.StringParser.String (eof, string)

import Text.HTML.Parser.Combinators
import Text.HTML.Parser.Types

parseHTML :: String -> Either ParseError (List HTML)
parseHTML s = flip runParser s $ many parseNode <* eof

parseElement = do
  Tuple name attrs <- parseOpenTag
  children <- many parseNode
  parseCloseTag name
  pure $ Element name attrs children

parseNode = fix \_ ->
  try parseElement <|>
  try parseVoidElement <|>
  parseTextNode

parseOpenTag :: Parser (Tuple String (List Attribute))
parseOpenTag = do
  notClosedTag
  char '<'
  name <- parseTagName
  skipSpaces
  attrs <- parseAttributes
  skipSpaces
  char '>'
  pure $ Tuple name attrs

parseCloseTag :: String -> Parser Char
parseCloseTag name = do
  string "</"
  string name
  char '>'

notClosedTag :: Parser Unit
notClosedTag = notFollowedBy $ string "</"

parseVoidElement = do
  notClosedTag
  char '<'
  name <- parseTagName
  skipSpaces
  attrs <- parseAttributes
  skipSpaces
  string "/>"
  pure $ VoidElement name attrs

parseTagName :: Parser String
parseTagName = catChars <$> many1 (satisfy isAlphaNumeric)

parseTextNode :: Parser HTML
parseTextNode = TextNode <<< catChars <$> many1 (noneOf ['<', '>'])

parseAttributes :: Parser (List Attribute)
parseAttributes = sepEndBy parseAttribute skipSpaces

parseAttribute :: Parser Attribute
parseAttribute = do
  name <- parseAttributeName
  skipSpaces
  maybeEquals <- optionMaybe $ char '='
  value <- case maybeEquals of
    Nothing -> pure ""
    Just _ -> parseAttributeValue
  pure $ Attribute name value

parseAttributeName :: Parser String
parseAttributeName = catChars <$> many1 (noneOf [' ', '"', '\'', '>', '/', '='])

parseAttributeValue :: Parser String
parseAttributeValue = do
  maybeOpenChar <- optionMaybe $ skipSpaces *> (char '"' <|> char '\'')
  case maybeOpenChar of
    Nothing -> catChars <$> many (noneOf [' ', '>'])
    Just openChar -> do
      value <- catChars <$> many (noneOf [openChar])
      char openChar
      pure value

module Text.HTML.Parser.Internal where

import Prelude
import Control.Alt
import Control.Apply
import Data.Either
import Data.List (List(..))
import Data.Maybe
import Data.Tuple

import Text.Parsing.StringParser
import Text.Parsing.StringParser.Combinators
import Text.Parsing.StringParser.String (eof, string)

import Text.HTML.Parser.Combinators
import Text.HTML.Parser.Types

parseHTML :: String -> Either ParseError (List HTML)
parseHTML s = flip runParser s $ many parseNode <* eof

parseElement = do
  Tuple name attrs <- parseOpenTag
  children <- many parseNode
  parseCloseTag name
  pure $ Element name attrs children

parseNode = fix \_ ->
  try parseElement <|>
  try parseVoidElement <|>
  parseTextNode

parseOpenTag :: Parser (Tuple String (List Attribute))
parseOpenTag = do
  notClosedTag
  char '<'
  name <- parseTagName
  skipSpaces
  attrs <- parseAttributes
  skipSpaces
  char '>'
  pure $ Tuple name attrs

parseCloseTag :: String -> Parser Char
parseCloseTag name = do
  string "</"
  string name
  char '>'

notClosedTag :: Parser Unit
notClosedTag = notFollowedBy $ string "</"

parseVoidElement = do
  notClosedTag
  char '<'
  name <- parseTagName
  skipSpaces
  attrs <- parseAttributes
  skipSpaces
  string "/>"
  pure $ VoidElement name attrs

parseTagName :: Parser String
parseTagName = catChars <$> many1 (satisfy isAlphaNumeric)

parseTextNode :: Parser HTML
parseTextNode = TextNode <<< catChars <$> many1 (noneOf ['<', '>'])

parseAttributes :: Parser (List Attribute)
parseAttributes = sepBy parseAttribute skipSpaces

parseAttribute :: Parser Attribute
parseAttribute = do
  name <- parseAttributeName
  skipSpaces
  maybeEquals <- optionMaybe $ char '='
  value <- case maybeEquals of
    Nothing -> pure ""
    Just _ -> parseAttributeValue
  pure $ Attribute name value

parseAttributeName :: Parser String
parseAttributeName = catChars <$> many1 (noneOf [' ', '"', '\'', '>', '/', '='])

parseAttributeValue :: Parser String
parseAttributeValue = do
  maybeOpenChar <- optionMaybe $ skipSpaces *> (char '"' <|> char '\'')
  case maybeOpenChar of
    Nothing -> catChars <$> many (noneOf [' ', '>'])
    Just openChar -> do
      value <- catChars <$> many (noneOf [openChar])
      char openChar
      pure value


Run jsonSchemaToIR within a state monad

Run jsonSchemaToIR within a state monad

We shall need this later.

module Language.JsonSchema
    ( JSONSchema
    , jsonSchemaListToIR
    , renderer
    ) where

import Core (class Eq, class Ord, Error, Unit, unit, bind, const, map, not, otherwise, pure, ($), (&&), (/=), (<), (<$>), (<>), (=<<), (>=), (>>>))

import Doc (Doc, Renderer, combineNames, getClasses, getTopLevels, line, lookupClassName, noForbidNamer, simpleNamer)
import IRGraph
import Control.Monad.Error.Class (throwError)

import Data.Argonaut.Core (Json, foldJson, fromArray, fromBoolean, fromObject, fromString, isBoolean, stringifyWithSpace)
import Data.Argonaut.Decode ((.??), decodeJson, class DecodeJson)
import Data.Array as A
import Data.Char as Char
import Data.Either (Either(Right, Left))
import Data.Foldable (class Foldable, foldM)
import Data.List (List, (:))
import Data.List as L
import Data.List.NonEmpty as NEL
import Control.Monad.State.Trans as StateT
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Set (Set)
import Data.Set as S
import Data.StrMap (StrMap)
import Data.StrMap as SM
import Data.String as String
import Data.String.Util (camelCase, capitalize, singular)
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(..))
import IR (IR, addClass, unifyTypes)
import Utils (mapM, mapMapM)

data JSONType
    = JSONObject
    | JSONArray
    | JSONBoolean
    | JSONString
    | JSONNull
    | JSONInteger
    | JSONNumber

derive instance eqJSONType :: Eq JSONType
derive instance ordJSONType :: Ord JSONType

jsonTypeEnumMap :: StrMap JSONType
jsonTypeEnumMap = SM.fromFoldable [
    Tuple "object" JSONObject, Tuple "array" JSONArray, Tuple "boolean" JSONBoolean,
    Tuple "string" JSONString, Tuple "null" JSONNull, Tuple "integer" JSONInteger,
    Tuple "number" JSONNumber
    ]

data PathElement
    = Root
    | Definition String

newtype JSONSchemaRef = JSONSchemaRef
    { path :: NEL.NonEmptyList PathElement
    , name :: Maybe String
    }

newtype JSONSchema = JSONSchema
    { definitions :: Maybe (StrMap JSONSchema)
    , ref :: Maybe JSONSchemaRef
    , types :: Maybe (Either JSONType (Set JSONType))
    , oneOf :: Maybe (Array JSONSchema)
    , properties :: Maybe (StrMap JSONSchema)
    , additionalProperties :: Either Boolean JSONSchema
    , items :: Maybe JSONSchema
    , required :: Maybe (Array String)
    , title :: Maybe String
    }

type JsonIR = StateT.StateT Unit IR

decodeEnum :: forall a. StrMap a -> Json -> Either Error a
decodeEnum sm j = do
    key <- decodeJson j
    maybe (Left "Unexpected enum key") Right $ SM.lookup key sm

instance decodeJsonType :: DecodeJson JSONType where
    decodeJson = decodeEnum jsonTypeEnumMap

instance decodeJsonSchemaRef :: DecodeJson JSONSchemaRef where
    decodeJson j = do
        refString :: String <- decodeJson j
        let pathElementsStrings = String.split (String.Pattern "/") refString
        parsed <- parseJsonSchemaRef $ L.fromFoldable pathElementsStrings
        case NEL.fromList parsed of
            Nothing -> Left "Reference must contain at least one path element"
            Just path -> pure $ JSONSchemaRef { path, name: A.last pathElementsStrings }

parseJsonSchemaRef :: List String -> Either Error (List PathElement)
parseJsonSchemaRef L.Nil =
    pure L.Nil
parseJsonSchemaRef ("#" : rest) = do
    restParsed <- parseJsonSchemaRef rest
    pure $ Root : restParsed
parseJsonSchemaRef ("definitions" : name : rest) = do
    restParsed <- parseJsonSchemaRef rest
    pure $ Definition name : restParsed
parseJsonSchemaRef _ =
    Left "Could not parse JSON Schema reference"

decodeTypes :: Json -> Either Error (Either JSONType (Set JSONType))
decodeTypes j =
    foldJson
        (\_ -> Left "`types` cannot be null")
        (\_ -> Left "`types` cannot be a boolean")
        (\_ -> Left "`types` cannot be a number")
        (\s -> do
            t <- decodeEnum jsonTypeEnumMap j
            pure $ Left t)
        (\a -> do
            l <- traverse (decodeEnum jsonTypeEnumMap) a
            pure $ Right $ S.fromFoldable l)
        (\_ -> Left "`Types` cannot be an object")
        j

decodeAdditionalProperties :: Maybe Json -> Either Error (Either Boolean JSONSchema)
decodeAdditionalProperties Nothing = Right $ Left true
decodeAdditionalProperties (Just j)
    | isBoolean j = do
        b <- decodeJson j
        pure $ Left b
    | otherwise = do
        js <- decodeJson j
        pure $ Right js

instance decodeJsonSchema :: DecodeJson JSONSchema where
    decodeJson j = do
        obj <- decodeJson j
        definitions <- obj .?? "definitions"
        ref <- obj .?? "$ref"

        typ <- obj .?? "type"
        -- TODO this sucks
        types <- maybe (pure Nothing) (map Just) (decodeTypes <$> typ)

        oneOf <- obj .?? "oneOf"
        properties <- obj .?? "properties"
        additionalProperties <- decodeAdditionalProperties $ SM.lookup "additionalProperties" obj
        items <- obj .?? "items"
        required <- obj .?? "required"
        title <- obj .?? "title"
        pure $ JSONSchema { definitions, ref, types, oneOf, properties, additionalProperties, items, required, title }

lookupRef :: JSONSchema -> List PathElement -> JSONSchema -> Either Error JSONSchema
lookupRef root ref local@(JSONSchema { definitions }) =
    case ref of
    L.Nil -> Right local
    Root : rest -> lookupRef root rest root
    Definition name : rest ->
        case definitions of
        Just sm ->
            case SM.lookup name sm of
            Just js -> lookupRef root rest js
            Nothing -> Left "Reference not found"
        Nothing -> Left "Definitions not found"

jsonUnifyTypes :: IRType -> IRType -> JsonIR IRType
jsonUnifyTypes a b = StateT.lift $ unifyTypes a b

toIRAndUnify :: forall a f. Foldable f => (a -> JsonIR IRType) -> f a -> JsonIR IRType
toIRAndUnify toIR l = do
    irs <- mapM toIR $ L.fromFoldable l
    foldM jsonUnifyTypes IRAnything irs

jsonSchemaToIR :: JSONSchema -> Named String -> JSONSchema -> JsonIR IRType
jsonSchemaToIR root name schema@(JSONSchema { definitions, ref, types, oneOf, properties, additionalProperties, items, required })
    | Just (JSONSchemaRef { path, name }) <- ref =
        case lookupRef root (NEL.toList path) schema of
        Left err -> throwError err
        Right js -> jsonSchemaToIR root (maybe (Inferred "Something") Given name) js
    | Just (Left jt) <- types =
        jsonTypeToIR root name jt schema
    | Just (Right jts) <- types =
        toIRAndUnify (\jt -> jsonTypeToIR root name jt schema) jts
    | Just jss <- oneOf =
        toIRAndUnify (jsonSchemaToIR root name) jss
    | otherwise =
        pure IRAnything

jsonSchemaListToIR :: forall t. Traversable t => Named String -> t JSONSchema -> IR IRType
jsonSchemaListToIR name l = do
    irTypes <- StateT.evalStateT (mapM (\js -> jsonSchemaToIR js name js) l) unit
    foldM unifyTypes IRAnything irTypes

jsonTypeToIR :: JSONSchema -> Named String -> JSONType -> JSONSchema -> JsonIR IRType
jsonTypeToIR root name jsonType (JSONSchema schema) =
    case jsonType of
    JSONObject ->
        case schema.properties of
        Just sm -> do
            let propMap = M.fromFoldable $ SM.toUnfoldable sm :: Array (Tuple String JSONSchema)
            props <- mapMapM (\n -> jsonSchemaToIR root $ Inferred n) propMap
            let required = maybe S.empty S.fromFoldable schema.required
            let title = maybe name Given schema.title
            nulled <- mapMapM (\n -> if S.member n required then pure else jsonUnifyTypes IRNull) props
            StateT.lift $ addClass $ makeClass title nulled
        Nothing ->
            case schema.additionalProperties of
            Left true ->
                pure $ IRMap IRAnything
            Left false ->
                pure $ IRAnything
            Right js -> do
                ir <- jsonSchemaToIR root singularName js
                pure $ IRMap ir
    JSONArray ->
        case schema.items of
        Just js -> do
            ir <- jsonSchemaToIR root singularName js
            pure $ IRArray ir
        Nothing -> pure $ IRArray IRAnything
    JSONBoolean -> pure IRBool
    JSONString -> pure IRString
    JSONNull -> pure IRNull
    JSONInteger -> pure IRInteger
    JSONNumber -> pure IRDouble
    where
        singularName = Inferred $ singular $ namedValue name

forbiddenNames :: Array String
forbiddenNames = []

renderer :: Renderer
renderer =
    { name: "Schema"
    , aceMode: "json"
    , extension: "schema"
    , doc: jsonSchemaDoc
    , options: []
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: noForbidNamer jsonNameStyle -- FIXME: put title on top levels, too
        , unions: Nothing
        }
    }

legalize :: String -> String
legalize s =
    String.fromCharArray $ map (\c -> if isLegal c then c else '_') (String.toCharArray s)
    where
        isLegal c =
            let cc = Char.toCharCode c
            in cc >= 32 && cc < 128 && c /= '/'

jsonNameStyle :: String -> String
jsonNameStyle =
    legalize >>> camelCase >>> capitalize

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

typeStrMap :: String -> Doc (StrMap Json)
typeStrMap s = pure $ SM.insert "type" (fromString s) SM.empty

typeJson :: String -> Doc Json
typeJson s = fromObject <$> typeStrMap s

strMapForType :: IRType -> Doc (StrMap Json)
strMapForType t =
    case t of
    IRAnything -> pure $ SM.empty
    IRNull -> typeStrMap "null"
    IRInteger -> typeStrMap "integer"
    IRDouble -> typeStrMap "number"
    IRBool -> typeStrMap "boolean"
    IRString -> typeStrMap "string"
    IRArray a -> do
        itemType <- jsonForType a
        sm <- typeStrMap "array"
        pure $ SM.insert "items" itemType sm
    IRClass i -> do
        name <- lookupClassName i
        pure $ SM.insert "$ref" (fromString $ "#/definitions/" <> name) SM.empty
    IRMap m -> do
        propertyType <- jsonForType m
        sm <- typeStrMap "object"
        pure $ SM.insert "additionalProperties" propertyType sm
    IRUnion ur -> do
        types <- mapUnionM jsonForType ur
        let typesJson = fromArray $ A.fromFoldable types
        pure $ SM.insert "oneOf" typesJson SM.empty

jsonForType :: IRType -> Doc Json
jsonForType t = do
    sm <- strMapForType t
    pure $ fromObject sm

strMapForOneOfTypes :: List IRType -> Doc (StrMap Json)
strMapForOneOfTypes L.Nil = pure $ SM.empty
strMapForOneOfTypes (t : L.Nil) = strMapForType t
strMapForOneOfTypes typeList = do
    objList <- mapM jsonForType typeList
    pure $ SM.insert "oneOf" (fromArray $ A.fromFoldable objList) SM.empty

definitionForClass :: Tuple Int IRClassData -> Doc (Tuple String Json)
definitionForClass (Tuple i (IRClassData { names, properties })) = do
    className <- lookupClassName i
    let sm = SM.insert "additionalProperties" (fromBoolean false) $ SM.insert "type" (fromString "object") SM.empty
    propsMap <- mapMapM (const jsonForType) properties
    let requiredProps = A.fromFoldable $ map fromString $ M.keys $ M.filter (\t -> not $ canBeNull t) properties
    let propsSM = SM.fromFoldable $ (M.toUnfoldable propsMap :: List (Tuple String Json))
    let withProperties = SM.insert "properties" (fromObject propsSM) sm
    let withRequired = SM.insert "required" (fromArray requiredProps) withProperties
    let withTitle = SM.insert "title" (fromString $ combineNames names) withRequired
    pure $ Tuple className $ fromObject withTitle

irToJson :: Doc Json
irToJson = do
    classes <- getClasses
    definitions <- fromObject <$> SM.fromFoldable <$> mapM definitionForClass classes
    -- FIXME: give a title to top-levels, too
    topLevel <- strMapForOneOfTypes =<< M.values <$> getTopLevels
    let sm = SM.insert "definitions" definitions topLevel
    pure $ fromObject sm

jsonSchemaDoc :: Doc Unit
jsonSchemaDoc = do
    json <- irToJson
    line $ stringifyWithSpace "    " json

module Language.JsonSchema where

import Core (class Eq, class Ord, Error, Unit, bind, const, map, not, otherwise, pure, ($), (&&), (/=), (<), (<$>), (<>), (=<<), (>=), (>>>))

import Doc (Doc, Renderer, combineNames, getClasses, getTopLevels, line, lookupClassName, noForbidNamer, simpleNamer)
import IRGraph
import Control.Monad.Error.Class (throwError)

import Data.Argonaut.Core (Json, foldJson, fromArray, fromBoolean, fromObject, fromString, isBoolean, stringifyWithSpace)
import Data.Argonaut.Decode ((.??), decodeJson, class DecodeJson)
import Data.Array as A
import Data.Char as Char
import Data.Either (Either(Right, Left))
import Data.Foldable (class Foldable, foldM)
import Data.List (List, (:))
import Data.List as L
import Data.List.NonEmpty as NEL

import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Set (Set)
import Data.Set as S
import Data.StrMap (StrMap)
import Data.StrMap as SM
import Data.String as String
import Data.String.Util (camelCase, capitalize, singular)
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(..))
import IR (IR, addClass, unifyTypes)
import Utils (mapM, mapMapM)

data JSONType
    = JSONObject
    | JSONArray
    | JSONBoolean
    | JSONString
    | JSONNull
    | JSONInteger
    | JSONNumber

derive instance eqJSONType :: Eq JSONType
derive instance ordJSONType :: Ord JSONType

jsonTypeEnumMap :: StrMap JSONType
jsonTypeEnumMap = SM.fromFoldable [
    Tuple "object" JSONObject, Tuple "array" JSONArray, Tuple "boolean" JSONBoolean,
    Tuple "string" JSONString, Tuple "null" JSONNull, Tuple "integer" JSONInteger,
    Tuple "number" JSONNumber
    ]

data PathElement
    = Root
    | Definition String

newtype JSONSchemaRef = JSONSchemaRef
    { path :: NEL.NonEmptyList PathElement
    , name :: Maybe String
    }

newtype JSONSchema = JSONSchema
    { definitions :: Maybe (StrMap JSONSchema)
    , ref :: Maybe JSONSchemaRef
    , types :: Maybe (Either JSONType (Set JSONType))
    , oneOf :: Maybe (Array JSONSchema)
    , properties :: Maybe (StrMap JSONSchema)
    , additionalProperties :: Either Boolean JSONSchema
    , items :: Maybe JSONSchema
    , required :: Maybe (Array String)
    , title :: Maybe String
    }

decodeEnum :: forall a. StrMap a -> Json -> Either Error a
decodeEnum sm j = do
    key <- decodeJson j
    maybe (Left "Unexpected enum key") Right $ SM.lookup key sm

instance decodeJsonType :: DecodeJson JSONType where
    decodeJson = decodeEnum jsonTypeEnumMap

instance decodeJsonSchemaRef :: DecodeJson JSONSchemaRef where
    decodeJson j = do
        refString :: String <- decodeJson j
        let pathElementsStrings = String.split (String.Pattern "/") refString
        parsed <- parseJsonSchemaRef $ L.fromFoldable pathElementsStrings
        case NEL.fromList parsed of
            Nothing -> Left "Reference must contain at least one path element"
            Just path -> pure $ JSONSchemaRef { path, name: A.last pathElementsStrings }

parseJsonSchemaRef :: List String -> Either Error (List PathElement)
parseJsonSchemaRef L.Nil =
    pure L.Nil
parseJsonSchemaRef ("#" : rest) = do
    restParsed <- parseJsonSchemaRef rest
    pure $ Root : restParsed
parseJsonSchemaRef ("definitions" : name : rest) = do
    restParsed <- parseJsonSchemaRef rest
    pure $ Definition name : restParsed
parseJsonSchemaRef _ =
    Left "Could not parse JSON Schema reference"

decodeTypes :: Json -> Either Error (Either JSONType (Set JSONType))
decodeTypes j =
    foldJson
        (\_ -> Left "`types` cannot be null")
        (\_ -> Left "`types` cannot be a boolean")
        (\_ -> Left "`types` cannot be a number")
        (\s -> do
            t <- decodeEnum jsonTypeEnumMap j
            pure $ Left t)
        (\a -> do
            l <- traverse (decodeEnum jsonTypeEnumMap) a
            pure $ Right $ S.fromFoldable l)
        (\_ -> Left "`Types` cannot be an object")
        j

decodeAdditionalProperties :: Maybe Json -> Either Error (Either Boolean JSONSchema)
decodeAdditionalProperties Nothing = Right $ Left true
decodeAdditionalProperties (Just j)
    | isBoolean j = do
        b <- decodeJson j
        pure $ Left b
    | otherwise = do
        js <- decodeJson j
        pure $ Right js

instance decodeJsonSchema :: DecodeJson JSONSchema where
    decodeJson j = do
        obj <- decodeJson j
        definitions <- obj .?? "definitions"
        ref <- obj .?? "$ref"

        typ <- obj .?? "type"
        -- TODO this sucks
        types <- maybe (pure Nothing) (map Just) (decodeTypes <$> typ)

        oneOf <- obj .?? "oneOf"
        properties <- obj .?? "properties"
        additionalProperties <- decodeAdditionalProperties $ SM.lookup "additionalProperties" obj
        items <- obj .?? "items"
        required <- obj .?? "required"
        title <- obj .?? "title"
        pure $ JSONSchema { definitions, ref, types, oneOf, properties, additionalProperties, items, required, title }

lookupRef :: JSONSchema -> List PathElement -> JSONSchema -> Either Error JSONSchema
lookupRef root ref local@(JSONSchema { definitions }) =
    case ref of
    L.Nil -> Right local
    Root : rest -> lookupRef root rest root
    Definition name : rest ->
        case definitions of
        Just sm ->
            case SM.lookup name sm of
            Just js -> lookupRef root rest js
            Nothing -> Left "Reference not found"
        Nothing -> Left "Definitions not found"

toIRAndUnify :: forall a f. Foldable f => (a -> IR IRType) -> f a -> IR IRType
toIRAndUnify toIR l = do
    irs <- mapM toIR $ L.fromFoldable l
    foldM unifyTypes IRAnything irs

jsonSchemaToIR :: JSONSchema -> Named String -> JSONSchema -> IR IRType
jsonSchemaToIR root name schema@(JSONSchema { definitions, ref, types, oneOf, properties, additionalProperties, items, required })
    | Just (JSONSchemaRef { path, name }) <- ref =
        case lookupRef root (NEL.toList path) schema of
        Left err -> throwError err
        Right js -> jsonSchemaToIR root (maybe (Inferred "Something") Given name) js
    | Just (Left jt) <- types =
        jsonTypeToIR root name jt schema
    | Just (Right jts) <- types =
        toIRAndUnify (\jt -> jsonTypeToIR root name jt schema) jts
    | Just jss <- oneOf =
        toIRAndUnify (jsonSchemaToIR root name) jss
    | otherwise =
        pure IRAnything

jsonSchemaListToIR :: forall t. Traversable t => Named String -> t JSONSchema -> IR IRType
jsonSchemaListToIR name l = do
    irTypes <- mapM (\js -> jsonSchemaToIR js name js) l
    foldM unifyTypes IRAnything irTypes

jsonTypeToIR :: JSONSchema -> Named String -> JSONType -> JSONSchema -> IR IRType
jsonTypeToIR root name jsonType (JSONSchema schema) =
    case jsonType of
    JSONObject ->
        case schema.properties of
        Just sm -> do
            let propMap = M.fromFoldable $ SM.toUnfoldable sm :: Array (Tuple String JSONSchema)
            props <- mapMapM (\n -> jsonSchemaToIR root $ Inferred n) propMap
            let required = maybe S.empty S.fromFoldable schema.required
            let title = maybe name Given schema.title
            nulled <- mapMapM (\n -> if S.member n required then pure else unifyTypes IRNull) props
            addClass $ makeClass title nulled
        Nothing ->
            case schema.additionalProperties of
            Left true ->
                pure $ IRMap IRAnything
            Left false ->
                pure $ IRAnything
            Right js -> do
                ir <- jsonSchemaToIR root singularName js
                pure $ IRMap ir
    JSONArray ->
        case schema.items of
        Just js -> do
            ir <- (jsonSchemaToIR root singularName) js
            pure $ IRArray ir
        Nothing -> pure $ IRArray IRAnything
    JSONBoolean -> pure IRBool
    JSONString -> pure IRString
    JSONNull -> pure IRNull
    JSONInteger -> pure IRInteger
    JSONNumber -> pure IRDouble
    where
        singularName = Inferred $ singular $ namedValue name

forbiddenNames :: Array String
forbiddenNames = []

renderer :: Renderer
renderer =
    { name: "Schema"
    , aceMode: "json"
    , extension: "schema"
    , doc: jsonSchemaDoc
    , options: []
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: noForbidNamer jsonNameStyle -- FIXME: put title on top levels, too
        , unions: Nothing
        }
    }

legalize :: String -> String
legalize s =
    String.fromCharArray $ map (\c -> if isLegal c then c else '_') (String.toCharArray s)
    where
        isLegal c =
            let cc = Char.toCharCode c
            in cc >= 32 && cc < 128 && c /= '/'

jsonNameStyle :: String -> String
jsonNameStyle =
    legalize >>> camelCase >>> capitalize

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

typeStrMap :: String -> Doc (StrMap Json)
typeStrMap s = pure $ SM.insert "type" (fromString s) SM.empty

typeJson :: String -> Doc Json
typeJson s = fromObject <$> typeStrMap s

strMapForType :: IRType -> Doc (StrMap Json)
strMapForType t =
    case t of
    IRAnything -> pure $ SM.empty
    IRNull -> typeStrMap "null"
    IRInteger -> typeStrMap "integer"
    IRDouble -> typeStrMap "number"
    IRBool -> typeStrMap "boolean"
    IRString -> typeStrMap "string"
    IRArray a -> do
        itemType <- jsonForType a
        sm <- typeStrMap "array"
        pure $ SM.insert "items" itemType sm
    IRClass i -> do
        name <- lookupClassName i
        pure $ SM.insert "$ref" (fromString $ "#/definitions/" <> name) SM.empty
    IRMap m -> do
        propertyType <- jsonForType m
        sm <- typeStrMap "object"
        pure $ SM.insert "additionalProperties" propertyType sm
    IRUnion ur -> do
        types <- mapUnionM jsonForType ur
        let typesJson = fromArray $ A.fromFoldable types
        pure $ SM.insert "oneOf" typesJson SM.empty

jsonForType :: IRType -> Doc Json
jsonForType t = do
    sm <- strMapForType t
    pure $ fromObject sm

strMapForOneOfTypes :: List IRType -> Doc (StrMap Json)
strMapForOneOfTypes L.Nil = pure $ SM.empty
strMapForOneOfTypes (t : L.Nil) = strMapForType t
strMapForOneOfTypes typeList = do
    objList <- mapM jsonForType typeList
    pure $ SM.insert "oneOf" (fromArray $ A.fromFoldable objList) SM.empty

definitionForClass :: Tuple Int IRClassData -> Doc (Tuple String Json)
definitionForClass (Tuple i (IRClassData { names, properties })) = do
    className <- lookupClassName i
    let sm = SM.insert "additionalProperties" (fromBoolean false) $ SM.insert "type" (fromString "object") SM.empty
    propsMap <- mapMapM (const jsonForType) properties
    let requiredProps = A.fromFoldable $ map fromString $ M.keys $ M.filter (\t -> not $ canBeNull t) properties
    let propsSM = SM.fromFoldable $ (M.toUnfoldable propsMap :: List (Tuple String Json))
    let withProperties = SM.insert "properties" (fromObject propsSM) sm
    let withRequired = SM.insert "required" (fromArray requiredProps) withProperties
    let withTitle = SM.insert "title" (fromString $ combineNames names) withRequired
    pure $ Tuple className $ fromObject withTitle

irToJson :: Doc Json
irToJson = do
    classes <- getClasses
    definitions <- fromObject <$> SM.fromFoldable <$> mapM definitionForClass classes
    -- FIXME: give a title to top-levels, too
    topLevel <- strMapForOneOfTypes =<< M.values <$> getTopLevels
    let sm = SM.insert "definitions" definitions topLevel
    pure $ fromObject sm

jsonSchemaDoc :: Doc Unit
jsonSchemaDoc = do
    json <- irToJson
    line $ stringifyWithSpace "    " json


Fix HOC test for renamed component' function

module Example.HOC.HOC where

import Prelude

import Control.Monad.Error.Class (class MonadError, throwError)
import Data.Maybe (Maybe(..))
import Data.Symbol (SProxy(..))
import Effect.Exception as Exn
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE

data Action o
  = Toggle
  | Reset
  | HandleInner o

type State i =
  -- | State of the HOC itself
  { on :: Boolean
  -- | Keep track of inputs that we pass through to the inner component
  , input :: i
  }

class CanSet f where
  set :: Boolean -> H.Action f

type ChildSlots f o =
  ( child :: H.Slot f o Unit
  )

_child = SProxy :: SProxy "child"

-- | Takes a component and wraps it to produce a new component with added
-- | functionality.
-- |
-- | For the sake of this example, we require that all components that this
-- | factory wraps implement the `CanSet` typeclass, i.e. something in them
-- | can be "set" by giving a boolean.
-- |
-- | `f`, `i`, `o` are the query, input and output types of the wrapped
-- | component.
factory
  :: forall f i o m
   . CanSet f
  => MonadError Exn.Error m
  => H.Component HH.HTML f i o m
  -> H.Component HH.HTML f i o m
factory innerComponent =
  H.mkComponent
    { initialState: { on: true, input: _ }
    , render
    , eval
    }

  where

  render :: State i -> H.ComponentHTML' (Action o) (ChildSlots f o) m
  render state =
    HH.div_
      [ HH.hr_
      , HH.p_
        [ HH.button
          [ HE.onClick (\_ -> Just Toggle) ]
          [ HH.text "Toggle wrapper state" ]
        , HH.text $ " Wrapper state: " <> if state.on then "on" else "off"
        ]
      , HH.p_
        [ HH.button
          [ HE.onClick (\_ -> Just Reset) ]
          [ HH.text "Set inner component to off" ]
        ]
      , HH.p_
        [ HH.slot _child unit innerComponent state.input (Just <<< HandleInner)
        ]
      , HH.hr_
      ]

  eval
    :: H.HalogenQ f (Action o) i
    ~> H.HalogenM' (State i) (Action o) (ChildSlots f o) o m
  eval = case _ of
    H.Initialize a -> pure a
    H.Finalize a -> pure a
    H.Receive i a -> H.modify_ (_ { input = i }) $> a
    H.Handle msg a ->
      a <$ case msg of
        Toggle -> H.modify_ (\state -> state { on = not state.on })
        Reset -> void $ H.query _child unit $ H.action (set false)
        HandleInner o -> H.raise o
    H.Request q ->
      H.query _child unit q >>= case _ of
        Nothing ->
          throwError (Exn.error "HOC inner component query failed (this should be impossible)")
        Just a ->
          pure a

module Example.HOC.HOC where

import Prelude

import Control.Monad.Error.Class (class MonadError, throwError)
import Data.Maybe (Maybe(..))
import Data.Symbol (SProxy(..))
import Effect.Exception as Exn
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE

data Action o
  = Toggle
  | Reset
  | HandleInner o

type State i =
  -- | State of the HOC itself
  { on :: Boolean
  -- | Keep track of inputs that we pass through to the inner component
  , input :: i
  }

class CanSet f where
  set :: Boolean -> H.Action f

type ChildSlots f o =
  ( child :: H.Slot f o Unit
  )

_child = SProxy :: SProxy "child"

-- | Takes a component and wraps it to produce a new component with added
-- | functionality.
-- |
-- | For the sake of this example, we require that all components that this
-- | factory wraps implement the `CanSet` typeclass, i.e. something in them
-- | can be "set" by giving a boolean.
-- |
-- | `f`, `i`, `o` are the query, input and output types of the wrapped
-- | component.
factory
  :: forall f i o m
   . CanSet f
  => MonadError Exn.Error m
  => H.Component HH.HTML f i o m
  -> H.Component HH.HTML f i o m
factory innerComponent =
  H.component'
    { initialState: { on: true, input: _ }
    , render
    , eval
    }

  where

  render
    :: State i
    -> H.ComponentHTML' (Action o) (ChildSlots f o) m
  render state =
    HH.div_
      [ HH.hr_
      , HH.p_
        [ HH.button
          [ HE.onClick (\_ -> Just Toggle) ]
          [ HH.text "Toggle wrapper state" ]
        , HH.text $ " Wrapper state: " <> if state.on then "on" else "off"
        ]
      , HH.p_
        [ HH.button
          [ HE.onClick (\_ -> Just Reset) ]
          [ HH.text "Set inner component to off" ]
        ]
      , HH.p_
        [ HH.slot _child unit innerComponent state.input (Just <<< HandleInner)
        ]
      , HH.hr_
      ]

  eval
    :: H.HalogenQ f (Action o) i
    ~> H.HalogenM' (State i) (Action o) (ChildSlots f o) o m
  eval = case _ of
    H.Initialize a -> pure a
    H.Finalize a -> pure a
    H.Receive i a -> H.modify_ (_ { input = i }) $> a
    H.Handle msg a ->
      a <$ case msg of
        Toggle -> H.modify_ (\state -> state { on = not state.on })
        Reset -> void $ H.query _child unit $ H.action (set false)
        HandleInner o -> H.raise o
    H.Request q ->
      H.query _child unit q >>= case _ of
        Nothing ->
          throwError (Exn.error "HOC inner component query failed (this should be impossible)")
        Just a ->
          pure a


Fix bad docs (#72)

Fix bad docs (#72)

module HTTPure.Query
  ( Query
  , read
  ) where

import Prelude

import Data.Array as Array
import Data.Maybe as Maybe
import Data.String as String
import Data.StrMap as StrMap
import Data.Tuple as Tuple
import Node.HTTP as HTTP

-- | The `Query` type is a `StrMap` of `Strings`, with one entry per query
-- | parameter in the request. For any query parameters that don't have values
-- | (`/some/path?query`), the value in the `StrMap` for that parameter will be
-- | the string `"true"`. Note that this type has an implementation of `Lookup`
-- | for `String` keys defined by `lookpStrMap` in [Lookup.purs](./Lookup.purs)
-- | because `lookupStrMap` is defined for any `StrMap` of `Monoids`. So you can
-- | do something like `query !! "foo"` to get the value of the query parameter
-- | "foo".
type Query = StrMap.StrMap String

-- | The `StrMap` of query segments in the given HTTP `Request`.
read :: HTTP.Request -> Query
read =
  HTTP.requestURL >>> split "?" >>> last >>> split "&" >>> nonempty >>> toStrMap
  where
    toStrMap = map toTuple >>> StrMap.fromFoldable
    nonempty = Array.filter ((/=) "")
    split = String.Pattern >>> String.split
    first = Array.head >>> Maybe.fromMaybe ""
    last = Array.tail >>> Maybe.fromMaybe [] >>> String.joinWith ""
    toTuple item = Tuple.Tuple (first itemParts) $ value $ last itemParts
      where
        value val = if val == "" then "true" else val
        itemParts = split "=" item

module HTTPure.Query
  ( Query
  , read
  ) where

import Prelude

import Data.Array as Array
import Data.Maybe as Maybe
import Data.String as String
import Data.StrMap as StrMap
import Data.Tuple as Tuple
import Node.HTTP as HTTP

-- | The `Query` type is a `StrMap` of `Strings`, with one entry per query
-- | parameter in the request. For any query parameters that don't have values
-- | (`/some/path?query`), the value in the `StrMap` for that parameter will be
-- | the string `"true"`. Note that this type has an implementation of `Lookup`
-- | for `String` keys defined by `lookpStrMap` in `Lookup.purs` because
-- | `lookupStrMap` is defined for any `StrMap` of `Monoids`. So you can do
-- | something like `query !! "foo"` to get the value of the query parameter
-- | "foo".
type Query = StrMap.StrMap String

-- | The `StrMap` of query segments in the given HTTP `Request`.
read :: HTTP.Request -> Query
read =
  HTTP.requestURL >>> split "?" >>> last >>> split "&" >>> nonempty >>> toStrMap
  where
    toStrMap = map toTuple >>> StrMap.fromFoldable
    nonempty = Array.filter ((/=) "")
    split = String.Pattern >>> String.split
    first = Array.head >>> Maybe.fromMaybe ""
    last = Array.tail >>> Maybe.fromMaybe [] >>> String.joinWith ""
    toTuple item = Tuple.Tuple (first itemParts) $ value $ last itemParts
      where
        value val = if val == "" then "true" else val
        itemParts = split "=" item