fixed stupid rounding errors

fixed stupid rounding errors

module Weekend where

import Prelude

import Control.Apply (lift2)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Now (NOW, locale, now)
import Data.DateTime (DateTime, adjust, date, diff, modifyTime, setHour, setMinute, setSecond, setMillisecond, weekday)
import Data.DateTime.Instant (toDateTime)
import Data.DateTime.Locale (Locale(..))
import Data.Either (either)
import Data.Enum (fromEnum, toEnum)
import Data.Formatter.DateTime (formatDateTime)
import Data.Formatter.Number (Formatter(..), format)
import Data.Int (floor, toNumber)
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.Newtype (unwrap)
import Data.Time.Duration (Days(..), Hours(..), Milliseconds, Minutes(..), Seconds, convertDuration)

weekendStartDayOfWeek :: Int
weekendStartDayOfWeek = 5

weekendStartHour :: Int
weekendStartHour = 17

offset :: forall eff. Eff (now :: NOW | eff) Minutes
offset = map (\(Locale _ min) -> negate min) locale

currentLocalTime :: forall eff. Eff (now :: NOW | eff) DateTime
currentLocalTime = map (fromMaybe bottom) effMaybeDateTime
  where
  effMaybeDateTime = lift2 adjust offset (map toDateTime now)

formattedCurrentTime :: forall eff. Eff (now :: NOW | eff) String
formattedCurrentTime = map toString currentLocalTime
  where
  toString dateTime = let workaroundForWeekday = show $ weekday $ date dateTime
                          formattedDate = (formatDateTime "HH:mm" >>> either (const "ERROR") id) dateTime
                       in workaroundForWeekday <> ", " <> formattedDate

isWeekend :: forall eff. Eff (now :: NOW | eff) Boolean
isWeekend = map isNothing durationTillWeekend

