Added few weapon types

Added few weapon types

module GameData where

import Data.Tuple
import Data.Array (map)
import Data.String
import Data.Monoid
import Data.Foldable
import qualified Data.Map as M
import Utils
import Math

type Point = { x :: Number, y :: Number }

(.+.) :: Point -> Point -> Point
(.+.) {x = x1, y = y1} {x = x2, y=y2} = {x: x1+x2, y: y1+y2}
infixl 9 .+.

(.-.) :: Point -> Point -> Point
(.-.) {x = x1, y = y1} {x = x2, y=y2} = {x: x1-x2, y: y1-y2}
infixl 9 .-.

(.==.) :: Point -> Point -> Boolean
(.==.) {x = x1, y = y1} {x = x2, y = y2} = x1 == x2 && y1 == y2

showPoint :: Point -> String
showPoint p = "(" ++ show p.x ++ ", " ++ show p.y ++ ")"

manhattanDistance :: Point -> Point -> Number
manhattanDistance {x = x1, y = y1} {x = x2, y=y2} = abs (x1 - x2) + abs (y1 - y2)

distanceSq :: Point -> Point -> Number
distanceSq {x = x1, y = y1} {x = x2, y=y2} = (x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2)

zerop :: Point
zerop = {x: 0, y: 0}

unitp :: Point -> Point
unitp p = {x: sign p.x, y: sign p.y}

type Stats =
    { maxHp :: Number
    , hp    :: Number
    , str   :: Number
    , dex   :: Number
    , int   :: Number
    }

defaultStats :: Stats
defaultStats = { maxHp: 10, hp: 10, str: 10, dex: 10, int: 10 }

guardStats :: Stats
guardStats = { maxHp: 20, hp: 20, str: 8, dex: 8, int: 10 }

archerStats :: Stats
archerStats = { maxHp: 10, hp: 10, str: 6, dex: 10, int: 10 }

statsToString :: Stats -> String
statsToString { maxHp = mh, hp  = h, str = s, dex = d, int = i } = "Hp: " ++ show h ++ "/" ++ show mh ++ ". Str: " ++ show s ++ ". Dex: " ++ show d ++ ". Int: " ++ show i ++"."
statsToString _ = ""

statModf :: Number -> Number
statModf x = -5 + floor (x / 2)

data SkillType = WeaponSkill | Sneak | Athletics | Lockpick

type Skill = { level :: Number, prog :: Number }

type Skills = M.Map SkillType Skill

instance showSkillType :: Show SkillType where
    show WeaponSkill = "weapon"
    show Sneak       = "sneaking"
    show Athletics   = "athletics"
    show Lockpick    = "lockpicking"

instance ordSkillType :: Ord SkillType where
    compare a b = compare (show a) (show b)

instance eqSkillType :: Eq SkillType where
    (==) a b = show a == show b
    (/=) a b = not (a == b)

defaultSkills :: Skills
defaultSkills = M.fromList [Tuple WeaponSkill {level: 0, prog: 0}
                           ,Tuple Sneak { level: 0, prog: 0}
                           ,Tuple Athletics { level: 0, prog: 0}
                           ,Tuple Lockpick { level: 0, prog: 0}
                           ]

startingClass :: [String]
startingClass = ["the knight", "the monk", "the ninja", "the peasant", "the rogue", "the scholar", "the skillmaster", "the soldier", "the developer"]

startingStats :: [Stats]
startingStats = [ { maxHp: 10, hp: 10, str: 14, dex:  9, int: 10 } -- Knight
                , { maxHp: 10, hp: 10, str: 10, dex: 11, int: 12 } -- Monk
                , { maxHp: 10, hp: 10, str:  9, dex: 14, int: 10 } -- Ninja
                , { maxHp:  9, hp:  9, str:  9, dex:  9, int:  9 } -- Peasant
                , { maxHp: 10, hp: 10, str: 10, dex: 11, int: 11 } -- Rogue
                , { maxHp: 10, hp: 10, str: 09, dex: 11, int: 13 } -- Scholar
                , { maxHp: 10, hp: 10, str: 10, dex: 10, int: 11 } -- Skillmaster
                , { maxHp: 10, hp: 10, str: 12, dex: 11, int: 10 } -- Soldier
                , { maxHp: 99, hp: 99, str: 99, dex: 99, int: 99 } -- Developer
                ]

startingSkillpoints :: [Number]
startingSkillpoints = [ 2 -- Knight
                      , 2 -- Monk
                      , 2 -- Ninja
                      , 1 -- Peasant
                      , 5 -- Rogue
                      , 5 -- Scholar
                      , 8 -- Skillmaster
                      , 2 -- Soldier
                      , 99 -- Developer
                      ]

skillsInfo :: Skills -> String
skillsInfo skills = skillsToString $ M.toList skills
    where
        skillToString :: Tuple SkillType Skill -> String
        skillToString (Tuple sType { level = l, prog = p }) = fill (show sType ++ " skill. ") 21 ++ fill (" Level: " ++ show l ++ ".") 11 ++ " Progress (0 - " ++ show (100 + l * 50) ++ "): " ++ show p ++"\n"

        skillsToString :: [Tuple SkillType Skill] -> String
        skillsToString [] = ""
        skillsToString (x:xs) = skillToString x ++ ("\n") ++ skillsToString xs

data CreatureType = Player | Guard | Archer | Peasant

instance showCT :: Show CreatureType where
    show Player  = "player"
    show Guard   = "guard"
    show Archer  = "archer"
    show Peasant = "peasant"

instance eqCT :: Eq CreatureType where
    (==) a b = show a == show b
    (/=) a b = show a /= show b

data AIState = Sleep
             | Idle Point   -- idling position
             | Patrol Point -- where to go

data Alertness = NoAlert  -- Does not see player
               | MightSee -- There is LOS and a chance to turn into Suspicious
               | Suspicious Number -- Number = progress towards alert
               | Alert Number -- Number = number of turns to stay alert

data AI = AI Alertness AIState | NoAI

type Creature =
    { pos   :: Point -- Position
    , dir   :: Point -- Facing direction
    , ctype :: CreatureType
    , stats :: Stats
    , time  :: Number
    , vel   :: Point -- Velocity
    , ai    :: AI
    }

--------- ARMOR STAT ---------

type ArmorStatRecord = { defence :: Number, weight :: Number }

data ArmorStat = ArmorStat ArmorStatRecord

extractStatArmor :: ArmorStat -> ArmorStatRecord
extractStatArmor (ArmorStat s) = s

instance semigroupArmorStat :: Semigroup ArmorStat where
    (<>) (ArmorStat a) (ArmorStat b) =
        ArmorStat { defence: a.defence + b.defence
                  , weight: a.weight + b.weight
                  }

instance monoidArmorStat :: Monoid ArmorStat where
    mempty = ArmorStat { defence: 0, weight: 0 }

--------- WEAPON STAT ---------

type WeaponStatRecord = { damage :: Number, weight :: Number, attackSpeed :: Number, attackBonus :: Number }

data WeaponStat = WeaponStat WeaponStatRecord

extractStatWeapon :: WeaponStat -> WeaponStatRecord
extractStatWeapon (WeaponStat s) = s

instance semigroupWeaponStat :: Semigroup WeaponStat where
    (<>) (WeaponStat a) (WeaponStat b) =
        WeaponStat { damage: a.damage + b.damage
                   , weight: a.weight + b.weight
                   , attackSpeed: a.attackSpeed + b.attackSpeed
                   , attackBonus: a.attackBonus + b.attackBonus
                   }

instance monoidWeaponStat :: Monoid WeaponStat where
    mempty = WeaponStat { damage: 0, weight: 0, attackSpeed: 0, attackBonus: 0 }

--------- MATERIALS ---------

data Material = Wood | Copper | Iron | Steel | Titanium | Adamantine | Leather

materialStatWeapon :: Material -> WeaponStat
materialStatWeapon Wood       = WeaponStat { damage: -3, weight: -1, attackSpeed:  -50, attackBonus: 4 }
materialStatWeapon Copper     = WeaponStat { damage: -1, weight:  1, attackSpeed:  100, attackBonus: 0 }
materialStatWeapon Iron       = WeaponStat { damage:  0, weight:  2, attackSpeed:  100, attackBonus: 0 }
materialStatWeapon Steel      = WeaponStat { damage:  1, weight:  3, attackSpeed:  100, attackBonus: 0 }
materialStatWeapon Titanium   = WeaponStat { damage:  2, weight:  4, attackSpeed:    0, attackBonus: 0 }
materialStatWeapon Adamantine = WeaponStat { damage:  3, weight:  4, attackSpeed: -100, attackBonus: 1 }
materialStatWeapon _ = mempty

materialStatArmor :: Material -> ArmorStat
materialStatArmor Leather    = ArmorStat { defence: 1, weight: 10 }
materialStatArmor Copper     = ArmorStat { defence: 2, weight: 30 }
materialStatArmor Iron       = ArmorStat { defence: 3, weight: 35 }
materialStatArmor Steel      = ArmorStat { defence: 4, weight: 45 }
materialStatArmor Titanium   = ArmorStat { defence: 5, weight: 60 }
materialStatArmor Adamantine = ArmorStat { defence: 7, weight: 60 }
materialStatArmor _ = mempty

instance showMaterial :: Show Material where
    show Wood       = "wooden"
    show Leather    = "leather"
    show Copper     = "copper"
    show Iron       = "iron"
    show Steel      = "steel"
    show Titanium   = "titanium"
    show Adamantine = "adamantine"

--------- WEAPON AND ARMOR PREFIXES ---------

data WeaponPrefix = Broken | Rusty | Dull | Sharp | Lethal | Masterwork | Light | Balanced | Heavy | Godly

data ArmorPrefix = BrokenA | RustyA | MasterworkA | LightA | HeavyA | GodlyA

prefixStatWeapon :: WeaponPrefix -> WeaponStat
prefixStatWeapon Broken     = WeaponStat { damage: -3, weight: -1, attackSpeed:   50, attackBonus: -4 }
prefixStatWeapon Rusty      = WeaponStat { damage: -2, weight:  1, attackSpeed:    0, attackBonus: -2 }
prefixStatWeapon Dull       = WeaponStat { damage: -1, weight:  0, attackSpeed:    0, attackBonus: -1 }
prefixStatWeapon Sharp      = WeaponStat { damage:  1, weight:  0, attackSpeed:    0, attackBonus:  1 }
prefixStatWeapon Lethal     = WeaponStat { damage:  2, weight:  0, attackSpeed:    0, attackBonus:  2 }
prefixStatWeapon Masterwork = WeaponStat { damage:  3, weight:  0, attackSpeed: -100, attackBonus:  3 }
prefixStatWeapon Godly      = WeaponStat { damage:  4, weight:  0, attackSpeed: -200, attackBonus:  4 }
prefixStatWeapon Light      = WeaponStat { damage:  0, weight: -2, attackSpeed: -100, attackBonus:  1 }
prefixStatWeapon Balanced   = WeaponStat { damage:  1, weight:  0, attackSpeed: -100, attackBonus:  3 }
prefixStatWeapon Heavy      = WeaponStat { damage:  2, weight:  3, attackSpeed:  100, attackBonus:  0 }
prefixStatWeapon _          = mempty

prefixStatArmor :: ArmorPrefix -> ArmorStat
prefixStatArmor BrokenA     = ArmorStat { defence: -1, weight:  -5 }
prefixStatArmor RustyA      = ArmorStat { defence:  1, weight:   5 }
prefixStatArmor MasterworkA = ArmorStat { defence:  5, weight:   5 }
prefixStatArmor GodlyA      = ArmorStat { defence:  7, weight:  10 }
prefixStatArmor LightA      = ArmorStat { defence:  0, weight: -10 }
prefixStatArmor HeavyA      = ArmorStat { defence:  2, weight:  10 }
prefixStatArmor _          = mempty

showPrefixWeapon :: [WeaponPrefix] -> String
showPrefixWeapon = joinWith " " <<< map show

instance showWeaponPrefix :: Show WeaponPrefix where
    show Rusty      = "rusty"
    show Broken     = "broken"
    show Dull       = "dull"
    show Masterwork = "masterwork"
    show Sharp      = "sharp"
    show Lethal     = "lethal"
    show Light      = "light"
    show Balanced   = "balanced"
    show Heavy      = "heavy"
    show Godly      = "godly"

showPrefixArmor :: [ArmorPrefix] -> String
showPrefixArmor = joinWith " " <<< map show

instance showArmorPrefix :: Show ArmorPrefix where
    show RustyA      = "rusty"
    show BrokenA     = "broken"
    show MasterworkA = "masterwork"
    show LightA      = "light"
    show HeavyA      = "heavy"
    show GodlyA      = "godly"

--------- WEAPON TYPES ---------

data WeaponType = Sword | Axe | Dagger | Spear | Mace | BattleAxe

instance showWeaponType :: Show WeaponType where
    show Sword     = "sword"
    show Axe       = "axe"
    show Dagger    = "dagger"
    show Spear     = "spear"'
    show Mace      = "mace"
    show BattleAxe = "battleaxe"