durationTillWeekend :: forall eff. Eff (now :: NOW | eff) (Maybe String)
durationTillWeekend = map testWeekend currentLocalTime
  where
  testWeekend now =
    let dayOfWeek = fromEnum $ weekday $ date now
        dayDiff   = Days $ toNumber (weekendStartDayOfWeek - dayOfWeek)
        startDate = fromMaybe bottom $ adjust dayDiff now
        startDatetime = modifyTime ((setHour $ fromMaybe bottom $ toEnum weekendStartHour) >>> (setMinute $ fromMaybe bottom $ toEnum 0) >>> (setSecond $ fromMaybe bottom $ toEnum 0) >>> (setMillisecond $ fromMaybe bottom $ toEnum 0)) startDate
        timeFormatter = Formatter { comma: false, before: 2, after: 0, abbreviations: false, sign: false }
        millisFormatter = Formatter { comma: false, before: 3, after: 0, abbreviations: false, sign: false }
        diffMillis :: Milliseconds
        diffMillis = diff startDatetime now
    in if startDatetime < now
       then Nothing
       else Just let d :: Days
                     d  = convertDuration diffMillis
                     d' = floor $ unwrap d
                     dd = show d'
                     h :: Hours
                     h  = convertDuration $ d - (Days $ toNumber d')
                     h' = toNumber $ floor $ unwrap h
                     hh = format timeFormatter h'
                     m :: Minutes
                     m  = convertDuration $ h - (Hours h')
                     m' = toNumber $ floor $ unwrap m
                     mm = format timeFormatter m'
                     s :: Seconds
                     s  = convertDuration $ m - (Minutes m')
                     s' = toNumber $ floor $ unwrap s
                     ss = format timeFormatter s'
                 in (if d' > 0 then dd <> " days and " else "") <> hh <> ":" <> mm <> ":" <> ss

module Weekend where

import Prelude

import Control.Apply (lift2)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Now (NOW, locale, now)
import Data.DateTime (DateTime, adjust, date, diff, modifyTime, setHour, setMinute, setSecond, weekday)
import Data.DateTime.Instant (toDateTime)
import Data.DateTime.Locale (Locale(..))
import Data.Either (either)
import Data.Enum (fromEnum, toEnum)
import Data.Formatter.DateTime (formatDateTime)
import Data.Formatter.Number (Formatter(..), format)
import Data.Int (floor, toNumber)
import Data.Maybe (Maybe(..), fromMaybe, isNothing)
import Data.Newtype (unwrap)
import Data.Time.Duration (Days(..), Hours(..), Milliseconds, Minutes(..), Seconds, convertDuration)

weekendStartDayOfWeek :: Int
weekendStartDayOfWeek = 5

weekendStartHour :: Int
weekendStartHour = 17

offset :: forall eff. Eff (now :: NOW | eff) Minutes
offset = map (\(Locale _ min) -> negate min) locale

currentLocalTime :: forall eff. Eff (now :: NOW | eff) DateTime
currentLocalTime = map (fromMaybe bottom) effMaybeDateTime
  where
  effMaybeDateTime = lift2 adjust offset (map toDateTime now)

formattedCurrentTime :: forall eff. Eff (now :: NOW | eff) String
formattedCurrentTime = map toString currentLocalTime
  where
  toString dateTime = let workaroundForWeekday = show $ weekday $ date dateTime
                          formattedDate = (formatDateTime "HH:mm" >>> either (const "ERROR") id) dateTime
                       in workaroundForWeekday <> ", " <> formattedDate

isWeekend :: forall eff. Eff (now :: NOW | eff) Boolean
isWeekend = map isNothing durationTillWeekend

durationTillWeekend :: forall eff. Eff (now :: NOW | eff) (Maybe String)
durationTillWeekend = map testWeekend currentLocalTime
  where
  testWeekend now =
    let dayOfWeek = fromEnum $ weekday $ date now
        dayDiff   = Days $ toNumber (weekendStartDayOfWeek - dayOfWeek)
        startDate = fromMaybe bottom $ adjust dayDiff now
        startDatetime = modifyTime ((setHour $ fromMaybe bottom $ toEnum weekendStartHour) >>> (setMinute $ fromMaybe bottom $ toEnum 0) >>> (setSecond $ fromMaybe bottom $ toEnum 0)) startDate
        timeFormatter = Formatter { comma: false, before: 2, after: 0, abbreviations: false, sign: false }
        millisFormatter = Formatter { comma: false, before: 3, after: 0, abbreviations: false, sign: false }
        diffMillis :: Milliseconds
        diffMillis = diff startDatetime now
    in if startDatetime < now
       then Nothing
       else Just let d :: Days
                     d  = convertDuration diffMillis
                     d' = floor $ unwrap d
                     dd = show d'
                     h :: Hours
                     h  = convertDuration $ d - (Days $ toNumber d')
                     h' = toNumber $ floor $ unwrap h
                     hh = format timeFormatter h'
                     m :: Minutes
                     m  = convertDuration $ h - (Hours h')
                     m' = toNumber $ floor $ unwrap m
                     mm = format timeFormatter m'
                     s :: Seconds
                     s  = convertDuration $ m - (Minutes m')
                     s' = toNumber $ floor $ unwrap s
                     ss = format timeFormatter s'
                 in (if d' > 0 then dd <> " days and " else "") <> hh <> ":" <> mm <> ":" <> ss


Fixed max carrying weight display

Fixed max carrying weight display

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 Debug.Trace
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

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

drawFrame :: Console -> ConsoleEff Unit
drawFrame console = do
    drawString console leftSideFrame  "990000" 0 0
    drawString console rightSideFrame "990000" 79 0
    drawString console bar "990000" 1 0
    drawString console bar "990000" 1 19
    where
        rightSideFrame :: String
        rightSideFrame = fromCode 187 ++ "\n" ++ joinWith "\n" (replicate 18 $ fromCode 186) ++ "\n" ++ fromCode 188

        leftSideFrame :: String
        leftSideFrame = fromCode 201 ++ "\n" ++ joinWith "\n" (replicate 18 $ fromCode 186) ++ "\n" ++ fromCode 200

        bar :: String
        bar = foldl (++) "" (replicate 78 $ fromCode 205)

-- Draws the game state.
drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console g@(Game state@{ window = SkillW }) = do
    clear console
    drawString console ("Name: " ++ state.playerName ++ "   " ++ "Total score: " ++ show state.pointsTotal) "AAAAAA" 2 2
    drawFrame console
    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
    drawFrame 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, equipments = eq, player = pl }) = do
    clear console
    drawFrame 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 (M.values eq) + carryingWeight inv )) ++ "/" ++ show (maxCarryingCapacity pl) ++ ")") "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 ("Loot collected " ++ show (lootPercentage g) ++ "%") lootColor 13 24
    drawString console ("Movement mode: " ++ show state.move ++ "   Speed: " ++ show (calcSpeed g)) "FF0000" 33 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
        lootColor :: String
        lootColor | lootPercentage g >= 50 = "00FF00"
        lootColor | otherwise              = "FF0000"

        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 241) "FF0000"
        drawCreatureType d Guard   = d (fromCode 240) "0000FF"
        drawCreatureType d Archer  = d (fromCode 242) "FF2EB9"
        drawCreatureType d Peasant = d (fromCode 241) "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 "(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
    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 g@(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 g

drawGame console g@(Victory state) = do
    clear console
    drawString console ("Congratulations " ++ state.playerName ++ "!\n\nYou have proved that you are a master thief.\n\nYour final score is " ++ show state.points ++ ".") "AAAAAA" 5 5
    drawString console "Press Enter to continue" "AAAAAA" 5 15
    return g

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 Debug.Trace
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

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

drawFrame :: Console -> ConsoleEff Unit
drawFrame console = do
    drawString console leftSideFrame  "990000" 0 0
    drawString console rightSideFrame "990000" 79 0
    drawString console bar "990000" 1 0
    drawString console bar "990000" 1 19
    where
        rightSideFrame :: String
        rightSideFrame = fromCode 187 ++ "\n" ++ joinWith "\n" (replicate 18 $ fromCode 186) ++ "\n" ++ fromCode 188

        leftSideFrame :: String
        leftSideFrame = fromCode 201 ++ "\n" ++ joinWith "\n" (replicate 18 $ fromCode 186) ++ "\n" ++ fromCode 200

        bar :: String
        bar = foldl (++) "" (replicate 78 $ fromCode 205)

-- Draws the game state.
drawGame :: Console -> GameState -> ConsoleEff GameState
drawGame console g@(Game state@{ window = SkillW }) = do
    clear console
    drawString console ("Name: " ++ state.playerName ++ "   " ++ "Total score: " ++ show state.pointsTotal) "AAAAAA" 2 2
    drawFrame console
    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
    drawFrame 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, equipments = eq, player = pl }) = do
    clear console
    drawFrame 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 (M.values eq) + carryingWeight inv )) ++ "/" ++ maxCarryingCapacity pl) "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 ("Loot collected " ++ show (lootPercentage g) ++ "%") lootColor 13 24
    drawString console ("Movement mode: " ++ show state.move ++ "   Speed: " ++ show (calcSpeed g)) "FF0000" 33 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
        lootColor :: String
        lootColor | lootPercentage g >= 50 = "00FF00"
        lootColor | otherwise              = "FF0000"

        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 241) "FF0000"
        drawCreatureType d Guard   = d (fromCode 240) "0000FF"
        drawCreatureType d Archer  = d (fromCode 242) "FF2EB9"
        drawCreatureType d Peasant = d (fromCode 241) "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 "(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
    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 g@(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 g

drawGame console g@(Victory state) = do
    clear console
    drawString console ("Congratulations " ++ state.playerName ++ "!\n\nYou have proved that you are a master thief.\n\nYour final score is " ++ show state.points ++ ".") "AAAAAA" 5 5
    drawString console "Press Enter to continue" "AAAAAA" 5 15
    return g


Update for changes to Data.Array

Update for changes to Data.Array

module Text.Pretty.PatternArrows where

import Prelude
import Data.Tuple (Tuple(..), uncurry)
import Data.Array (map)
import Data.Foldable
import Data.Maybe
import Control.Arrow
import Control.Monad
import Control.Monad.Trans
import Control.Monad.State.Trans

-- |
-- A first-order pattern match
--
-- A pattern is a Kleisli arrow for the @StateT Maybe@ monad. That is, patterns can fail, and can carry user-defined state.
--
data Pattern u a b = Pattern (a -> StateT u Maybe b)

runPattern :: forall u a b. Pattern u a b -> a -> StateT u Maybe b
runPattern (Pattern f) a = f a

instance functorPattern :: Functor (Pattern u a) where
  (<$>) f (Pattern p) = Pattern $ \a -> f <$> p a

instance semigroupoidPattern :: Semigroupoid (Pattern u) where
  (<<<) (Pattern f) (Pattern g) = Pattern $ f <=< g

instance categoryPattern :: Category (Pattern u) where
  id = Pattern $ \a -> return a

instance arrowPattern :: Arrow (Pattern u) where
  arr f = Pattern $ \a -> return $ f a
  first p = Pattern $ \(Tuple b d) -> flip Tuple d <$> runPattern p b

instance arrowZeroPattern :: ArrowZero (Pattern u) where
  azero = Pattern $ \_ -> lift Nothing

instance arrowPlusPattern :: ArrowPlus (Pattern u) where
  (<+>) p q = Pattern $ \a -> StateT $ \s ->
                case runStateT (runPattern p a) s of
                  Nothing -> runStateT (runPattern q a) s
                  Just r -> Just r

-- |
-- Run a pattern with an input and initial user state
--
-- Returns Nothing if the pattern fails to match
--
pattern :: forall u a b. Pattern u a b -> u -> a -> Maybe b
pattern p u = flip evalStateT u <<< runPattern p

-- |
-- Construct a pattern from a function
--
mkPattern :: forall u a b. (a -> Maybe b) -> Pattern u a b
mkPattern f = Pattern $ \a -> lift (f a)

-- |
-- Construct a pattern from a stateful function
--
mkPattern' :: forall u a b. (a -> StateT u Maybe b) -> Pattern u a b
mkPattern' = Pattern

fix :: forall u a r. (Pattern u a r -> Pattern u a r) -> Pattern u a r
fix f = Pattern $ \a -> runPattern (f $ fix f) a

-- |
-- Construct a pattern which recursively matches on the left-hand-side
--
chainl :: forall u a r. Pattern u a (Tuple a a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> arr (uncurry f)

-- |
-- Construct a pattern which recursively matches on the right-hand side
--
chainr :: forall u a r. Pattern u a (Tuple a a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> arr (uncurry f)

-- |
-- Construct a pattern which recursively matches on one-side of a tuple
--
wrap' :: forall u a s r. Pattern u a (Tuple s a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r
wrap' g f p = fix $ \c -> g >>> (id *** (c <+> p)) >>> arr (uncurry f)

-- |
-- Construct a pattern which matches a part of a tuple
--
split' :: forall u a s t r. Pattern u a (Tuple s t) -> (s -> t -> r) -> Pattern u a r
split' s f = s >>> arr (uncurry f)

-- |
-- An operator:
--
--  [@AssocL@] A left-associative operator
--
--  [@AssocR@] A right-associative operator
--
--  [@Wrap@] A prefix-like or postfix-like operator
--
--  [@Split@] A prefix-like or postfix-like operator which does not recurse into its operand
--
class Op op where
  assocL :: forall u a r.     Pattern u a (Tuple a a) -> (r -> r -> r) -> op u a r
  assocR :: forall u a r.     Pattern u a (Tuple a a) -> (r -> r -> r) -> op u a r
  wrap   :: forall u a s r.   Pattern u a (Tuple s a) -> (s -> r -> r) -> op u a r
  split  :: forall u a s t r. Pattern u a (Tuple s t) -> (s -> t -> r) -> op u a r

data Operator u a r = Operator (forall op. (Op op) => op u a r)

-- |
-- A table of operators
--
data OperatorTable u a r = OperatorTable [[Operator u a r]]

runOperatorTable :: forall u a r. OperatorTable u a r -> [[Operator u a r]]
runOperatorTable (OperatorTable table) = table

foldl1 :: forall a. (a -> a -> a) -> [a] -> a
foldl1 f (x:xs) = foldl f x xs

-- |
-- The target data type of the "Op" language, which modifies a Pattern
--
data PatternEndo u a r = PatternEndo (Pattern u a r -> Pattern u a r)

runPatternEndo :: forall u a r. PatternEndo u a r -> Pattern u a r -> Pattern u a r
runPatternEndo (PatternEndo f) p = f p

instance opPatternEndo :: Op PatternEndo where
  assocL pat g = PatternEndo $ chainl pat g
  assocR pat g = PatternEndo $ chainr pat g
  wrap   pat g = PatternEndo $ wrap'  pat g
  split  pat g = PatternEndo $ \_ -> split' pat g

-- |
-- Convert an operator to a PatternEndo
--
toPatternEndo :: forall u a r. Operator u a r -> Pattern u a r -> Pattern u a r
toPatternEndo (Operator op) = runPatternEndo op

-- |
-- Build a pretty printer from an operator table and an indecomposable pattern
--
buildPrettyPrinter :: forall u a r. OperatorTable u a r -> Pattern u a r -> Pattern u a r
buildPrettyPrinter table p =
  let fs = map (map toPatternEndo) $ runOperatorTable table in
  foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \f -> f p' <+> p')) p $ fs

module Text.Pretty.PatternArrows where

import Prelude
import Data.Tuple (Tuple(..), uncurry)
import Data.Array
import Data.Foldable
import Data.Maybe
import Control.Arrow
import Control.Monad
import Control.Monad.Trans
import Control.Monad.State.Trans

-- |
-- A first-order pattern match
--
-- A pattern is a Kleisli arrow for the @StateT Maybe@ monad. That is, patterns can fail, and can carry user-defined state.
--
data Pattern u a b = Pattern (a -> StateT u Maybe b)

runPattern :: forall u a b. Pattern u a b -> a -> StateT u Maybe b
runPattern (Pattern f) a = f a

instance functorPattern :: Functor (Pattern u a) where
  (<$>) f (Pattern p) = Pattern $ \a -> f <$> p a

instance semigroupoidPattern :: Semigroupoid (Pattern u) where
  (<<<) (Pattern f) (Pattern g) = Pattern $ f <=< g

instance categoryPattern :: Category (Pattern u) where
  id = Pattern $ \a -> return a

instance arrowPattern :: Arrow (Pattern u) where
  arr f = Pattern $ \a -> return $ f a
  first p = Pattern $ \(Tuple b d) -> flip Tuple d <$> runPattern p b

instance arrowZeroPattern :: ArrowZero (Pattern u) where
  azero = Pattern $ \_ -> lift Nothing

instance arrowPlusPattern :: ArrowPlus (Pattern u) where
  (<+>) p q = Pattern $ \a -> StateT $ \s ->
                case runStateT (runPattern p a) s of
                  Nothing -> runStateT (runPattern q a) s
                  Just r -> Just r

-- |
-- Run a pattern with an input and initial user state
--
-- Returns Nothing if the pattern fails to match
--
pattern :: forall u a b. Pattern u a b -> u -> a -> Maybe b
pattern p u = flip evalStateT u <<< runPattern p

-- |
-- Construct a pattern from a function
--
mkPattern :: forall u a b. (a -> Maybe b) -> Pattern u a b
mkPattern f = Pattern $ \a -> lift (f a)

-- |
-- Construct a pattern from a stateful function
--
mkPattern' :: forall u a b. (a -> StateT u Maybe b) -> Pattern u a b
mkPattern' = Pattern

fix :: forall u a r. (Pattern u a r -> Pattern u a r) -> Pattern u a r
fix f = Pattern $ \a -> runPattern (f $ fix f) a

-- |
-- Construct a pattern which recursively matches on the left-hand-side
--
chainl :: forall u a r. Pattern u a (Tuple a a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> arr (uncurry f)

-- |
-- Construct a pattern which recursively matches on the right-hand side
--
chainr :: forall u a r. Pattern u a (Tuple a a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> arr (uncurry f)

-- |
-- Construct a pattern which recursively matches on one-side of a tuple
--
wrap' :: forall u a s r. Pattern u a (Tuple s a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r
wrap' g f p = fix $ \c -> g >>> (id *** (c <+> p)) >>> arr (uncurry f)

-- |
-- Construct a pattern which matches a part of a tuple
--
split' :: forall u a s t r. Pattern u a (Tuple s t) -> (s -> t -> r) -> Pattern u a r
split' s f = s >>> arr (uncurry f)

-- |
-- An operator:
--
--  [@AssocL@] A left-associative operator
--
--  [@AssocR@] A right-associative operator
--
--  [@Wrap@] A prefix-like or postfix-like operator
--
--  [@Split@] A prefix-like or postfix-like operator which does not recurse into its operand
--
class Op op where
  assocL :: forall u a r.     Pattern u a (Tuple a a) -> (r -> r -> r) -> op u a r
  assocR :: forall u a r.     Pattern u a (Tuple a a) -> (r -> r -> r) -> op u a r
  wrap   :: forall u a s r.   Pattern u a (Tuple s a) -> (s -> r -> r) -> op u a r
  split  :: forall u a s t r. Pattern u a (Tuple s t) -> (s -> t -> r) -> op u a r

data Operator u a r = Operator (forall op. (Op op) => op u a r)

-- |
-- A table of operators
--
data OperatorTable u a r = OperatorTable [[Operator u a r]]

runOperatorTable :: forall u a r. OperatorTable u a r -> [[Operator u a r]]
runOperatorTable (OperatorTable table) = table

foldl1 :: forall a. (a -> a -> a) -> [a] -> a
foldl1 f (x:xs) = foldl f x xs

-- |
-- The target data type of the "Op" language, which modifies a Pattern
--
data PatternEndo u a r = PatternEndo (Pattern u a r -> Pattern u a r)

runPatternEndo :: forall u a r. PatternEndo u a r -> Pattern u a r -> Pattern u a r
runPatternEndo (PatternEndo f) p = f p

instance opPatternEndo :: Op PatternEndo where
  assocL pat g = PatternEndo $ chainl pat g
  assocR pat g = PatternEndo $ chainr pat g
  wrap   pat g = PatternEndo $ wrap'  pat g
  split  pat g = PatternEndo $ \_ -> split' pat g

-- |
-- Convert an operator to a PatternEndo
--
toPatternEndo :: forall u a r. Operator u a r -> Pattern u a r -> Pattern u a r
toPatternEndo (Operator op) = runPatternEndo op

-- |
-- Build a pretty printer from an operator table and an indecomposable pattern
--
buildPrettyPrinter :: forall u a r. OperatorTable u a r -> Pattern u a r -> Pattern u a r
buildPrettyPrinter table p =
  let fs = map (map toPatternEndo) $ runOperatorTable table in
  foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \f -> f p' <+> p')) p $ fs


Add warning icon to all error titles

Add warning icon to all error titles

{-
Copyright 2017 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Error.Component
  ( errorCardComponent
  , module SlamData.Workspace.Card.Error.Component.Query
  , module SlamData.Workspace.Card.Error.Component.State
  ) where

import SlamData.Prelude

import Data.Argonaut as J
import Data.Path.Pathy as Path
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Quasar.Advanced.QuasarAF as QA
import SlamData.GlobalError as GE
import SlamData.Monad (Slam)
import SlamData.Render.Icon as I
import SlamData.Wiring as Wiring
import SlamData.Workspace.AccessType (AccessType(..))
import SlamData.Workspace.Card.CardType.FormInputType as FIT
import SlamData.Workspace.Card.Error as CE
import SlamData.Workspace.Card.Error (CardError(..), cardToGlobalError)
import SlamData.Workspace.Card.Error.Component.Query (Query(..))
import SlamData.Workspace.Card.Error.Component.State (State, initialState)
import Utils (prettyJson)

type DSL = H.ComponentDSL State Query Void Slam
type HTML = H.ComponentHTML Query

errorCardComponent ∷ H.Component HH.HTML Query CardError Void Slam
errorCardComponent =
  H.lifecycleComponent
    { initialState: initialState
    , render
    , eval
    -- TODO: check whether the card needs to be able to respond to input changes
    -- it may be unnecessary, as I think the error card disappears between runs -gb
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }

render ∷ State → HTML
render st =
  HH.div
    [ HP.class_ (H.ClassName "sd-error-container") ]
    [ prettyPrintCardError st st.error ]

errorTitle ∷ Array HTML → HTML
errorTitle title =
  HH.h1_
    [ I.warningSm
    , HH.span_ title
    ]

eval ∷ Query ~> DSL
eval = case _ of
  Init next → do
    { accessType } ← Wiring.expose
    H.modify (_ { accessType = accessType })
    pure next
  ToggleExpanded b next → do
    H.modify (_ { expanded = b })
    pure next

printQErrorWithDetails ∷ QA.QError → HTML
printQErrorWithDetails = case _ of
  err → HH.text (QA.printQError err)

printQErrorDetails ∷ QA.QError → HTML
printQErrorDetails = case _ of
  QA.ErrorMessage { raw } → printQErrorRaw raw
  err → HH.text (QA.printQError err)

printQErrorRaw ∷ J.JObject → HTML
printQErrorRaw raw = HH.pre_ [ HH.text (prettyJson (J.fromObject raw)) ]

prettyPrintCardError ∷ State → CardError → HTML
prettyPrintCardError state ce = case cardToGlobalError ce of
  Just ge → HH.text (GE.print ge)
  Nothing → case ce of
    QuasarError qError → printQErrorWithDetails qError
    StringlyTypedError err → HH.text err
    CacheCardError cce → cacheErrorMessage state cce
    QueryCardError qce → queryErrorMessage state qce
    MarkdownCardError mde → markdownErrorMessage state mde
    DownloadOptionsCardError dloe → downloadOptionsErrorMessage state dloe
    OpenCardError oce → openErrorMessage state oce
    TableCardError tce → tableErrorMessage state tce
    FormInputStaticCardError fise → formInputStaticErrorMessage state fise
    FormInputLabeledCardError file → formInputLabeledErrorMessage state file

collapsible ∷ String → HTML → Boolean → HTML
collapsible title content expanded =
  HH.div
    [ HP.classes [ H.ClassName "sd-collapsible-error" ] ]
    $ join
      [ pure $
          HH.button
            [ HE.onClick $ HE.input_ (ToggleExpanded (not expanded)) ]
            [ if expanded then I.chevronDownSm else I.chevronRightSm
            , HH.span_ [ HH.text title ]
            ]
      , guard expanded $>
          HH.div
            [ HP.class_ (H.ClassName "sd-collapsible-error-content") ]
            [ content ]
      ]

queryErrorMessage ∷ State → CE.QueryError → HTML
queryErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the query card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.QueryCompileError qErr →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occurred during query compilation." ]
          , renderMore qErr
          ]
    CE.QueryRetrieveResultError qErr →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occurred when retrieving the query result." ]
          , renderMore qErr
          ]
  renderMore = case _ of
    QA.ErrorMessage {title, message, raw} →
      pure $ HH.div_
        $ join
          [ foldMap (\t -> pure $ HH.p_ [ HH.text t ]) title
          , pure $ HH.p_ [ HH.text message ]
          , guard (accessType == Editable) $> collapsible "Quasar error details" (printQErrorRaw raw) expanded
          ]
    err' →
      guard (accessType == Editable) $> collapsible "Quasar error details" (printQErrorDetails err') expanded

cacheErrorMessage ∷ State → CE.CacheError → HTML
cacheErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the cache card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.CacheInvalidFilepath fp →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "There is a problem in the configuration of the cache card." ]
          , pure $ HH.p_
              [ HH.text "The provided path "
              , HH.code_ [ HH.text fp ]
              , HH.text " is not a valid location to store the cache result."
              ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.CacheQuasarError qe →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "Caching the result of a query failed." ]
          , pure $ HH.p_ [ HH.text "The Quasar analytics engine returned an error while verifying the cache result." ]
          , guard (accessType == Editable) $> collapsible "Quasar error details" (printQErrorDetails qe) expanded
          ]
    CE.CacheErrorSavingFile fp →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "Caching the result of a query failed." ]
          , pure $ HH.p_
              [ HH.text "The file "
              , HH.code_ [ HH.text (Path.printPath fp) ]
              , HH.text " could not be written to."
              ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and provide an alternative path to fix this error." ]
          ]
    CE.CacheResourceNotModified →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "Caching the result of a query failed." ]
          , pure $ HH.p_ [ HH.text "Caching can only be applied to queries that perform at least one transformation on an existing data set." ]
          -- TODO: only show this solution when there are no following cards?
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and delete it to fix this error." ]
          ]