weaponTypeStat :: WeaponType -> WeaponStat
weaponTypeStat Sword     = WeaponStat { damage: 3, weight:  6, attackSpeed:  800, attackBonus: 1 }
weaponTypeStat Axe       = WeaponStat { damage: 5, weight:  8, attackSpeed: 1200, attackBonus: 0 }
weaponTypeStat Dagger    = WeaponStat { damage: 2, weight:  4, attackSpeed:  600, attackBonus: 2 }
weaponTypeStat Spear     = WeaponStat { damage: 2, weight:  4, attackSpeed:  600, attackBonus: 2 }
weaponTypeStat Mace      = WeaponStat { damage: 2, weight:  4, attackSpeed:  600, attackBonus: 2 }
weaponTypeStat BattleAxe = WeaponStat { damage: 9, weight: 10, attackSpeed: 2000, attackBonus: 2 }

--------- ITEM TYPES ---------

data ItemType = Loot   { value :: Number }
              | Weapon { weaponType :: WeaponType, material :: Material, prefix :: [WeaponPrefix] }
              | Armor  { material :: Material, prefix :: [ArmorPrefix]}
              | Shield { material :: Material, prefix :: [ArmorPrefix] }
              | Ring

instance showItemType :: Show ItemType where
    show (Loot   { value = val })                          = "an item worth of " ++ show val ++ " gold coins"
    show (Weapon { weaponType = t, material = mat, prefix  = [] })         = show t
    show (Weapon { weaponType = t, material = mat, prefix  = prefixList }) = showPrefixWeapon prefixList ++ " " ++ show mat ++ " " ++ show t
    show (Armor  { material = mat, prefix = [] })          = show mat ++ " armor"
    show (Armor  { material = mat, prefix = prefixList })  = showPrefixArmor prefixList ++ " " ++ show mat ++ " armor"
    show (Shield  { material = mat, prefix = [] })         = show mat ++ " shield"
    show (Shield  { material = mat, prefix = prefixList }) = showPrefixArmor prefixList ++ " " ++ show mat ++ " shield"
    show Ring                                              = "One ring to fold them and in Haskell bind them."
    show _                                                 = "unknown item"

--------- ITEM ---------

type Item = { itemType :: ItemType, pos :: Point, vel :: Point }

carryingWeight :: [Item] -> Number
carryingWeight [] = 0
carryingWeight (x:xs) =
  case x.itemType of
    Weapon w -> (weaponStat x).weight + (carryingWeight xs)
    Armor  w -> (armorStat  x).weight + (carryingWeight xs)
    Shield w -> (armorStat  x).weight + (carryingWeight xs)
    _        -> carryingWeight xs

weaponStat :: Item -> WeaponStatRecord
weaponStat { itemType = Weapon w } = extractStatWeapon (materialStatWeapon w.material <> weaponTypeStat w.weaponType <> (monoidSum <<< map prefixStatWeapon $ w.prefix))
weaponStat _ = extractStatWeapon mempty

armorStat :: Item -> ArmorStatRecord
armorStat { itemType = Armor  w } = extractStatArmor (materialStatArmor w.material <> (monoidSum <<< map prefixStatArmor $ w.prefix))
armorStat { itemType = Shield w } = extractStatArmor (materialStatArmor w.material <> (monoidSum <<< map prefixStatArmor $ w.prefix))
armorStat _ = extractStatArmor mempty

showItem :: Item -> String
showItem i@{ itemType = Weapon _ } = let s = weaponStat i in show i.itemType ++ ", Dmg: "     ++ show (s.damage)  ++ ", Weight: " ++ show (s.weight)
showItem i@{ itemType = Armor  _ } = let s = armorStat  i in show i.itemType ++ ", Defence: " ++ show (s.defence) ++ ", Weight: " ++ show (s.weight)
showItem i@{ itemType = Shield _ } = let s = armorStat  i in show i.itemType ++ ", Defence: " ++ show (s.defence) ++ ", Weight: " ++ show (s.weight)
showItem i = show i.itemType

module GameData where

import Data.Tuple
import Data.Array (map)
import Data.String
import Data.Monoid
import Data.Foldable
import qualified Data.Map as M
import Utils
import Math

type Point = { x :: Number, y :: Number }

(.+.) :: Point -> Point -> Point
(.+.) {x = x1, y = y1} {x = x2, y=y2} = {x: x1+x2, y: y1+y2}
infixl 9 .+.

(.-.) :: Point -> Point -> Point
(.-.) {x = x1, y = y1} {x = x2, y=y2} = {x: x1-x2, y: y1-y2}
infixl 9 .-.

(.==.) :: Point -> Point -> Boolean
(.==.) {x = x1, y = y1} {x = x2, y = y2} = x1 == x2 && y1 == y2

showPoint :: Point -> String
showPoint p = "(" ++ show p.x ++ ", " ++ show p.y ++ ")"

manhattanDistance :: Point -> Point -> Number
manhattanDistance {x = x1, y = y1} {x = x2, y=y2} = abs (x1 - x2) + abs (y1 - y2)

distanceSq :: Point -> Point -> Number
distanceSq {x = x1, y = y1} {x = x2, y=y2} = (x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2)

zerop :: Point
zerop = {x: 0, y: 0}

unitp :: Point -> Point
unitp p = {x: sign p.x, y: sign p.y}

type Stats =
    { maxHp :: Number
    , hp    :: Number
    , str   :: Number
    , dex   :: Number
    , int   :: Number
    }

defaultStats :: Stats
defaultStats = { maxHp: 10, hp: 10, str: 10, dex: 10, int: 10 }

guardStats :: Stats
guardStats = { maxHp: 20, hp: 20, str: 8, dex: 8, int: 10 }

archerStats :: Stats
archerStats = { maxHp: 10, hp: 10, str: 6, dex: 10, int: 10 }

statsToString :: Stats -> String
statsToString { maxHp = mh, hp  = h, str = s, dex = d, int = i } = "Hp: " ++ show h ++ "/" ++ show mh ++ ". Str: " ++ show s ++ ". Dex: " ++ show d ++ ". Int: " ++ show i ++"."
statsToString _ = ""

statModf :: Number -> Number
statModf x = -5 + floor (x / 2)

data SkillType = WeaponSkill | Sneak | Athletics | Lockpick

type Skill = { level :: Number, prog :: Number }

type Skills = M.Map SkillType Skill

instance showSkillType :: Show SkillType where
    show WeaponSkill = "weapon"
    show Sneak       = "sneaking"
    show Athletics   = "athletics"
    show Lockpick    = "lockpicking"

instance ordSkillType :: Ord SkillType where
    compare a b = compare (show a) (show b)

instance eqSkillType :: Eq SkillType where
    (==) a b = show a == show b
    (/=) a b = not (a == b)

defaultSkills :: Skills
defaultSkills = M.fromList [Tuple WeaponSkill {level: 0, prog: 0}
                           ,Tuple Sneak { level: 0, prog: 0}
                           ,Tuple Athletics { level: 0, prog: 0}
                           ,Tuple Lockpick { level: 0, prog: 0}
                           ]

startingClass :: [String]
startingClass = ["the knight", "the monk", "the ninja", "the peasant", "the rogue", "the scholar", "the skillmaster", "the soldier", "the developer"]

startingStats :: [Stats]
startingStats = [ { maxHp: 10, hp: 10, str: 14, dex:  9, int: 10 } -- Knight
                , { maxHp: 10, hp: 10, str: 10, dex: 11, int: 12 } -- Monk
                , { maxHp: 10, hp: 10, str:  9, dex: 14, int: 10 } -- Ninja
                , { maxHp:  9, hp:  9, str:  9, dex:  9, int:  9 } -- Peasant
                , { maxHp: 10, hp: 10, str: 10, dex: 11, int: 11 } -- Rogue
                , { maxHp: 10, hp: 10, str: 09, dex: 11, int: 13 } -- Scholar
                , { maxHp: 10, hp: 10, str: 10, dex: 10, int: 11 } -- Skillmaster
                , { maxHp: 10, hp: 10, str: 12, dex: 11, int: 10 } -- Soldier
                , { maxHp: 99, hp: 99, str: 99, dex: 99, int: 99 } -- Developer
                ]

startingSkillpoints :: [Number]
startingSkillpoints = [ 2 -- Knight
                      , 2 -- Monk
                      , 2 -- Ninja
                      , 1 -- Peasant
                      , 5 -- Rogue
                      , 5 -- Scholar
                      , 8 -- Skillmaster
                      , 2 -- Soldier
                      , 99 -- Developer
                      ]

skillsInfo :: Skills -> String
skillsInfo skills = skillsToString $ M.toList skills
    where
        skillToString :: Tuple SkillType Skill -> String
        skillToString (Tuple sType { level = l, prog = p }) = fill (show sType ++ " skill. ") 21 ++ fill (" Level: " ++ show l ++ ".") 11 ++ " Progress (0 - " ++ show (100 + l * 50) ++ "): " ++ show p ++"\n"

        skillsToString :: [Tuple SkillType Skill] -> String
        skillsToString [] = ""
        skillsToString (x:xs) = skillToString x ++ ("\n") ++ skillsToString xs

data CreatureType = Player | Guard | Archer | Peasant

instance showCT :: Show CreatureType where
    show Player  = "player"
    show Guard   = "guard"
    show Archer  = "archer"
    show Peasant = "peasant"

instance eqCT :: Eq CreatureType where
    (==) a b = show a == show b
    (/=) a b = show a /= show b

data AIState = Sleep
             | Idle Point   -- idling position
             | Patrol Point -- where to go

data Alertness = NoAlert  -- Does not see player
               | MightSee -- There is LOS and a chance to turn into Suspicious
               | Suspicious Number -- Number = progress towards alert
               | Alert Number -- Number = number of turns to stay alert

data AI = AI Alertness AIState | NoAI

type Creature =
    { pos   :: Point -- Position
    , dir   :: Point -- Facing direction
    , ctype :: CreatureType
    , stats :: Stats
    , time  :: Number
    , vel   :: Point -- Velocity
    , ai    :: AI
    }

--------- ARMOR STAT ---------

type ArmorStatRecord = { defence :: Number, weight :: Number }

data ArmorStat = ArmorStat ArmorStatRecord

extractStatArmor :: ArmorStat -> ArmorStatRecord
extractStatArmor (ArmorStat s) = s

instance semigroupArmorStat :: Semigroup ArmorStat where
    (<>) (ArmorStat a) (ArmorStat b) =
        ArmorStat { defence: a.defence + b.defence
                  , weight: a.weight + b.weight
                  }

instance monoidArmorStat :: Monoid ArmorStat where
    mempty = ArmorStat { defence: 0, weight: 0 }

--------- WEAPON STAT ---------

type WeaponStatRecord = { damage :: Number, weight :: Number, attackSpeed :: Number, attackBonus :: Number }

data WeaponStat = WeaponStat WeaponStatRecord

extractStatWeapon :: WeaponStat -> WeaponStatRecord
extractStatWeapon (WeaponStat s) = s

instance semigroupWeaponStat :: Semigroup WeaponStat where
    (<>) (WeaponStat a) (WeaponStat b) =
        WeaponStat { damage: a.damage + b.damage
                   , weight: a.weight + b.weight
                   , attackSpeed: a.attackSpeed + b.attackSpeed
                   , attackBonus: a.attackBonus + b.attackBonus
                   }

instance monoidWeaponStat :: Monoid WeaponStat where
    mempty = WeaponStat { damage: 0, weight: 0, attackSpeed: 0, attackBonus: 0 }

--------- MATERIALS ---------

data Material = Wood | Copper | Iron | Steel | Titanium | Adamantine | Leather

materialStatWeapon :: Material -> WeaponStat
materialStatWeapon Wood       = WeaponStat { damage: -3, weight: -1, attackSpeed:  -50, attackBonus: 4 }
materialStatWeapon Copper     = WeaponStat { damage: -1, weight:  1, attackSpeed:  100, attackBonus: 0 }
materialStatWeapon Iron       = WeaponStat { damage:  0, weight:  2, attackSpeed:  100, attackBonus: 0 }
materialStatWeapon Steel      = WeaponStat { damage:  1, weight:  3, attackSpeed:  100, attackBonus: 0 }
materialStatWeapon Titanium   = WeaponStat { damage:  2, weight:  4, attackSpeed:    0, attackBonus: 0 }
materialStatWeapon Adamantine = WeaponStat { damage:  3, weight:  4, attackSpeed: -100, attackBonus: 1 }
materialStatWeapon _ = mempty

materialStatArmor :: Material -> ArmorStat
materialStatArmor Leather    = ArmorStat { defence: 1, weight: 10 }
materialStatArmor Copper     = ArmorStat { defence: 2, weight: 30 }
materialStatArmor Iron       = ArmorStat { defence: 3, weight: 35 }
materialStatArmor Steel      = ArmorStat { defence: 4, weight: 45 }
materialStatArmor Titanium   = ArmorStat { defence: 5, weight: 60 }
materialStatArmor Adamantine = ArmorStat { defence: 7, weight: 60 }
materialStatArmor _ = mempty

instance showMaterial :: Show Material where
    show Wood       = "wooden"
    show Leather    = "leather"
    show Copper     = "copper"
    show Iron       = "iron"
    show Steel      = "steel"
    show Titanium   = "titanium"
    show Adamantine = "adamantine"

--------- WEAPON AND ARMOR PREFIXES ---------

data WeaponPrefix = Broken | Rusty | Dull | Sharp | Lethal | Masterwork | Light | Balanced | Heavy | Godly

data ArmorPrefix = BrokenA | RustyA | MasterworkA | LightA | HeavyA | GodlyA