markdownErrorMessage ∷ State → CE.MarkdownError → HTML
markdownErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Markdown card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  -- TODO: explain which field for all these cases? -gb
  renderDetails = case _ of
    CE.MarkdownParseError {markdown, error} →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "Parsing the provided Markdown failed." ]
          , pure $ HH.p_
              [ HH.text "We encountered the following parse error: "
              , HH.code_ [ HH.text error ]
              ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownSqlParseError {sql, error} →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "Parsing SQL embedded inside Markdown failed." ]
          , pure $ renderParseError error sql
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownNoTextBoxResults →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "A text box field did not return any results." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownInvalidTimeValue { time, error } →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An invalid time value was provided." ]
          , pure $ renderParseError error time
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownInvalidDateValue { date, error } →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An invalid date value was provided." ]
          , pure $ renderParseError error date
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownInvalidDateTimeValue { datetime, error } →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An invalid timestamp value was provided." ]
          , pure $ renderParseError error datetime
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownTypeError t1 t2 →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "A type mismatch occurred when populating a field in the Markdown card." ]
          , pure $ HH.p_
              [ HH.text "We encountered the following type:"
              , HH.br_
              , HH.code_ [ HH.text t1 ]
              , HH.text " where we expected:"
              , HH.br_
              , HH.code_ [ HH.text t2 ]
              ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    where
      renderParseError error value =
        HH.p_
          [ HH.text "We encountered the following error:"
          , HH.br_
          , HH.code_ [ HH.text error ]
          , HH.text " when trying to parse:"
          , HH.br_
          , HH.code_ [ HH.text value ]
          ]

downloadOptionsErrorMessage ∷ State → CE.DownloadOptionsError → HTML
downloadOptionsErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Download Options card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.DownloadOptionsFilenameRequired →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "No filename was provided in the Download Options card." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.DownloadOptionsFilenameInvalid fn →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "The filename provided in the Download Options card is invalid." ]
          , pure $ HH.p_
              [ HH.code_ [ HH.text fn ], HH.text " is not a valid filepath." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]

openErrorMessage ∷ State → CE.OpenError → HTML
openErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Open card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.OpenFileNotFound fp →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "A file that was selected in the Open card could not be found." ]
          , pure $ HH.p_
              [ HH.code_ [ HH.text fp ], HH.text " does not exist." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and make a new selection to fix this error." ]
          ]
    CE.OpenNoResourceSelected →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "No resource was selected in the Open card." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select either a file or a variable to fix this error." ]
          ]
    CE.OpenNoFileSelected →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "The resource selected in the Open card is of an invalid type" ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select a file or variable to fix this error." ]
          ]

tableErrorMessage ∷ State → CE.TableError → HTML
tableErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Preview Table card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.TableMissingResourceInputError →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "Expected a TaggedResource input." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.TableCountQuasarError qErr →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "A error occured when counting the preview data." ]
          , pure $ printQErrorWithDetails qErr
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.TableSampleQuasarError qErr →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "A error occured during sampling of the preview data." ]
          , pure $ printQErrorWithDetails qErr
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]

formInputStaticErrorMessage ∷ State → CE.FormInputStaticError → HTML
formInputStaticErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Forminput static card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.FIStaticNoAxis →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput static card." ]
          , pure $ HH.p_
              [ HH.text "No axis was selected" ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
          ]
    CE.FIStaticMissingAxis axis →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput static card." ]
          , pure $ HH.p_
              [ HH.text "The selected axis was not present in the data." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]