prefixStatWeapon :: WeaponPrefix -> WeaponStat
prefixStatWeapon Broken     = WeaponStat { damage: -3, weight: -1, attackSpeed:   50, attackBonus: -4 }
prefixStatWeapon Rusty      = WeaponStat { damage: -2, weight:  1, attackSpeed:    0, attackBonus: -2 }
prefixStatWeapon Dull       = WeaponStat { damage: -1, weight:  0, attackSpeed:    0, attackBonus: -1 }
prefixStatWeapon Sharp      = WeaponStat { damage:  1, weight:  0, attackSpeed:    0, attackBonus:  1 }
prefixStatWeapon Lethal     = WeaponStat { damage:  2, weight:  0, attackSpeed:    0, attackBonus:  2 }
prefixStatWeapon Masterwork = WeaponStat { damage:  3, weight:  0, attackSpeed: -100, attackBonus:  3 }
prefixStatWeapon Godly      = WeaponStat { damage:  4, weight:  0, attackSpeed: -200, attackBonus:  4 }
prefixStatWeapon Light      = WeaponStat { damage:  0, weight: -2, attackSpeed: -100, attackBonus:  1 }
prefixStatWeapon Balanced   = WeaponStat { damage:  1, weight:  0, attackSpeed: -100, attackBonus:  3 }
prefixStatWeapon Heavy      = WeaponStat { damage:  2, weight:  3, attackSpeed:  100, attackBonus:  0 }
prefixStatWeapon _          = mempty

prefixStatArmor :: ArmorPrefix -> ArmorStat
prefixStatArmor BrokenA     = ArmorStat { defence: -1, weight:  -5 }
prefixStatArmor RustyA      = ArmorStat { defence:  1, weight:   5 }
prefixStatArmor MasterworkA = ArmorStat { defence:  5, weight:   5 }
prefixStatArmor GodlyA      = ArmorStat { defence:  7, weight:  10 }
prefixStatArmor LightA      = ArmorStat { defence:  0, weight: -10 }
prefixStatArmor HeavyA      = ArmorStat { defence:  2, weight:  10 }
prefixStatArmor _          = mempty

showPrefixWeapon :: [WeaponPrefix] -> String
showPrefixWeapon = joinWith " " <<< map show

instance showWeaponPrefix :: Show WeaponPrefix where
    show Rusty      = "rusty"
    show Broken     = "broken"
    show Dull       = "dull"
    show Masterwork = "masterwork"
    show Sharp      = "sharp"
    show Lethal     = "lethal"
    show Light      = "light"
    show Balanced   = "balanced"
    show Heavy      = "heavy"
    show Godly      = "godly"

showPrefixArmor :: [ArmorPrefix] -> String
showPrefixArmor = joinWith " " <<< map show

instance showArmorPrefix :: Show ArmorPrefix where
    show RustyA      = "rusty"
    show BrokenA     = "broken"
    show MasterworkA = "masterwork"
    show LightA      = "light"
    show HeavyA      = "heavy"
    show GodlyA      = "godly"

--------- WEAPON TYPES ---------

data WeaponType = Sword | Axe | Dagger

instance showWeaponType :: Show WeaponType where
    show Sword  = "sword"
    show Axe    = "axe"
    show Dagger = "dagger"

weaponTypeStat :: WeaponType -> WeaponStat
weaponTypeStat Sword  = WeaponStat { damage: 3, weight: 6, attackSpeed: 800,  attackBonus: 1 }
weaponTypeStat Axe    = WeaponStat { damage: 5, weight: 8, attackSpeed: 1200, attackBonus: 0 }
weaponTypeStat Dagger = WeaponStat { damage: 2, weight: 4, attackSpeed: 600,  attackBonus: 2 }

--------- ITEM TYPES ---------

data ItemType = Loot   { value :: Number }
              | Weapon { weaponType :: WeaponType, material :: Material, prefix :: [WeaponPrefix] }
              | Armor  { material :: Material, prefix :: [ArmorPrefix]}
              | Shield { material :: Material, prefix :: [ArmorPrefix] }
              | Ring

instance showItemType :: Show ItemType where
    show (Loot   { value = val })                          = "an item worth of " ++ show val ++ " gold coins"
    show (Weapon { weaponType = t, material = mat, prefix  = [] })         = show t
    show (Weapon { weaponType = t, material = mat, prefix  = prefixList }) = showPrefixWeapon prefixList ++ " " ++ show mat ++ " " ++ show t
    show (Armor  { material = mat, prefix = [] })          = show mat ++ " armor"
    show (Armor  { material = mat, prefix = prefixList })  = showPrefixArmor prefixList ++ " " ++ show mat ++ " armor"
    show (Shield  { material = mat, prefix = [] })         = show mat ++ " shield"
    show (Shield  { material = mat, prefix = prefixList }) = showPrefixArmor prefixList ++ " " ++ show mat ++ " shield"
    show Ring                                              = "One ring to fold them and in Haskell bind them."
    show _                                                 = "unknown item"

--------- ITEM ---------

type Item = { itemType :: ItemType, pos :: Point, vel :: Point }

carryingWeight :: [Item] -> Number
carryingWeight [] = 0
carryingWeight (x:xs) =
  case x.itemType of
    Weapon w -> (weaponStat x).weight + (carryingWeight xs)
    Armor  w -> (armorStat  x).weight + (carryingWeight xs)
    Shield w -> (armorStat  x).weight + (carryingWeight xs)
    _        -> carryingWeight xs

weaponStat :: Item -> WeaponStatRecord
weaponStat { itemType = Weapon w } = extractStatWeapon (materialStatWeapon w.material <> weaponTypeStat w.weaponType <> (monoidSum <<< map prefixStatWeapon $ w.prefix))
weaponStat _ = extractStatWeapon mempty

armorStat :: Item -> ArmorStatRecord
armorStat { itemType = Armor  w } = extractStatArmor (materialStatArmor w.material <> (monoidSum <<< map prefixStatArmor $ w.prefix))
armorStat { itemType = Shield w } = extractStatArmor (materialStatArmor w.material <> (monoidSum <<< map prefixStatArmor $ w.prefix))
armorStat _ = extractStatArmor mempty

showItem :: Item -> String
showItem i@{ itemType = Weapon _ } = let s = weaponStat i in show i.itemType ++ ", Dmg: "     ++ show (s.damage)  ++ ", Weight: " ++ show (s.weight)
showItem i@{ itemType = Armor  _ } = let s = armorStat  i in show i.itemType ++ ", Defence: " ++ show (s.defence) ++ ", Weight: " ++ show (s.weight)
showItem i@{ itemType = Shield _ } = let s = armorStat  i in show i.itemType ++ ", Defence: " ++ show (s.defence) ++ ", Weight: " ++ show (s.weight)
showItem i = show i.itemType


Fix Prefix Id Bug

Fix Prefix Id Bug

module Web
  ( exprToJQuery
  , getPath
  , topLevelTypetoJQuery
  , idExpr
  , drawLines
  , findConnections
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.JQuery as J
import DOM
import Prelude

import Data.Foldable (all,foldr)
import Data.Traversable (for)
import Data.List
import Data.Tuple
import Data.String (joinWith)
import Data.Foreign (unsafeFromForeign, Foreign())
import Control.Apply ((*>))
import Control.Bind ((=<<), (>=>))
import Control.Monad.State
import Control.Monad.Eff.Class

import AST
import Evaluator (Path(..))
import TypeChecker (prettyPrintType,extractType,mapM)
import JSHelpers

pathPropName :: String
pathPropName = "clickyEvaluation_path"

getPath :: forall eff. J.JQuery -> Eff (dom :: DOM | eff) Path
getPath j = unsafeFromForeign <$> J.getProp pathPropName j

-- TODO rename to fit new Type
exprToJQuery :: forall eff. Output -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery output = go id output
  where
  go :: (Path -> Path) -> Output -> Eff (dom :: DOM | eff) J.JQuery
  go p o = J.setProp pathPropName (p End) =<< case o of
    {expr:(Atom a), typ:(TAtom t), idTree:(IAtom i)} -> atom a t i
    {expr:(Binary op e1 e2), typ:(TBinary opt tt1 tt2 t), idTree:(IBinary opi i1 i2 i)} -> do
      j1 <- go (p <<< Fst) {expr:e1, typ:tt1, idTree:i1}
      j2 <- go (p <<< Snd) {expr:e2, typ:tt2, idTree:i2}
      binary op opt opi t i j1 j2

    {expr:(List es), typ:(TListTree ts t), idTree:(IListTree is i)} -> case isString es of
                  true  -> string es t i
                  false -> do js <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t, idTree:i'}) (0 .. (length es - 1)) (zip is (zip es ts))
                              list js t i
    {expr:NTuple es, typ:TNTuple ts t,idTree: INTuple is i} -> do
      js <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t,idTree:i'}) (0 .. (length es - 1)) (zip is (zip es ts))
      tuple js t i
    {expr:SectL e op, typ:TSectL tt opt t, idTree:(ISectL i opi i')} -> do
      j <- go (p <<< Fst) {expr:e, typ:tt, idTree: i}
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
      section j jop t i'
    {expr:SectR op e, typ:TSectR opt tt t, idTree: (ISectR opi i i')} -> do
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
      j <- go (p <<< Snd) {expr:e, typ:tt, idTree: i}
      section jop j t i'
    {expr:PrefixOp op, typ:TPrefixOp t, idTree: (IPrefixOp i)} -> makeDiv ("(" ++ pPrintOp op ++ ")") (toList ["prefix", "op"]) >>= addTypetoDiv t >>= addIdtoDiv i
    {expr:IfExpr cond thenExpr elseExpr, typ:TIfExpr tt1 tt2  tt3 t,idTree:IIfExpr i1 i2 i3 i} -> do
      jc <- go (p <<< Fst) {expr:cond, typ:tt1, idTree: i1}
      jt <- go (p <<< Snd) {expr:thenExpr, typ:tt2, idTree: i2}
      je <- go (p <<< Thrd) {expr:elseExpr, typ:tt3, idTree: i3}
      ifexpr jc jt je t i
    {expr:Lambda binds body, typ:TLambda lb tt t, idTree: (ILambda bis i i')} -> do
      jBinds <- for (zip bis (zip binds lb)) binding
      jBody <- go (p <<< Fst) {expr:body, typ:tt, idTree: i}
      lambda jBinds jBody t i'
    {expr:App func args, typ:TApp tt ts t, idTree:IApp i1 is i} -> do
      jFunc <- go (p <<< Fst) {expr:func, typ:tt, idTree: i1}
      jArgs <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t, idTree: i'}) (0 .. (length args - 1)) (zip is (zip args ts))
      app jFunc jArgs t i
    {} -> makeDiv "You found a Bug" Nil

atom :: forall eff. Atom -> Type -> Int ->  Eff (dom :: DOM | eff) J.JQuery
atom (AInt n) t  i   = makeDiv (show n) (toList ["atom", "num"]) >>= addTypetoDiv t >>= addIdtoDiv i
atom (Bool true) t i = makeDiv "True"  (toList ["atom", "bool"]) >>= addTypetoDiv t >>= addIdtoDiv i
atom (Bool false) t i= makeDiv "False" (toList ["atom", "bool"]) >>= addTypetoDiv t >>= addIdtoDiv i
atom (Char c) t  i  = (makeDiv ("'" ++ c ++ "'") (toList ["atom", "char"])) >>= addTypetoDiv t >>= addIdtoDiv i
atom (Name name) t i = makeDiv name (toList ["atom", "name"]) >>= addTypetoDiv t >>= addIdtoDiv i

binding :: forall eff. Tuple IBinding (Tuple Binding  TypeBinding) -> Eff (dom :: DOM | eff) J.JQuery
binding b = case b of
  Tuple (ILit i) (Tuple (Lit a) (TLit t))       -> atom a t i
  Tuple (IConsLit i1 i2 i) (Tuple (ConsLit b bs) (TConsLit tb tbs t))-> do
    jCons <- makeDiv "" Nil >>= addTypetoDiv t >>= addIdtoDiv i
    makeDiv "(" (singleton "brace") >>= flip J.append jCons
    binding (Tuple i1 (Tuple b tb))            >>= flip J.append jCons
    makeDiv ":" (singleton "colon") >>= flip J.append jCons
    binding (Tuple i2 (Tuple bs tbs))           >>= flip J.append jCons
    makeDiv ")" (singleton "brace") >>= flip J.append jCons
  Tuple (IListLit is i)(Tuple (ListLit bs) (TListLit tbs t)) -> do
    jList <- makeDiv "" Nil >>= addTypetoDiv t >>= addIdtoDiv i
    makeDiv "[" (singleton "brace") >>= flip J.append jList
    let bx = zip is (zip bs tbs)
    for bx $ \b -> do
      binding b >>= flip J.append jList
      makeDiv "," (singleton "comma") >>= flip J.append jList
    makeDiv "]" (singleton "brace") >>= flip J.append jList
  Tuple (INTupleLit is i)(Tuple (NTupleLit bs) (TNTupleLit tbs t))-> do
    jTuple <- makeDiv "" Nil >>= addTypetoDiv t >>= addIdtoDiv i
    makeDiv "(" (singleton "brace") >>= flip J.append jTuple
    let b = (zip is (zip bs tbs))
    interleaveM_ (binding >=> flip J.append jTuple) (makeDiv "," (singleton "comma") >>= flip J.append jTuple) b
    makeDiv ")" (singleton "brace") >>= flip J.append jTuple
    return jTuple

lambda :: forall eff. List J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
lambda jBinds jBody t i = do
  jLam <- makeDiv "" (singleton "lambda") >>= addTypetoDiv t >>= addIdtoDiv i
  open <- makeDiv "(" (singleton "brace")
  J.append open jLam
  bs <- makeDiv "\\" (singleton "backslash")
  J.append bs jLam
  for jBinds (flip J.append jLam)
  arrow <- makeDiv "->" (singleton "arrow")
  J.append arrow jLam
  J.append jBody jLam
  close <- makeDiv ")" (singleton "brace")
  J.append close jLam
  return jLam

binary :: forall eff. Op -> Type -> Int -> Type -> Int -> J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
binary op opt opi t i j1 j2 = do
  dBin <- makeDiv "" (singleton "binary") >>= addTypetoDiv t >>= addIdtoDiv i
  J.append j1 dBin
  dOp <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
  J.append dOp dBin
  J.append j2 dBin
  return dBin

section :: forall eff. J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
section j1 j2 t i = do
  jSect <- makeDiv "" (singleton "section") >>= addTypetoDiv t >>= addIdtoDiv i
  open <- makeDiv "(" (singleton "brace")
  J.append open jSect
  J.append j1 jSect
  J.append j2 jSect
  close <- makeDiv ")" (singleton "brace")
  J.append close jSect
  return jSect

ifexpr :: forall eff. J.JQuery -> J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
ifexpr cond thenExpr elseExpr t i = do
  dIf <- makeDiv "" (singleton "if") >>= addTypetoDiv t >>= addIdtoDiv i
  makeDiv "if" (singleton "keyword") >>= flip J.append dIf
  J.append cond dIf
  makeDiv "then" (singleton "keyword") >>= flip J.append dIf
  J.append thenExpr dIf
  makeDiv "else" (singleton "keyword") >>= flip J.append dIf
  J.append elseExpr dIf
  return dIf

interleaveM_ :: forall a b m. (Monad m) => (a -> m b) -> m b -> List a -> m Unit
interleaveM_ f sep = go
  where
  go Nil     = return unit
  go (Cons x Nil)    = void $ f x
  go (Cons x xs) = f x *> sep *> go xs

tuple :: forall eff. List J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
tuple js t i = do
  dtuple <- makeDiv "" (singleton "tuple") >>= addTypetoDiv t >>= addIdtoDiv i
  open <- makeDiv "(" (singleton "brace")
  J.append open dtuple
  interleaveM_ (flip J.append dtuple) (makeDiv "," (singleton "comma") >>= flip J.append dtuple) js
  close <- makeDiv ")" (singleton "brace")
  J.append close dtuple
  return dtuple

list :: forall eff. List J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
list js t   i  = do
  dls <- makeDiv "" (singleton "list") >>= addTypetoDiv t >>= addIdtoDiv i
  open <- makeDiv "[" (singleton "brace")
  J.append open dls
  interleaveM_ (flip J.append dls) (makeDiv "," (singleton "comma") >>= flip J.append dls) js
  close <- makeDiv "]" (singleton "brace")
  J.append close dls
  return dls

isString :: List Expr -> Boolean
isString es = length es > 0 && all isChar es
  where
  isChar (Atom (Char _)) = true
  isChar _               = false

string :: forall eff. List Expr -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
string es t i = do
  let str = "\"" ++ joinWith "" (fromList ((\(Atom (Char s)) -> s) <$> es)) ++ "\""
  dstring <- makeDiv str (toList ["list", "string"]) >>= addTypetoDiv t >>= addIdtoDiv i
  return dstring

app :: forall eff. J.JQuery -> List J.JQuery -> Type -> Int  -> Eff (dom :: DOM | eff) J.JQuery
app jFunc jArgs t i = do
  dApp <- makeDiv "" (singleton "app") >>= addTypetoDiv t >>= addIdtoDiv i
  J.addClass "func" jFunc
  J.append jFunc dApp
  for jArgs (flip J.append dApp)
  return dApp

type Class = String

makeDiv :: forall eff. String -> List Class -> Eff (dom :: DOM | eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for classes (flip J.addClass d)
  return d

emptyJQuery:: forall eff . Eff (dom :: DOM | eff) J.JQuery
emptyJQuery = J.create ""

addTypetoDiv:: forall eff. Type -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addTypetoDiv typ d = do
  J.setAttr "title" (prettyPrintType typ) d

addIdtoDiv:: forall eff a. (Show a) => a -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addIdtoDiv id d = do
    J.setAttr "id" ("expr"++(show id)) d

addTypIdtoDiv:: forall eff a. (Show a) => a -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addTypIdtoDiv id d = do
    J.setAttr "id" ("typ"++(show id)) d

addResultIdtoDiv:: forall eff a. (Show a) => a -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addResultIdtoDiv id d = do
    J.setAttr "id" ("typ" ++ (show id) ++ "result") d

dummyExpr:: Expr
dummyExpr =  Atom $ AInt 0

typetoJQuery:: forall eff. Output -> Eff (dom :: DOM | eff) J.JQuery
typetoJQuery {typ:TListTree ls t, idTree: IListTree is i} = do
    container <- makeDiv "" $ Cons "output" Nil
    list <- mapM (\(Tuple t i) -> typetoJQuery {typ:t , idTree:i ,expr:dummyExpr}) (zip ls is)
    for list $ (\l -> J.append l container)
    containerContent <- J.getText container
    if Data.String.length containerContent == 0 then J.setAttr "class" "" container else emptyJQuery
    return $ container
typetoJQuery {typ:TNTuple ls t, idTree: INTuple is i} = do
    container <- makeDiv "" $ Cons "output" Nil
    list <- mapM (\(Tuple t i) -> typetoJQuery {typ:t , idTree:i ,expr:dummyExpr}) (zip ls is)
    for list $ (\l -> J.append l container)
    containerContent <- J.getText container
    if Data.String.length containerContent == 0 then J.setAttr "class" "" container else emptyJQuery
    return $ container
typetoJQuery {typ:TBinary t1 tt1 tt2 t, idTree:IBinary i1 it1 it2 i} = do
    container <- makeDiv "" Nil
    subContainer <- makeDiv "" $ Cons "subtypes output" Nil
    jExp1 <- typetoJQuery {typ:tt1 ,idTree:it1, expr:dummyExpr}
    jExp2 <- typetoJQuery {typ:tt2 ,idTree:it2, expr:dummyExpr}
    J.append jExp1 subContainer
    J.append jExp2 subContainer
    contentSub <- J.getText subContainer
    if Data.String.length contentSub == 0 then J.setAttr "class" "" subContainer else emptyJQuery
    J.append subContainer container
typetoJQuery {typ: TUnary t1 tt t, idTree: IUnary i1 it i} = emptyJQuery --TODO

typetoJQuery {typ: TSectL tt _ _, idTree: ISectL it _ _} = typetoJQuery {typ:tt, idTree:it, expr:dummyExpr}
typetoJQuery {typ: TSectR _ tt _, idTree: ISectR _ it _} = typetoJQuery {typ:tt, idTree:it, expr:dummyExpr}

typetoJQuery {typ: TIfExpr t1 t2 t3 t, idTree: IIfExpr i1 i2 i3 i} = do
    container <- makeDiv "" $ Cons "output" Nil
    div1 <- typetoJQuery {typ:t1,idTree:i1,expr:dummyExpr}
    div2 <- typetoJQuery {typ:t2,idTree:i2,expr:dummyExpr}
    div3 <- typetoJQuery {typ:t3,idTree:i3,expr:dummyExpr}
    J.append div1 container
    J.append div2 container
    J.append div3 container
    containerContent <- J.getText container
    if Data.String.length containerContent == 0 then J.setAttr "class" "" container else emptyJQuery
    return container

typetoJQuery {typ: TLetExpr _ tt1 tt2 t,idTree: ILetExpr _ it1 it2 i} = emptyJQuery --TODO

typetoJQuery {typ: TLambda _ tt t, idTree: ILambda _ it i} = typetoJQuery {typ:tt,idTree:it,expr:dummyExpr}

typetoJQuery {typ:TApp t1 tl t, idTree:IApp i1 is i} = do
    container <- makeDiv "" Nil
    typContainer <- (makeDiv "" $ Cons "output" Nil) >>= addTypIdtoDiv (extractIndex i1)
    list <- mapM (\(Tuple t i) -> (makeDiv (prettyPrintType (extractType t)) $ Cons "output" Nil) >>= (addTypIdtoDiv (extractIndex i))) (zip tl is)
    for list $ (\l -> do
                  J.append l typContainer
                  arr <- makeDiv " -> " Nil
                  J.append arr typContainer)
    exprType <- (makeDiv (prettyPrintType t) $ Cons "output" Nil) >>= addResultIdtoDiv i
    J.append exprType typContainer
    J.append typContainer container
    br <- J.create "
"
    J.append br container
    subContainer <- makeDiv "" $ Cons "subtypes output" Nil
    divExpr <- typetoJQuery {typ: t1,idTree:i1,expr:dummyExpr}
    J.append divExpr subContainer
    list <- mapM (\(Tuple t i) -> typetoJQuery {typ:t,idTree:i, expr:dummyExpr}) (zip tl is)
    for list $ (\l -> J.append l subContainer)
    contentSub <- J.getText subContainer
    if Data.String.length contentSub == 0 then J.setAttr "class" "" subContainer else emptyJQuery
    J.append subContainer container

typetoJQuery {typ:typ} = emptyJQuery

-- to show type even is no application
topLevelTypetoJQuery :: forall eff. Output -> Eff (dom :: DOM | eff) J.JQuery
topLevelTypetoJQuery {typ:TBinary t1 tt1 tt2 t, idTree:IBinary i1 it1 it2 i} = do
        container <- makeDiv "" Nil
        typContainer <- (makeDiv "" $ Cons "output" Nil) >>= addTypIdtoDiv i1
        div1 <- (makeDiv (prettyPrintType (extractType tt1)) $ Cons "output" Nil) >>= (addTypIdtoDiv (extractIndex it1))
        div2 <- (makeDiv (prettyPrintType (extractType tt2)) $ Cons "output" Nil) >>= (addTypIdtoDiv (extractIndex it2))
        div3 <- (makeDiv (prettyPrintType t) $ Cons "output" Nil) >>= (addResultIdtoDiv i)
        arr <- makeDiv " -> " Nil
        arr2 <- makeDiv " -> " Nil
        J.append div1 typContainer
        J.append arr typContainer
        J.append div2 typContainer
        J.append arr2 typContainer
        J.append div3 typContainer
        J.append typContainer container
        br <- J.create "
"
        J.append br container
        subContainer <- makeDiv "" $ Cons "subtypes output" Nil
        jExp1 <- typetoJQuery {typ:tt1 ,idTree:it1, expr:dummyExpr}
        jExp2 <- typetoJQuery {typ:tt2 ,idTree:it2, expr:dummyExpr}
        J.append jExp1 subContainer
        J.append jExp2 subContainer
        contentSub <- J.getText subContainer
        if Data.String.length contentSub == 0 then J.setAttr "class" "" subContainer else emptyJQuery
        J.append subContainer container

topLevelTypetoJQuery t@{typ:tt, idTree: it} = do
        container <- makeDiv "" Nil
        typContainer <- makeDiv (prettyPrintType (extractType tt)) $ Cons "output" Nil
        addTypIdtoDiv (extractIndex it) typContainer
        J.append typContainer container
        br <- J.create "
"
        J.append br container
        types <- typetoJQuery t
        J.append types container

findConnections:: IndexTree -> List (Tuple String String)
findConnections (IBinary i1 it1 it2 i) = Cons (buildPairResult i) $  Cons (buildPair i1) $ Cons (buildPair (extractIndex it1)) $ Cons (buildPair (extractIndex it2)) $ findOtherConnections it1 ++ findOtherConnections it2
findConnections id = Cons (buildPair (extractIndex id)) $ findOtherConnections id

findOtherConnections:: IndexTree -> List (Tuple String String)
findOtherConnections (IListTree ls _) = concat $ map findOtherConnections ls
findOtherConnections (INTuple ls _) = concat $ map findOtherConnections ls
findOtherConnections (IBinary _ it1 it2 _) = findOtherConnections it1 ++ findOtherConnections it2
findOtherConnections (IUnary _ it _) = findOtherConnections it
findOtherConnections (ISectL it _ _ ) = findOtherConnections it
findOtherConnections (ISectR _ it _ ) = findOtherConnections it
findOtherConnections (IIfExpr it1 it2 it3 _ ) = findOtherConnections it1 ++ findOtherConnections it2 ++ findOtherConnections it3
findOtherConnections (ILetExpr _ it1 it2 _ ) = findOtherConnections it1 ++ findOtherConnections it2
findOtherConnections (ILambda _ it _) = findOtherConnections it
findOtherConnections (IApp it its i) =  Cons (buildPair (extractIndex it))  $  Cons (buildPairResult i) $ (map (\i -> buildPair $ extractIndex i) its) ++ (concat (map findOtherConnections its)) -- Cons buildPair i
findOtherConnections _ = Nil -- atom prefixOP

buildPair:: Int -> (Tuple String String)
buildPair i = Tuple ("typ" ++ show i) ("expr" ++ show i)

buildPairResult:: Int -> (Tuple String String)
buildPairResult i = Tuple ("expr" ++ show i) ("typ"++ (show i) ++ "result")

-- draws a line between two divs
-- canvas obj1 obj2 svgContainer
-- Foreign JQuery JQuery JQuery
drawLines::forall eff. Foreign -> J.JQuery -> List (Tuple String String) -> Eff (dom :: DOM | eff) Unit
drawLines canvas svgContainer lines' = do
      lines <- mapM toJQueryPair lines'
      for lines $ (\(Tuple l1 l2) -> do
              y1 <- yOffset l1
              x1 <- xOffset l1
              y2 <- yOffset l2
              x2 <- xOffset l2
              path canvas $ "M" ++ (show x1) ++ " " ++ (show y1) ++ "L" ++ (show x2) ++ " " ++ (show y2)
          )
      return unit
    where
    -- calculates x and y offset to svgContainer
    yOffset jObj = offsetTop jObj >>= (\y -> offsetTop svgContainer >>= (\x -> return (y - x)))
    xOffset jObj = offsetLeft jObj >>= (\y -> offsetLeft svgContainer >>= (\x -> return (y - x)))

-- fings matching typ expr pair
toJQueryPair::forall eff. Tuple String String -> Eff (dom :: DOM | eff) (Tuple J.JQuery J.JQuery)
toJQueryPair (Tuple id1 id2) = do
  typ <- J.select ("#" ++ id1)
  expr <- J.select ("#" ++ id2)
  return $ Tuple typ expr

idExpr:: Expr -> IndexTree
idExpr e = fst $ runState (indexExpr e) {count:0}

indexExpr:: Expr -> State {count:: Int} IndexTree
indexExpr (Atom _) = do
                  i <- fresh
                  return $ IAtom i
indexExpr (List es) = do
                  is <- mapM indexExpr es
                  i <- fresh
                  return $ IListTree is i
indexExpr (NTuple es) = do
                  is <- mapM indexExpr es
                  i <- fresh
                  return $ INTuple is i
indexExpr (Binary _ e1 e2) = do
                  i1 <- indexExpr e1
                  i2 <- indexExpr e2
                  i <- fresh
                  i' <- fresh
                  return $ (IBinary i' i1 i2 i)
indexExpr (Unary _ e) = do
                  i <- indexExpr e
                  i' <- fresh
                  i'' <- fresh
                  return $ IUnary i'' i i'
indexExpr (SectL e _) = do
                  i <- indexExpr e
                  i' <- fresh
                  i'' <- fresh
                  return $ ISectL i i'' i'
indexExpr (SectR _ e) = do
                  i <- indexExpr e
                  i' <- fresh
                  i'' <- fresh
                  return $ ISectR i'' i i'
indexExpr (PrefixOp _) = do
                  i <- fresh
                  return $ IPrefixOp i
indexExpr (IfExpr e1 e2 e3) = do
                  i1 <- indexExpr e1
                  i2 <- indexExpr e2
                  i3 <- indexExpr e3
                  i <- fresh
                  return $ IIfExpr i1 i2 i3 i
indexExpr (LetExpr b e1 e2) = do
                  ib <- indexBinding b
                  i1 <- indexExpr e1
                  i2 <- indexExpr e2
                  i <- fresh
                  return $ ILetExpr ib i1 i2 i
indexExpr (Lambda bs e) = do
                 ibs <- mapM indexBinding bs
                 i <- indexExpr e
                 i' <- fresh
                 return $ ILambda ibs i i'
indexExpr (App e es) = do
                e1 <- indexExpr e
                is <- mapM indexExpr es
                i <- fresh
                return $ IApp e1 is i

indexBinding:: Binding -> State {count :: Int} IBinding
indexBinding (Lit _) = do
                    i <- fresh
                    return $ ILit i
indexBinding (ConsLit b1 b2 ) = do
                      i1 <- indexBinding b1
                      i2 <- indexBinding b2
                      i <- fresh
                      return $ IConsLit i1 i2 i
indexBinding (ListLit bs) = do
                        is <- mapM indexBinding bs
                        i <- fresh
                        return $ IListLit is i
indexBinding (NTupleLit bs) = do
                      is <- mapM indexBinding bs
                      i <- fresh
                      return $ INTupleLit is i

fresh ::State {count:: Int} Int
fresh = do
  {count = count} <- get
  put {count:count+1}
  return count

extractIndex:: IndexTree -> Int
extractIndex (IAtom i)  =  i
extractIndex (IListTree _ i)  =  i
extractIndex (INTuple _ i)  =  i
extractIndex (IBinary _ _ _ i)  =  i
extractIndex (IUnary _ _ i)  =  i
extractIndex (ISectL _ _ i)  =  i
extractIndex (ISectR _ _ i)  =  i
extractIndex (IPrefixOp i)  =  i
extractIndex (IIfExpr _ _ _ i)  =  i
extractIndex (ILetExpr _ _ _ i)  =  i
extractIndex (ILambda _ _ i)  =  i
extractIndex (IApp _ _ i)  =  i

module Web
  ( exprToJQuery
  , getPath
  , topLevelTypetoJQuery
  , idExpr
  , drawLines
  , findConnections
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.JQuery as J
import DOM
import Prelude

import Data.Foldable (all,foldr)
import Data.Traversable (for)
import Data.List
import Data.Tuple
import Data.String (joinWith)
import Data.Foreign (unsafeFromForeign, Foreign())
import Control.Apply ((*>))
import Control.Bind ((=<<), (>=>))
import Control.Monad.State
import Control.Monad.Eff.Class

import AST
import Evaluator (Path(..))
import TypeChecker (prettyPrintType,extractType,mapM)
import JSHelpers

pathPropName :: String
pathPropName = "clickyEvaluation_path"

getPath :: forall eff. J.JQuery -> Eff (dom :: DOM | eff) Path
getPath j = unsafeFromForeign <$> J.getProp pathPropName j

-- TODO rename to fit new Type
exprToJQuery :: forall eff. Output -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery output = go id output
  where
  go :: (Path -> Path) -> Output -> Eff (dom :: DOM | eff) J.JQuery
  go p o = J.setProp pathPropName (p End) =<< case o of
    {expr:(Atom a), typ:(TAtom t), idTree:(IAtom i)} -> atom a t i
    {expr:(Binary op e1 e2), typ:(TBinary opt tt1 tt2 t), idTree:(IBinary opi i1 i2 i)} -> do
      j1 <- go (p <<< Fst) {expr:e1, typ:tt1, idTree:i1}
      j2 <- go (p <<< Snd) {expr:e2, typ:tt2, idTree:i2}
      binary op opt opi t i j1 j2

    {expr:(List es), typ:(TListTree ts t), idTree:(IListTree is i)} -> case isString es of
                  true  -> string es t i
                  false -> do js <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t, idTree:i'}) (0 .. (length es - 1)) (zip is (zip es ts))
                              list js t i
    {expr:NTuple es, typ:TNTuple ts t,idTree: INTuple is i} -> do
      js <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t,idTree:i'}) (0 .. (length es - 1)) (zip is (zip es ts))
      tuple js t i
    {expr:SectL e op, typ:TSectL tt opt t, idTree:(ISectL i opi i')} -> do
      j <- go (p <<< Fst) {expr:e, typ:tt, idTree: i}
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
      section j jop t i'
    {expr:SectR op e, typ:TSectR opt tt t, idTree: (ISectR opi i i')} -> do
      jop <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
      j <- go (p <<< Snd) {expr:e, typ:tt, idTree: i}
      section jop j t i'
    {expr:PrefixOp op, typ:TPrefixOp t, idTree: (IPrefixOp i)} -> makeDiv ("(" ++ pPrintOp op ++ ")") (toList ["prefix", "op"]) >>= addTypetoDiv t
    {expr:IfExpr cond thenExpr elseExpr, typ:TIfExpr tt1 tt2  tt3 t,idTree:IIfExpr i1 i2 i3 i} -> do
      jc <- go (p <<< Fst) {expr:cond, typ:tt1, idTree: i1}
      jt <- go (p <<< Snd) {expr:thenExpr, typ:tt2, idTree: i2}
      je <- go (p <<< Thrd) {expr:elseExpr, typ:tt3, idTree: i3}
      ifexpr jc jt je t i
    {expr:Lambda binds body, typ:TLambda lb tt t, idTree: (ILambda bis i i')} -> do
      jBinds <- for (zip bis (zip binds lb)) binding
      jBody <- go (p <<< Fst) {expr:body, typ:tt, idTree: i}
      lambda jBinds jBody t i'
    {expr:App func args, typ:TApp tt ts t, idTree:IApp i1 is i} -> do
      jFunc <- go (p <<< Fst) {expr:func, typ:tt, idTree: i1}
      jArgs <- zipWithA (\i (Tuple i' (Tuple e t)) -> go (p <<< Nth i) {expr:e, typ:t, idTree: i'}) (0 .. (length args - 1)) (zip is (zip args ts))
      app jFunc jArgs t i
    {} -> makeDiv "You found a Bug" Nil

atom :: forall eff. Atom -> Type -> Int ->  Eff (dom :: DOM | eff) J.JQuery
atom (AInt n) t  i   = makeDiv (show n) (toList ["atom", "num"]) >>= addTypetoDiv t >>= addIdtoDiv i
atom (Bool true) t i = makeDiv "True"  (toList ["atom", "bool"]) >>= addTypetoDiv t >>= addIdtoDiv i
atom (Bool false) t i= makeDiv "False" (toList ["atom", "bool"]) >>= addTypetoDiv t >>= addIdtoDiv i
atom (Char c) t  i  = (makeDiv ("'" ++ c ++ "'") (toList ["atom", "char"])) >>= addTypetoDiv t >>= addIdtoDiv i
atom (Name name) t i = makeDiv name (toList ["atom", "name"]) >>= addTypetoDiv t >>= addIdtoDiv i

binding :: forall eff. Tuple IBinding (Tuple Binding  TypeBinding) -> Eff (dom :: DOM | eff) J.JQuery
binding b = case b of
  Tuple (ILit i) (Tuple (Lit a) (TLit t))       -> atom a t i
  Tuple (IConsLit i1 i2 i) (Tuple (ConsLit b bs) (TConsLit tb tbs t))-> do
    jCons <- makeDiv "" Nil >>= addTypetoDiv t >>= addIdtoDiv i
    makeDiv "(" (singleton "brace") >>= flip J.append jCons
    binding (Tuple i1 (Tuple b tb))            >>= flip J.append jCons
    makeDiv ":" (singleton "colon") >>= flip J.append jCons
    binding (Tuple i2 (Tuple bs tbs))           >>= flip J.append jCons
    makeDiv ")" (singleton "brace") >>= flip J.append jCons
  Tuple (IListLit is i)(Tuple (ListLit bs) (TListLit tbs t)) -> do
    jList <- makeDiv "" Nil >>= addTypetoDiv t >>= addIdtoDiv i
    makeDiv "[" (singleton "brace") >>= flip J.append jList
    let bx = zip is (zip bs tbs)
    for bx $ \b -> do
      binding b >>= flip J.append jList
      makeDiv "," (singleton "comma") >>= flip J.append jList
    makeDiv "]" (singleton "brace") >>= flip J.append jList
  Tuple (INTupleLit is i)(Tuple (NTupleLit bs) (TNTupleLit tbs t))-> do
    jTuple <- makeDiv "" Nil >>= addTypetoDiv t >>= addIdtoDiv i
    makeDiv "(" (singleton "brace") >>= flip J.append jTuple
    let b = (zip is (zip bs tbs))
    interleaveM_ (binding >=> flip J.append jTuple) (makeDiv "," (singleton "comma") >>= flip J.append jTuple) b
    makeDiv ")" (singleton "brace") >>= flip J.append jTuple
    return jTuple

lambda :: forall eff. List J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
lambda jBinds jBody t i = do
  jLam <- makeDiv "" (singleton "lambda") >>= addTypetoDiv t >>= addIdtoDiv i
  open <- makeDiv "(" (singleton "brace")
  J.append open jLam
  bs <- makeDiv "\\" (singleton "backslash")
  J.append bs jLam
  for jBinds (flip J.append jLam)
  arrow <- makeDiv "->" (singleton "arrow")
  J.append arrow jLam
  J.append jBody jLam
  close <- makeDiv ")" (singleton "brace")
  J.append close jLam
  return jLam

binary :: forall eff. Op -> Type -> Int -> Type -> Int -> J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
binary op opt opi t i j1 j2 = do
  dBin <- makeDiv "" (singleton "binary") >>= addTypetoDiv t >>= addIdtoDiv i
  J.append j1 dBin
  dOp <- makeDiv (pPrintOp op) (singleton "op") >>= addTypetoDiv opt >>= addIdtoDiv opi
  J.append dOp dBin
  J.append j2 dBin
  return dBin

section :: forall eff. J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
section j1 j2 t i = do
  jSect <- makeDiv "" (singleton "section") >>= addTypetoDiv t >>= addIdtoDiv i
  open <- makeDiv "(" (singleton "brace")
  J.append open jSect
  J.append j1 jSect
  J.append j2 jSect
  close <- makeDiv ")" (singleton "brace")
  J.append close jSect
  return jSect

ifexpr :: forall eff. J.JQuery -> J.JQuery -> J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
ifexpr cond thenExpr elseExpr t i = do
  dIf <- makeDiv "" (singleton "if") >>= addTypetoDiv t >>= addIdtoDiv i
  makeDiv "if" (singleton "keyword") >>= flip J.append dIf
  J.append cond dIf
  makeDiv "then" (singleton "keyword") >>= flip J.append dIf
  J.append thenExpr dIf
  makeDiv "else" (singleton "keyword") >>= flip J.append dIf
  J.append elseExpr dIf
  return dIf

interleaveM_ :: forall a b m. (Monad m) => (a -> m b) -> m b -> List a -> m Unit
interleaveM_ f sep = go
  where
  go Nil     = return unit
  go (Cons x Nil)    = void $ f x
  go (Cons x xs) = f x *> sep *> go xs

tuple :: forall eff. List J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
tuple js t i = do
  dtuple <- makeDiv "" (singleton "tuple") >>= addTypetoDiv t >>= addIdtoDiv i
  open <- makeDiv "(" (singleton "brace")
  J.append open dtuple
  interleaveM_ (flip J.append dtuple) (makeDiv "," (singleton "comma") >>= flip J.append dtuple) js
  close <- makeDiv ")" (singleton "brace")
  J.append close dtuple
  return dtuple

list :: forall eff. List J.JQuery -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
list js t   i  = do
  dls <- makeDiv "" (singleton "list") >>= addTypetoDiv t >>= addIdtoDiv i
  open <- makeDiv "[" (singleton "brace")
  J.append open dls
  interleaveM_ (flip J.append dls) (makeDiv "," (singleton "comma") >>= flip J.append dls) js
  close <- makeDiv "]" (singleton "brace")
  J.append close dls
  return dls

isString :: List Expr -> Boolean
isString es = length es > 0 && all isChar es
  where
  isChar (Atom (Char _)) = true
  isChar _               = false

string :: forall eff. List Expr -> Type -> Int -> Eff (dom :: DOM | eff) J.JQuery
string es t i = do
  let str = "\"" ++ joinWith "" (fromList ((\(Atom (Char s)) -> s) <$> es)) ++ "\""
  dstring <- makeDiv str (toList ["list", "string"]) >>= addTypetoDiv t >>= addIdtoDiv i
  return dstring

app :: forall eff. J.JQuery -> List J.JQuery -> Type -> Int  -> Eff (dom :: DOM | eff) J.JQuery
app jFunc jArgs t i = do
  dApp <- makeDiv "" (singleton "app") >>= addTypetoDiv t >>= addIdtoDiv i
  J.addClass "func" jFunc
  J.append jFunc dApp
  for jArgs (flip J.append dApp)
  return dApp

type Class = String

makeDiv :: forall eff. String -> List Class -> Eff (dom :: DOM | eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for classes (flip J.addClass d)
  return d

emptyJQuery:: forall eff . Eff (dom :: DOM | eff) J.JQuery
emptyJQuery = J.create ""

addTypetoDiv:: forall eff. Type -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addTypetoDiv typ d = do
  J.setAttr "title" (prettyPrintType typ) d

addIdtoDiv:: forall eff a. (Show a) => a -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addIdtoDiv id d = do
    J.setAttr "id" ("expr"++(show id)) d

addTypIdtoDiv:: forall eff a. (Show a) => a -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addTypIdtoDiv id d = do
    J.setAttr "id" ("typ"++(show id)) d

addResultIdtoDiv:: forall eff a. (Show a) => a -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
addResultIdtoDiv id d = do
    J.setAttr "id" ("typ" ++ (show id) ++ "result") d

dummyExpr:: Expr
dummyExpr =  Atom $ AInt 0

typetoJQuery:: forall eff. Output -> Eff (dom :: DOM | eff) J.JQuery
typetoJQuery {typ:TListTree ls t, idTree: IListTree is i} = do
    container <- makeDiv "" $ Cons "output" Nil
    list <- mapM (\(Tuple t i) -> typetoJQuery {typ:t , idTree:i ,expr:dummyExpr}) (zip ls is)
    for list $ (\l -> J.append l container)
    containerContent <- J.getText container
    if Data.String.length containerContent == 0 then J.setAttr "class" "" container else emptyJQuery
    return $ container
typetoJQuery {typ:TNTuple ls t, idTree: INTuple is i} = do
    container <- makeDiv "" $ Cons "output" Nil
    list <- mapM (\(Tuple t i) -> typetoJQuery {typ:t , idTree:i ,expr:dummyExpr}) (zip ls is)
    for list $ (\l -> J.append l container)
    containerContent <- J.getText container
    if Data.String.length containerContent == 0 then J.setAttr "class" "" container else emptyJQuery
    return $ container
typetoJQuery {typ:TBinary t1 tt1 tt2 t, idTree:IBinary i1 it1 it2 i} = do
    container <- makeDiv "" Nil
    subContainer <- makeDiv "" $ Cons "subtypes output" Nil
    jExp1 <- typetoJQuery {typ:tt1 ,idTree:it1, expr:dummyExpr}
    jExp2 <- typetoJQuery {typ:tt2 ,idTree:it2, expr:dummyExpr}
    J.append jExp1 subContainer
    J.append jExp2 subContainer
    contentSub <- J.getText subContainer
    if Data.String.length contentSub == 0 then J.setAttr "class" "" subContainer else emptyJQuery
    J.append subContainer container
typetoJQuery {typ: TUnary t1 tt t, idTree: IUnary i1 it i} = emptyJQuery --TODO

typetoJQuery {typ: TSectL tt _ _, idTree: ISectL it _ _} = typetoJQuery {typ:tt, idTree:it, expr:dummyExpr}
typetoJQuery {typ: TSectR _ tt _, idTree: ISectR _ it _} = typetoJQuery {typ:tt, idTree:it, expr:dummyExpr}

typetoJQuery {typ: TIfExpr t1 t2 t3 t, idTree: IIfExpr i1 i2 i3 i} = do
    container <- makeDiv "" $ Cons "output" Nil
    div1 <- typetoJQuery {typ:t1,idTree:i1,expr:dummyExpr}
    div2 <- typetoJQuery {typ:t2,idTree:i2,expr:dummyExpr}
    div3 <- typetoJQuery {typ:t3,idTree:i3,expr:dummyExpr}
    J.append div1 container
    J.append div2 container
    J.append div3 container
    containerContent <- J.getText container
    if Data.String.length containerContent == 0 then J.setAttr "class" "" container else emptyJQuery
    return container

typetoJQuery {typ: TLetExpr _ tt1 tt2 t,idTree: ILetExpr _ it1 it2 i} = emptyJQuery --TODO

typetoJQuery {typ: TLambda _ tt t, idTree: ILambda _ it i} = typetoJQuery {typ:tt,idTree:it,expr:dummyExpr}

typetoJQuery {typ:TApp t1 tl t, idTree:IApp i1 is i} = do
    container <- makeDiv "" Nil
    typContainer <- (makeDiv "" $ Cons "output" Nil) >>= addTypIdtoDiv (extractIndex i1)
    list <- mapM (\(Tuple t i) -> (makeDiv (prettyPrintType (extractType t)) $ Cons "output" Nil) >>= (addTypIdtoDiv (extractIndex i))) (zip tl is)
    for list $ (\l -> do
                  J.append l typContainer
                  arr <- makeDiv " -> " Nil
                  J.append arr typContainer)
    exprType <- (makeDiv (prettyPrintType t) $ Cons "output" Nil) >>= addResultIdtoDiv i
    J.append exprType typContainer
    J.append typContainer container
    br <- J.create "
"
    J.append br container
    subContainer <- makeDiv "" $ Cons "subtypes output" Nil
    divExpr <- typetoJQuery {typ: t1,idTree:i1,expr:dummyExpr}
    J.append divExpr subContainer
    list <- mapM (\(Tuple t i) -> typetoJQuery {typ:t,idTree:i, expr:dummyExpr}) (zip tl is)
    for list $ (\l -> J.append l subContainer)
    contentSub <- J.getText subContainer
    if Data.String.length contentSub == 0 then J.setAttr "class" "" subContainer else emptyJQuery
    J.append subContainer container

typetoJQuery {typ:typ} = emptyJQuery

-- to show type even is no application
topLevelTypetoJQuery :: forall eff. Output -> Eff (dom :: DOM | eff) J.JQuery
topLevelTypetoJQuery {typ:TBinary t1 tt1 tt2 t, idTree:IBinary i1 it1 it2 i} = do
        container <- makeDiv "" Nil
        typContainer <- (makeDiv "" $ Cons "output" Nil) >>= addTypIdtoDiv i1
        div1 <- (makeDiv (prettyPrintType (extractType tt1)) $ Cons "output" Nil) >>= (addTypIdtoDiv (extractIndex it1))
        div2 <- (makeDiv (prettyPrintType (extractType tt2)) $ Cons "output" Nil) >>= (addTypIdtoDiv (extractIndex it2))
        div3 <- (makeDiv (prettyPrintType t) $ Cons "output" Nil) >>= (addResultIdtoDiv i)
        arr <- makeDiv " -> " Nil
        arr2 <- makeDiv " -> " Nil
        J.append div1 typContainer
        J.append arr typContainer
        J.append div2 typContainer
        J.append arr2 typContainer
        J.append div3 typContainer
        J.append typContainer container
        br <- J.create "
"
        J.append br container
        subContainer <- makeDiv "" $ Cons "subtypes output" Nil
        jExp1 <- typetoJQuery {typ:tt1 ,idTree:it1, expr:dummyExpr}
        jExp2 <- typetoJQuery {typ:tt2 ,idTree:it2, expr:dummyExpr}
        J.append jExp1 subContainer
        J.append jExp2 subContainer
        contentSub <- J.getText subContainer
        if Data.String.length contentSub == 0 then J.setAttr "class" "" subContainer else emptyJQuery
        J.append subContainer container

topLevelTypetoJQuery t@{typ:tt, idTree: it} = do
        container <- makeDiv "" Nil
        typContainer <- makeDiv (prettyPrintType (extractType tt)) $ Cons "output" Nil
        addTypIdtoDiv (extractIndex it) typContainer
        J.append typContainer container
        br <- J.create "
"
        J.append br container
        types <- typetoJQuery t
        J.append types container

findConnections:: IndexTree -> List (Tuple String String)
findConnections (IBinary i1 it1 it2 i) = Cons (buildPairResult i) $  Cons (buildPair i1) $ Cons (buildPair (extractIndex it1)) $ Cons (buildPair (extractIndex it2)) $ findOtherConnections it1 ++ findOtherConnections it2
findConnections id = Cons (buildPair (extractIndex id)) $ findOtherConnections id

findOtherConnections:: IndexTree -> List (Tuple String String)
findOtherConnections (IListTree ls _) = concat $ map findOtherConnections ls
findOtherConnections (INTuple ls _) = concat $ map findOtherConnections ls
findOtherConnections (IBinary _ it1 it2 _) = findOtherConnections it1 ++ findOtherConnections it2
findOtherConnections (IUnary _ it _) = findOtherConnections it
findOtherConnections (ISectL it _ _ ) = findOtherConnections it
findOtherConnections (ISectR _ it _ ) = findOtherConnections it
findOtherConnections (IIfExpr it1 it2 it3 _ ) = findOtherConnections it1 ++ findOtherConnections it2 ++ findOtherConnections it3
findOtherConnections (ILetExpr _ it1 it2 _ ) = findOtherConnections it1 ++ findOtherConnections it2
findOtherConnections (ILambda _ it _) = findOtherConnections it
findOtherConnections (IApp it its i) =  Cons (buildPair (extractIndex it))  $  Cons (buildPairResult i) $ (map (\i -> buildPair $ extractIndex i) its) ++ (concat (map findOtherConnections its)) -- Cons buildPair i
findOtherConnections _ = Nil -- atom prefixOP

buildPair:: Int -> (Tuple String String)
buildPair i = Tuple ("typ" ++ show i) ("expr" ++ show i)

buildPairResult:: Int -> (Tuple String String)
buildPairResult i = Tuple ("expr" ++ show i) ("typ"++ (show i) ++ "result")

-- draws a line between two divs
-- canvas obj1 obj2 svgContainer
-- Foreign JQuery JQuery JQuery
drawLines::forall eff. Foreign -> J.JQuery -> List (Tuple String String) -> Eff (dom :: DOM | eff) Unit
drawLines canvas svgContainer lines' = do
      lines <- mapM toJQueryPair lines'
      for lines $ (\(Tuple l1 l2) -> do
              y1 <- yOffset l1
              x1 <- xOffset l1
              y2 <- yOffset l2
              x2 <- xOffset l2
              path canvas $ "M" ++ (show x1) ++ " " ++ (show y1) ++ "L" ++ (show x2) ++ " " ++ (show y2)
          )
      return unit
    where
    -- calculates x and y offset to svgContainer
    yOffset jObj = offsetTop jObj >>= (\y -> offsetTop svgContainer >>= (\x -> return (y - x)))
    xOffset jObj = offsetLeft jObj >>= (\y -> offsetLeft svgContainer >>= (\x -> return (y - x)))

-- fings matching typ expr pair
toJQueryPair::forall eff. Tuple String String -> Eff (dom :: DOM | eff) (Tuple J.JQuery J.JQuery)
toJQueryPair (Tuple id1 id2) = do
  typ <- J.select ("#" ++ id1)
  expr <- J.select ("#" ++ id2)
  return $ Tuple typ expr

idExpr:: Expr -> IndexTree
idExpr e = fst $ runState (indexExpr e) {count:0}

indexExpr:: Expr -> State {count:: Int} IndexTree
indexExpr (Atom _) = do
                  i <- fresh
                  return $ IAtom i
indexExpr (List es) = do
                  is <- mapM indexExpr es
                  i <- fresh
                  return $ IListTree is i
indexExpr (NTuple es) = do
                  is <- mapM indexExpr es
                  i <- fresh
                  return $ INTuple is i
indexExpr (Binary _ e1 e2) = do
                  i1 <- indexExpr e1
                  i2 <- indexExpr e2
                  i <- fresh
                  i' <- fresh
                  return $ (IBinary i' i1 i2 i)
indexExpr (Unary _ e) = do
                  i <- indexExpr e
                  i' <- fresh
                  i'' <- fresh
                  return $ IUnary i'' i i'
indexExpr (SectL e _) = do
                  i <- indexExpr e
                  i' <- fresh
                  i'' <- fresh
                  return $ ISectL i i'' i'
indexExpr (SectR _ e) = do
                  i <- indexExpr e
                  i' <- fresh
                  i'' <- fresh
                  return $ ISectR i'' i i'
indexExpr (PrefixOp _) = do
                  i <- fresh
                  return $ IPrefixOp i
indexExpr (IfExpr e1 e2 e3) = do
                  i1 <- indexExpr e1
                  i2 <- indexExpr e2
                  i3 <- indexExpr e3
                  i <- fresh
                  return $ IIfExpr i1 i2 i3 i
indexExpr (LetExpr b e1 e2) = do
                  ib <- indexBinding b
                  i1 <- indexExpr e1
                  i2 <- indexExpr e2
                  i <- fresh
                  return $ ILetExpr ib i1 i2 i
indexExpr (Lambda bs e) = do
                 ibs <- mapM indexBinding bs
                 i <- indexExpr e
                 i' <- fresh
                 return $ ILambda ibs i i'
indexExpr (App e es) = do
                e1 <- indexExpr e
                is <- mapM indexExpr es
                i <- fresh
                return $ IApp e1 is i

indexBinding:: Binding -> State {count :: Int} IBinding
indexBinding (Lit _) = do
                    i <- fresh
                    return $ ILit i
indexBinding (ConsLit b1 b2 ) = do
                      i1 <- indexBinding b1
                      i2 <- indexBinding b2
                      i <- fresh
                      return $ IConsLit i1 i2 i
indexBinding (ListLit bs) = do
                        is <- mapM indexBinding bs
                        i <- fresh
                        return $ IListLit is i
indexBinding (NTupleLit bs) = do
                      is <- mapM indexBinding bs
                      i <- fresh
                      return $ INTupleLit is i

fresh ::State {count:: Int} Int
fresh = do
  {count = count} <- get
  put {count:count+1}
  return count

extractIndex:: IndexTree -> Int
extractIndex (IAtom i)  =  i
extractIndex (IListTree _ i)  =  i
extractIndex (INTuple _ i)  =  i
extractIndex (IBinary _ _ _ i)  =  i
extractIndex (IUnary _ _ i)  =  i
extractIndex (ISectL _ _ i)  =  i
extractIndex (ISectR _ _ i)  =  i
extractIndex (IPrefixOp i)  =  i
extractIndex (IIfExpr _ _ _ i)  =  i
extractIndex (ILetExpr _ _ _ i)  =  i
extractIndex (ILambda _ _ i)  =  i
extractIndex (IApp _ _ i)  =  i


derive Semigroup and Monoid (#578)

derive Semigroup and Monoid (#578)

* derive Semigroup and Monoid

* Update HalogenM.purs

module Halogen.Query.HalogenM where

import Prelude

import Control.Applicative.Free (FreeAp, liftFreeAp, hoistFreeAp)
import Control.Monad.Error.Class (class MonadThrow, throwError)
import Control.Monad.Free (Free, hoistFree, liftF)
import Control.Monad.Reader.Class (class MonadAsk, ask)
import Control.Monad.Rec.Class (class MonadRec, tailRecM, Step(..))
import Control.Monad.State.Class (class MonadState)
import Control.Monad.Trans.Class (class MonadTrans)
import Control.Monad.Writer.Class (class MonadTell, tell)
import Control.Parallel.Class (class Parallel)
import Data.Bifunctor (lmap)
import Data.FoldableWithIndex (foldrWithIndex)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, over)
import Data.Symbol (class IsSymbol, SProxy)
import Data.Traversable (traverse)
import Data.Tuple (Tuple)
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (class MonadEffect, liftEffect)
import Halogen.Data.Slot (Slot)
import Halogen.Data.Slot as Slot
import Halogen.Query.ChildQuery as CQ
import Halogen.Query.EventSource as ES
import Halogen.Query.Input (RefLabel)
import Prim.Row as Row
import Web.DOM (Element)

-- | The Halogen component eval algebra.
data HalogenF state action slots output m a
  = State (state -> Tuple a state)
  | Subscribe (SubscriptionId -> ES.EventSource m action) (SubscriptionId -> a)
  | Unsubscribe SubscriptionId a
  | Lift (m a)
  | ChildQuery (CQ.ChildQueryBox slots a)
  | Raise output a
  | Par (HalogenAp state action slots output m a)
  | Fork (HalogenM state action slots output m Unit) (ForkId -> a)
  | Kill ForkId a
  | GetRef RefLabel (Maybe Element -> a)

instance functorHalogenF :: Functor m => Functor (HalogenF state action slots output m) where
  map f = case _ of
    State k -> State (lmap f <<< k)
    Subscribe fes k -> Subscribe fes (f <<< k)
    Unsubscribe sid a -> Unsubscribe sid (f a)
    Lift q -> Lift (map f q)
    ChildQuery cq -> ChildQuery (map f cq)
    Raise o a -> Raise o (f a)
    Par pa -> Par (map f pa)
    Fork hmu k -> Fork hmu (f <<< k)
    Kill fid a -> Kill fid (f a)
    GetRef p k -> GetRef p (f <<< k)

-- | The Halogen component eval effect monad.
newtype HalogenM state action slots output m a = HalogenM (Free (HalogenF state action slots output m) a)

derive newtype instance functorHalogenM :: Functor (HalogenM state action slots output m)
derive newtype instance applyHalogenM :: Apply (HalogenM state action slots output m)
derive newtype instance applicativeHalogenM :: Applicative (HalogenM state action slots output m)
derive newtype instance bindHalogenM :: Bind (HalogenM state action slots output m)
derive newtype instance monadHalogenM :: Monad (HalogenM state action slots output m)
derive newtype instance semigroupHalogenM :: Semigroup a => Semigroup (HalogenM state action slots output m a)
derive newtype instance monoidHalogenM :: Monoid a => Monoid (HalogenM state action slots output m a)

instance monadEffectHalogenM :: MonadEffect m => MonadEffect (HalogenM state action slots output m) where
  liftEffect = HalogenM <<< liftF <<< Lift <<< liftEffect

instance monadAffHalogenM :: MonadAff m => MonadAff (HalogenM state action slots output m) where
  liftAff = HalogenM <<< liftF <<< Lift <<< liftAff

instance parallelHalogenM :: Parallel (HalogenAp state action slots output m) (HalogenM state action slots output m) where
  parallel = HalogenAp <<< liftFreeAp
  sequential = HalogenM <<< liftF <<< Par

instance monadTransHalogenM :: MonadTrans (HalogenM state action slots o) where
  lift = HalogenM <<< liftF <<< Lift

instance monadRecHalogenM :: MonadRec (HalogenM state action slots output m) where
  tailRecM k a = k a >>= case _ of
    Loop x -> tailRecM k x
    Done y -> pure y

instance monadStateHalogenM :: MonadState state (HalogenM state action slots output m) where
  state = HalogenM <<< liftF <<< State

instance monadAskHalogenM :: MonadAsk r m => MonadAsk r (HalogenM state action slots output m) where
  ask = HalogenM $ liftF $ Lift ask

instance monadTellHalogenM :: MonadTell w m => MonadTell w (HalogenM state action slots output m) where
  tell = HalogenM <<< liftF <<< Lift <<< tell

instance monadThrowHalogenM :: MonadThrow e m => MonadThrow e (HalogenM state action slots output m) where
  throwError = HalogenM <<< liftF <<< Lift <<< throwError

-- | An applicative-only version of `HalogenM` to allow for parallel evaluation.
newtype HalogenAp state action slots output m a = HalogenAp (FreeAp (HalogenM state action slots output m) a)

derive instance newtypeHalogenAp :: Newtype (HalogenAp state query slots output m a) _
derive newtype instance functorHalogenAp :: Functor (HalogenAp state query slots output m)
derive newtype instance applyHalogenAp :: Apply (HalogenAp state query slots output m)
derive newtype instance applicativeHalogenAp :: Applicative (HalogenAp state query slots output m)

-- | Raises an output message for the component.
raise :: forall state action slots output m. output -> HalogenM state action slots output m Unit
raise o = HalogenM $ liftF $ Raise o unit

-- | Sends a query to a child of a component at the specified slot.
query
  :: forall state action output m label slots query output' slot a _1
   . Row.Cons label (Slot query output' slot) _1 slots
  => IsSymbol label
  => Ord slot
  => SProxy label
  -> slot
  -> query a
  -> HalogenM state action slots output m (Maybe a)
query label p q = HalogenM $ liftF $ ChildQuery $ CQ.mkChildQueryBox $
  CQ.ChildQuery (\k → maybe (pure Nothing) k <<< Slot.lookup label p) q identity

-- | Sends a query to all children of a component at a given slot label.
queryAll
  :: forall state action output m label slots query output' slot a _1
   . Row.Cons label (Slot query output' slot) _1 slots
  => IsSymbol label
  => Ord slot
  => SProxy label
  -> query a
  -> HalogenM state action slots output m (Map slot a)
queryAll label q =
  HalogenM $ liftF $ ChildQuery $ CQ.mkChildQueryBox $
    CQ.ChildQuery (\k -> map catMapMaybes <<< traverse k <<< Slot.slots label) q identity
  where
    catMapMaybes ∷ forall k v. Ord k ⇒ Map k (Maybe v) -> Map k v
    catMapMaybes = foldrWithIndex (\k v acc → maybe acc (flip (Map.insert k) acc) v) Map.empty

-- | The ID value associated with a subscription. Allows the subscription to be
-- | stopped at a later time.
newtype SubscriptionId = SubscriptionId Int

derive newtype instance eqSubscriptionId :: Eq SubscriptionId
derive newtype instance ordSubscriptionId :: Ord SubscriptionId

-- | Subscribes a component to an `EventSource`.
-- |
-- | When a component is disposed of any active subscriptions will automatically
-- | be stopped and no further subscriptions will be possible during
-- | finalization.
subscribe :: forall state action slots output m. ES.EventSource m action -> HalogenM state action slots output m SubscriptionId
subscribe es = HalogenM $ liftF $ Subscribe (\_ -> es) identity

-- | An alternative to `subscribe`, intended for subscriptions that unsubscribe
-- | themselves. Instead of returning the `SubscriptionId` from `subscribe'`, it
-- | is passed into an `EventSource` constructor. This allows emitted queries
-- | to include the `SubscriptionId`, rather than storing it in the state of the
-- | component.
-- |
-- | When a component is disposed of any active subscriptions will automatically
-- | be stopped and no further subscriptions will be possible during
-- | finalization.
subscribe' :: forall state action slots output m. (SubscriptionId -> ES.EventSource m action) -> HalogenM state action slots output m Unit
subscribe' esc = HalogenM $ liftF $ Subscribe esc (const unit)

-- | Unsubscribes a component from an `EventSource`. If the subscription
-- | associated with the ID has already ended this will have no effect.
unsubscribe :: forall state action slots output m. SubscriptionId -> HalogenM state action slots output m Unit
unsubscribe sid = HalogenM $ liftF $ Unsubscribe sid unit

-- | The ID value associated with a forked process. Allows the fork to be killed
-- | at a later time.
newtype ForkId = ForkId Int

derive newtype instance eqForkId :: Eq ForkId
derive newtype instance ordForkId :: Ord ForkId

-- | Starts a `HalogenM` process running independent from the current `eval`
-- | "thread".
-- |
-- | A commonly use case for `fork` is in component initializers where some
-- | async action is started. Normally all interaction with the component will
-- | be blocked until the initializer completes, but if the async action is
-- | `fork`ed instead, the initializer can complete synchronously while the
-- | async action continues.
-- |
-- | Some care needs to be taken when using a `fork` that can modify the
-- | component state, as it's easy for the forked process to "clobber" the state
-- | (overwrite some or all of it with an old value) by mistake.
-- |
-- | When a component is disposed of any active forks will automatically
-- | be killed. New forks can be started during finalization but there will be
-- | no means of killing them.
fork :: forall state action slots output m. HalogenM state action slots output m Unit -> HalogenM state action slots output m ForkId
fork hmu = HalogenM $ liftF $ Fork hmu identity

-- | Kills a forked process if it is still running. Attempting to kill a forked
-- | process that has already ended will have no effect.
kill :: forall state action slots output m. ForkId -> HalogenM state action slots output m Unit
kill fid = HalogenM $ liftF $ Kill fid unit

-- | Retrieves an `Element` value that is associated with a `Ref` in the
-- | rendered output of a component. If there is no currently rendered value for
-- | the requested ref this will return `Nothing`.
getRef :: forall state action slots output m. RefLabel -> HalogenM state action slots output m (Maybe Element)
getRef p = HalogenM $ liftF $ GetRef p identity

imapState
  :: forall state state' action slots output m
   . (state -> state')
  -> (state' -> state)
  -> HalogenM state action slots output m
  ~> HalogenM state' action slots output m
imapState f f' (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF state action slots output m ~> HalogenF state' action slots output m
  go = case _ of
    State fs -> State (map f <<< fs <<< f')
    Subscribe fes k -> Subscribe fes k
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (imapState f f')) p)
    Fork hmu k -> Fork (imapState f f' hmu) k
    Kill fid a -> Kill fid a
    GetRef p k -> GetRef p k

mapAction
  :: forall state action action' slots output m
   . Functor m
  => (action -> action')
  -> HalogenM state action slots output m
  ~> HalogenM state action' slots output m
mapAction f (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF state action slots output m ~> HalogenF state action' slots output m
  go = case _ of
    State fs -> State fs
    Subscribe fes k -> Subscribe (map f <<< fes) k
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapAction f)) p)
    Fork hmu k -> Fork (mapAction f hmu) k
    Kill fid a -> Kill fid a
    GetRef p k -> GetRef p k

mapOutput
  :: forall state action slots output output' m
   . (output -> output')
  -> HalogenM state action slots output m
  ~> HalogenM state action slots output' m
mapOutput f (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF state action slots output m ~> HalogenF state action slots output' m
  go = case _ of
    State fs -> State fs
    Subscribe fes k -> Subscribe fes k
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise (f o) a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapOutput f)) p)
    Fork hmu k -> Fork (mapOutput f hmu) k
    Kill fid a -> Kill fid a
    GetRef p k -> GetRef p k

hoist
  :: forall state action slots output m m'
   . Functor m'
  => (m ~> m')
  -> HalogenM state action slots output m
  ~> HalogenM state action slots output m'
hoist nat (HalogenM fa) = HalogenM (hoistFree go fa)
  where
  go :: HalogenF state action slots output m ~> HalogenF state action slots output m'
  go = case _ of
    State f -> State f
    Subscribe fes k -> Subscribe (ES.hoist nat <<< fes) k
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift (nat q)
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (hoist nat)) p)
    Fork hmu k -> Fork (hoist nat hmu) k
    Kill fid a -> Kill fid a
    GetRef p k -> GetRef p k

module Halogen.Query.HalogenM where

import Prelude

import Control.Applicative.Free (FreeAp, liftFreeAp, hoistFreeAp)
import Control.Monad.Error.Class (class MonadThrow, throwError)
import Control.Monad.Free (Free, hoistFree, liftF)
import Control.Monad.Reader.Class (class MonadAsk, ask)
import Control.Monad.Rec.Class (class MonadRec, tailRecM, Step(..))
import Control.Monad.State.Class (class MonadState)
import Control.Monad.Trans.Class (class MonadTrans)
import Control.Monad.Writer.Class (class MonadTell, tell)
import Control.Parallel.Class (class Parallel)
import Data.Bifunctor (lmap)
import Data.FoldableWithIndex (foldrWithIndex)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, over)
import Data.Symbol (class IsSymbol, SProxy)
import Data.Traversable (traverse)
import Data.Tuple (Tuple)
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (class MonadEffect, liftEffect)
import Halogen.Data.Slot (Slot)
import Halogen.Data.Slot as Slot
import Halogen.Query.ChildQuery as CQ
import Halogen.Query.EventSource as ES
import Halogen.Query.Input (RefLabel)
import Prim.Row as Row
import Web.DOM (Element)

-- | The Halogen component eval algebra.
data HalogenF state action slots output m a
  = State (state -> Tuple a state)
  | Subscribe (SubscriptionId -> ES.EventSource m action) (SubscriptionId -> a)
  | Unsubscribe SubscriptionId a
  | Lift (m a)
  | ChildQuery (CQ.ChildQueryBox slots a)
  | Raise output a
  | Par (HalogenAp state action slots output m a)
  | Fork (HalogenM state action slots output m Unit) (ForkId -> a)
  | Kill ForkId a
  | GetRef RefLabel (Maybe Element -> a)

instance functorHalogenF :: Functor m => Functor (HalogenF state action slots output m) where
  map f = case _ of
    State k -> State (lmap f <<< k)
    Subscribe fes k -> Subscribe fes (f <<< k)
    Unsubscribe sid a -> Unsubscribe sid (f a)
    Lift q -> Lift (map f q)
    ChildQuery cq -> ChildQuery (map f cq)
    Raise o a -> Raise o (f a)
    Par pa -> Par (map f pa)
    Fork hmu k -> Fork hmu (f <<< k)
    Kill fid a -> Kill fid (f a)
    GetRef p k -> GetRef p (f <<< k)

-- | The Halogen component eval effect monad.
newtype HalogenM state action slots output m a = HalogenM (Free (HalogenF state action slots output m) a)

derive newtype instance functorHalogenM :: Functor (HalogenM state action slots output m)
derive newtype instance applyHalogenM :: Apply (HalogenM state action slots output m)
derive newtype instance applicativeHalogenM :: Applicative (HalogenM state action slots output m)
derive newtype instance bindHalogenM :: Bind (HalogenM state action slots output m)
derive newtype instance monadHalogenM :: Monad (HalogenM state action slots output m)

instance monadEffectHalogenM :: MonadEffect m => MonadEffect (HalogenM state action slots output m) where
  liftEffect = HalogenM <<< liftF <<< Lift <<< liftEffect

instance monadAffHalogenM :: MonadAff m => MonadAff (HalogenM state action slots output m) where
  liftAff = HalogenM <<< liftF <<< Lift <<< liftAff

instance parallelHalogenM :: Parallel (HalogenAp state action slots output m) (HalogenM state action slots output m) where
  parallel = HalogenAp <<< liftFreeAp
  sequential = HalogenM <<< liftF <<< Par

instance monadTransHalogenM :: MonadTrans (HalogenM state action slots o) where
  lift = HalogenM <<< liftF <<< Lift

instance monadRecHalogenM :: MonadRec (HalogenM state action slots output m) where
  tailRecM k a = k a >>= case _ of
    Loop x -> tailRecM k x
    Done y -> pure y

instance monadStateHalogenM :: MonadState state (HalogenM state action slots output m) where
  state = HalogenM <<< liftF <<< State

instance monadAskHalogenM :: MonadAsk r m => MonadAsk r (HalogenM state action slots output m) where
  ask = HalogenM $ liftF $ Lift ask

instance monadTellHalogenM :: MonadTell w m => MonadTell w (HalogenM state action slots output m) where
  tell = HalogenM <<< liftF <<< Lift <<< tell

instance monadThrowHalogenM :: MonadThrow e m => MonadThrow e (HalogenM state action slots output m) where
  throwError = HalogenM <<< liftF <<< Lift <<< throwError

-- | An applicative-only version of `HalogenM` to allow for parallel evaluation.
newtype HalogenAp state action slots output m a = HalogenAp (FreeAp (HalogenM state action slots output m) a)

derive instance newtypeHalogenAp :: Newtype (HalogenAp state query slots output m a) _
derive newtype instance functorHalogenAp :: Functor (HalogenAp state query slots output m)
derive newtype instance applyHalogenAp :: Apply (HalogenAp state query slots output m)
derive newtype instance applicativeHalogenAp :: Applicative (HalogenAp state query slots output m)

-- | Raises an output message for the component.
raise :: forall state action slots output m. output -> HalogenM state action slots output m Unit
raise o = HalogenM $ liftF $ Raise o unit

-- | Sends a query to a child of a component at the specified slot.
query
  :: forall state action output m label slots query output' slot a _1
   . Row.Cons label (Slot query output' slot) _1 slots
  => IsSymbol label
  => Ord slot
  => SProxy label
  -> slot
  -> query a
  -> HalogenM state action slots output m (Maybe a)
query label p q = HalogenM $ liftF $ ChildQuery $ CQ.mkChildQueryBox $
  CQ.ChildQuery (\k → maybe (pure Nothing) k <<< Slot.lookup label p) q identity

-- | Sends a query to all children of a component at a given slot label.
queryAll
  :: forall state action output m label slots query output' slot a _1
   . Row.Cons label (Slot query output' slot) _1 slots
  => IsSymbol label
  => Ord slot
  => SProxy label
  -> query a
  -> HalogenM state action slots output m (Map slot a)
queryAll label q =
  HalogenM $ liftF $ ChildQuery $ CQ.mkChildQueryBox $
    CQ.ChildQuery (\k -> map catMapMaybes <<< traverse k <<< Slot.slots label) q identity
  where
    catMapMaybes ∷ forall k v. Ord k ⇒ Map k (Maybe v) -> Map k v
    catMapMaybes = foldrWithIndex (\k v acc → maybe acc (flip (Map.insert k) acc) v) Map.empty

-- | The ID value associated with a subscription. Allows the subscription to be
-- | stopped at a later time.
newtype SubscriptionId = SubscriptionId Int

derive newtype instance eqSubscriptionId :: Eq SubscriptionId
derive newtype instance ordSubscriptionId :: Ord SubscriptionId

-- | Subscribes a component to an `EventSource`.
-- |
-- | When a component is disposed of any active subscriptions will automatically
-- | be stopped and no further subscriptions will be possible during
-- | finalization.
subscribe :: forall state action slots output m. ES.EventSource m action -> HalogenM state action slots output m SubscriptionId
subscribe es = HalogenM $ liftF $ Subscribe (\_ -> es) identity

-- | An alternative to `subscribe`, intended for subscriptions that unsubscribe
-- | themselves. Instead of returning the `SubscriptionId` from `subscribe'`, it
-- | is passed into an `EventSource` constructor. This allows emitted queries
-- | to include the `SubscriptionId`, rather than storing it in the state of the
-- | component.
-- |
-- | When a component is disposed of any active subscriptions will automatically
-- | be stopped and no further subscriptions will be possible during
-- | finalization.
subscribe' :: forall state action slots output m. (SubscriptionId -> ES.EventSource m action) -> HalogenM state action slots output m Unit
subscribe' esc = HalogenM $ liftF $ Subscribe esc (const unit)

-- | Unsubscribes a component from an `EventSource`. If the subscription
-- | associated with the ID has already ended this will have no effect.
unsubscribe :: forall state action slots output m. SubscriptionId -> HalogenM state action slots output m Unit
unsubscribe sid = HalogenM $ liftF $ Unsubscribe sid unit

-- | The ID value associated with a forked process. Allows the fork to be killed
-- | at a later time.
newtype ForkId = ForkId Int

derive newtype instance eqForkId :: Eq ForkId
derive newtype instance ordForkId :: Ord ForkId

-- | Starts a `HalogenM` process running independent from the current `eval`
-- | "thread".
-- |
-- | A commonly use case for `fork` is in component initializers where some
-- | async action is started. Normally all interaction with the component will
-- | be blocked until the initializer completes, but if the async action is
-- | `fork`ed instead, the initializer can complete synchronously while the
-- | async action continues.
-- |
-- | Some care needs to be taken when using a `fork` that can modify the
-- | component state, as it's easy for the forked process to "clobber" the state
-- | (overwrite some or all of it with an old value) by mistake.
-- |
-- | When a component is disposed of any active forks will automatically
-- | be killed. New forks can be started during finalization but there will be
-- | no means of killing them.
fork :: forall state action slots output m. HalogenM state action slots output m Unit -> HalogenM state action slots output m ForkId
fork hmu = HalogenM $ liftF $ Fork hmu identity

-- | Kills a forked process if it is still running. Attempting to kill a forked
-- | process that has already ended will have no effect.
kill :: forall state action slots output m. ForkId -> HalogenM state action slots output m Unit
kill fid = HalogenM $ liftF $ Kill fid unit

-- | Retrieves an `Element` value that is associated with a `Ref` in the
-- | rendered output of a component. If there is no currently rendered value for
-- | the requested ref this will return `Nothing`.
getRef :: forall state action slots output m. RefLabel -> HalogenM state action slots output m (Maybe Element)
getRef p = HalogenM $ liftF $ GetRef p identity

imapState
  :: forall state state' action slots output m
   . (state -> state')
  -> (state' -> state)
  -> HalogenM state action slots output m
  ~> HalogenM state' action slots output m
imapState f f' (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF state action slots output m ~> HalogenF state' action slots output m
  go = case _ of
    State fs -> State (map f <<< fs <<< f')
    Subscribe fes k -> Subscribe fes k
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (imapState f f')) p)
    Fork hmu k -> Fork (imapState f f' hmu) k
    Kill fid a -> Kill fid a
    GetRef p k -> GetRef p k

mapAction
  :: forall state action action' slots output m
   . Functor m
  => (action -> action')
  -> HalogenM state action slots output m
  ~> HalogenM state action' slots output m
mapAction f (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF state action slots output m ~> HalogenF state action' slots output m
  go = case _ of
    State fs -> State fs
    Subscribe fes k -> Subscribe (map f <<< fes) k
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapAction f)) p)
    Fork hmu k -> Fork (mapAction f hmu) k
    Kill fid a -> Kill fid a
    GetRef p k -> GetRef p k

mapOutput
  :: forall state action slots output output' m
   . (output -> output')
  -> HalogenM state action slots output m
  ~> HalogenM state action slots output' m
mapOutput f (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF state action slots output m ~> HalogenF state action slots output' m
  go = case _ of
    State fs -> State fs
    Subscribe fes k -> Subscribe fes k
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise (f o) a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapOutput f)) p)
    Fork hmu k -> Fork (mapOutput f hmu) k
    Kill fid a -> Kill fid a
    GetRef p k -> GetRef p k

hoist
  :: forall state action slots output m m'
   . Functor m'
  => (m ~> m')
  -> HalogenM state action slots output m
  ~> HalogenM state action slots output m'
hoist nat (HalogenM fa) = HalogenM (hoistFree go fa)
  where
  go :: HalogenF state action slots output m ~> HalogenF state action slots output m'
  go = case _ of
    State f -> State f
    Subscribe fes k -> Subscribe (ES.hoist nat <<< fes) k
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift (nat q)
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (hoist nat)) p)
    Fork hmu k -> Fork (hoist nat hmu) k
    Kill fid a -> Kill fid a
    GetRef p k -> GetRef p k