formInputLabeledErrorMessage ∷ State → CE.FormInputLabeledError → HTML
formInputLabeledErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Forminput labeled card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.FILabeledNoAxisError →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput labeled card." ]
          , pure $ HH.p_
              [ HH.text "No axis was selected" ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
          ]
    CE.FILabeledEmptyResourceError →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput labeled card." ]
          , pure $ HH.p_
              [ HH.text "The selected resource was empty." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
          ]
    CE.FILabeledTooManyEntries { formInputType, maximum, entryCount } →
      let
        errorText =
          "The " <> FIT.printFormInputType formInputType
          <> " form input can't take more than "
          <> show (FIT.maximumCountOfEntries formInputType)
          <> "entries, but there were: "
          <> show entryCount
          <> ". Please use 'limit' or 'group by'"
      in
        HH.div_
          $ join
            [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput labeled card." ]
            , pure $ HH.p_
                [ HH.text errorText ]
            , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
            ]
    CE.FILabeledTooManySelected { formInputType, maximum, selectedCount } →
      let
        errorText =
          "The " <> FIT.printFormInputType formInputType
          <> " form input can't have more than "
          <> show (FIT.maximumCountOfSelectedValues formInputType)
          <> " selected values, but there were: "
          <> show selectedCount
          <> ". Please, use another axis"
      in
        HH.div_
          $ join
            [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput labeled card." ]
            , pure $ HH.p_
                [ HH.text errorText ]
            , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
            ]
    -- TODO: Use the label argument for a better error message
    CE.FILabeledNonUniqueLabelError label →
      HH.div_
        $ join
          [ pure $ errorTitle [ HH.text "An error occured when setting up the Forminput labeled card." ]
          , pure $ HH.p_
              [ HH.text "Labels must be unique. Please, use other axis." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
          ]

{-
Copyright 2017 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Error.Component
  ( errorCardComponent
  , module SlamData.Workspace.Card.Error.Component.Query
  , module SlamData.Workspace.Card.Error.Component.State
  ) where

import SlamData.Prelude

import Data.Argonaut as J
import Data.Path.Pathy as Path
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Quasar.Advanced.QuasarAF as QA
import SlamData.GlobalError as GE
import SlamData.Monad (Slam)
import SlamData.Render.Icon as I
import SlamData.Wiring as Wiring
import SlamData.Workspace.AccessType (AccessType(..))
import SlamData.Workspace.Card.CardType.FormInputType as FIT
import SlamData.Workspace.Card.Error as CE
import SlamData.Workspace.Card.Error (CardError(..), cardToGlobalError)
import SlamData.Workspace.Card.Error.Component.Query (Query(..))
import SlamData.Workspace.Card.Error.Component.State (State, initialState)
import Utils (prettyJson)

type DSL = H.ComponentDSL State Query Void Slam
type HTML = H.ComponentHTML Query

errorCardComponent ∷ H.Component HH.HTML Query CardError Void Slam
errorCardComponent =
  H.lifecycleComponent
    { initialState: initialState
    , render
    , eval
    -- TODO: check whether the card needs to be able to respond to input changes
    -- it may be unnecessary, as I think the error card disappears between runs -gb
    , receiver: const Nothing
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }

render ∷ State → HTML
render st =
  HH.div
    [ HP.class_ (H.ClassName "sd-error-container") ]
    [ prettyPrintCardError st st.error ]

eval ∷ Query ~> DSL
eval = case _ of
  Init next → do
    { accessType } ← Wiring.expose
    H.modify (_ { accessType = accessType })
    pure next
  ToggleExpanded b next → do
    H.modify (_ { expanded = b })
    pure next

printQErrorWithDetails ∷ QA.QError → HTML
printQErrorWithDetails = case _ of
  err → HH.text (QA.printQError err)

printQErrorDetails ∷ QA.QError → HTML
printQErrorDetails = case _ of
  QA.ErrorMessage { raw } → printQErrorRaw raw
  err → HH.text (QA.printQError err)

printQErrorRaw ∷ J.JObject → HTML
printQErrorRaw raw = HH.pre_ [ HH.text (prettyJson (J.fromObject raw)) ]

prettyPrintCardError ∷ State → CardError → HTML
prettyPrintCardError state ce = case cardToGlobalError ce of
  Just ge → HH.text (GE.print ge)
  Nothing → case ce of
    QuasarError qError → printQErrorWithDetails qError
    StringlyTypedError err → HH.text err
    CacheCardError cce → cacheErrorMessage state cce
    QueryCardError qce → queryErrorMessage state qce
    MarkdownCardError mde → markdownErrorMessage state mde
    DownloadOptionsCardError dloe → downloadOptionsErrorMessage state dloe
    OpenCardError oce → openErrorMessage state oce
    TableCardError tce → tableErrorMessage state tce
    FormInputStaticCardError fise → formInputStaticErrorMessage state fise
    FormInputLabeledCardError file → formInputLabeledErrorMessage state file

collapsible ∷ String → HTML → Boolean → HTML
collapsible title content expanded =
  HH.div
    [ HP.classes [ H.ClassName "sd-collapsible-error" ] ]
    $ join
      [ pure $
          HH.button
            [ HE.onClick $ HE.input_ (ToggleExpanded (not expanded)) ]
            [ if expanded then I.chevronDownSm else I.chevronRightSm
            , HH.span_ [ HH.text title ]
            ]
      , guard expanded $>
          HH.div
            [ HP.class_ (H.ClassName "sd-collapsible-error-content") ]
            [ content ]
      ]

queryErrorMessage ∷ State → CE.QueryError → HTML
queryErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the query card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.QueryCompileError qErr →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "An error occurred during query compilation." ]
          , renderMore qErr
          ]
    CE.QueryRetrieveResultError qErr →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "An error occurred when retrieving the query result." ]
          , renderMore qErr
          ]
  renderMore = case _ of
    QA.ErrorMessage {title, message, raw} →
      pure $ HH.div_
        $ join
          [ foldMap (\t -> pure $ HH.p_ [ HH.text t ]) title
          , pure $ HH.p_ [ HH.text message ]
          , guard (accessType == Editable) $> collapsible "Quasar error details" (printQErrorRaw raw) expanded
          ]
    err' →
      guard (accessType == Editable) $> collapsible "Quasar error details" (printQErrorDetails err') expanded

cacheErrorMessage ∷ State → CE.CacheError → HTML
cacheErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the cache card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.CacheInvalidFilepath fp →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "There is a problem in the configuration of the cache card." ]
          , pure $ HH.p_
              [ HH.text "The provided path "
              , HH.code_ [ HH.text fp ]
              , HH.text " is not a valid location to store the cache result."
              ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.CacheQuasarError qe →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ I.warningSm, HH.text "Caching the result of a query failed." ]
          , pure $ HH.p_ [ HH.text "The Quasar analytics engine returned an error while verifying the cache result." ]
          , guard (accessType == Editable) $> collapsible "Quasar error details" (printQErrorDetails qe) expanded
          ]
    CE.CacheErrorSavingFile fp →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "Caching the result of a query failed." ]
          , pure $ HH.p_
              [ HH.text "The file "
              , HH.code_ [ HH.text (Path.printPath fp) ]
              , HH.text " could not be written to."
              ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and provide an alternative path to fix this error." ]
          ]
    CE.CacheResourceNotModified →
      HH.div_
        $ join
          [ pure $ HH.h1_
              [ I.warningSm
              , HH.span_ [ HH.text "Caching the result of a query failed." ]
              ]
          , pure $ HH.p_ [ HH.text "Caching can only be applied to queries that perform at least one transformation on an existing data set." ]
          -- TODO: only show this solution when there are no following cards?
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and delete it to fix this error." ]
          ]

markdownErrorMessage ∷ State → CE.MarkdownError → HTML
markdownErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Markdown card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  -- TODO: explain which field for all these cases? -gb
  renderDetails = case _ of
    CE.MarkdownParseError {markdown, error} →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "Parsing the provided Markdown failed." ]
          , pure $ HH.p_
              [ HH.text "We encountered the following parse error: "
              , HH.code_ [ HH.text error ]
              ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownSqlParseError {sql, error} →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "Parsing SQL embedded inside Markdown failed." ]
          , pure $ renderParseError error sql
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownNoTextBoxResults →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "A text box field did not return any results." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownInvalidTimeValue { time, error } →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "An invalid time value was provided." ]
          , pure $ renderParseError error time
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownInvalidDateValue { date, error } →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "An invalid date value was provided." ]
          , pure $ renderParseError error date
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownInvalidDateTimeValue { datetime, error } →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "An invalid timestamp value was provided." ]
          , pure $ renderParseError error datetime
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.MarkdownTypeError t1 t2 →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "A type mismatch occurred when populating a field in the Markdown card." ]
          , pure $ HH.p_
              [ HH.text "We encountered the following type:"
              , HH.br_
              , HH.code_ [ HH.text t1 ]
              , HH.text " where we expected:"
              , HH.br_
              , HH.code_ [ HH.text t2 ]
              ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    where
      renderParseError error value =
        HH.p_
          [ HH.text "We encountered the following error:"
          , HH.br_
          , HH.code_ [ HH.text error ]
          , HH.text " when trying to parse:"
          , HH.br_
          , HH.code_ [ HH.text value ]
          ]

downloadOptionsErrorMessage ∷ State → CE.DownloadOptionsError → HTML
downloadOptionsErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Download Options card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.DownloadOptionsFilenameRequired →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "No filename was provided in the Download Options card." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.DownloadOptionsFilenameInvalid fn →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "The filename provided in the Download Options card is invalid." ]
          , pure $ HH.p_
              [ HH.code_ [ HH.text fn ], HH.text " is not a valid filepath." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]

openErrorMessage ∷ State → CE.OpenError → HTML
openErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Open card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.OpenFileNotFound fp →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "A file that was selected in the Open card could not be found." ]
          , pure $ HH.p_
              [ HH.code_ [ HH.text fp ], HH.text " does not exist." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and make a new selection to fix this error." ]
          ]
    CE.OpenNoResourceSelected →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "No resource was selected in the Open card." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select either a file or a variable to fix this error." ]
          ]
    CE.OpenNoFileSelected →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "The resource selected in the Open card is of an invalid type" ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select a file or variable to fix this error." ]
          ]

tableErrorMessage ∷ State → CE.TableError → HTML
tableErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Preview Table card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.TableMissingResourceInputError →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "Expected a TaggedResource input." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.TableCountQuasarError qErr →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "A error occured when counting the preview data." ]
          , pure $ printQErrorWithDetails qErr
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]
    CE.TableSampleQuasarError qErr →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "A error occured during sampling of the preview data." ]
          , pure $ printQErrorWithDetails qErr
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]

formInputStaticErrorMessage ∷ State → CE.FormInputStaticError → HTML
formInputStaticErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Forminput static card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.FIStaticNoAxis →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "An error occured when setting up the Forminput static card." ]
          , pure $ HH.p_
              [ HH.text "No axis was selected" ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
          ]
    CE.FIStaticMissingAxis axis →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "An error occured when setting up the Forminput static card." ]
          , pure $ HH.p_
              [ HH.text "The selected axis was not present in the data." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card to fix this error." ]
          ]

formInputLabeledErrorMessage ∷ State → CE.FormInputLabeledError → HTML
formInputLabeledErrorMessage { accessType, expanded } err =
  case accessType of
    Editable → renderDetails err
    ReadOnly →
      HH.div_
        [ HH.p_ [ HH.text "A problem occurred in the Forminput labeled card, please notify the author of this workspace." ]
        , collapsible "Error details" (renderDetails err) expanded
        ]
  where
  renderDetails = case _ of
    CE.FILabeledNoAxisError →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "An error occured when setting up the Forminput labeled card." ]
          , pure $ HH.p_
              [ HH.text "No axis was selected" ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
          ]
    CE.FILabeledEmptyResourceError →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "An error occured when setting up the Forminput labeled card." ]
          , pure $ HH.p_
              [ HH.text "The selected resource was empty." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
          ]
    CE.FILabeledTooManyEntries { formInputType, maximum, entryCount } →
      let
        errorText =
          "The " <> FIT.printFormInputType formInputType
          <> " form input can't take more than "
          <> show (FIT.maximumCountOfEntries formInputType)
          <> "entries, but there were: "
          <> show entryCount
          <> ". Please use 'limit' or 'group by'"
      in
        HH.div_
          $ join
            [ pure $ HH.h1_ [ HH.text "An error occured when setting up the Forminput labeled card." ]
            , pure $ HH.p_
                [ HH.text errorText ]
            , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
            ]
    CE.FILabeledTooManySelected { formInputType, maximum, selectedCount } →
      let
        errorText =
          "The " <> FIT.printFormInputType formInputType
          <> " form input can't have more than "
          <> show (FIT.maximumCountOfSelectedValues formInputType)
          <> " selected values, but there were: "
          <> show selectedCount
          <> ". Please, use another axis"
      in
        HH.div_
          $ join
            [ pure $ HH.h1_ [ HH.text "An error occured when setting up the Forminput labeled card." ]
            , pure $ HH.p_
                [ HH.text errorText ]
            , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
            ]
    -- TODO: Use the label argument for a better error message
    CE.FILabeledNonUniqueLabelError label →
      HH.div_
        $ join
          [ pure $ HH.h1_ [ HH.text "An error occured when setting up the Forminput labeled card." ]
          , pure $ HH.p_
              [ HH.text "Labels must be unique. Please, use other axis." ]
          , guard (accessType == Editable) $> HH.p_ [ HH.text "Go back to the previous card and select an axis to fix this error." ]
          ]