All weapon and armor materials, prefixes and types balanced

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:  0, attackSpeed:  -50, attackBonus: 0 }
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:  3, attackSpeed: -100, attackBonus: 1 }
materialStatWeapon _ = mempty

materialStatArmor :: Material -> ArmorStat
materialStatArmor Leather    = ArmorStat { defence: 1, weight: 10 }
materialStatArmor Copper     = ArmorStat { defence: 2, weight: 25 }
materialStatArmor Iron       = ArmorStat { defence: 3, weight: 40 }
materialStatArmor Steel      = ArmorStat { defence: 4, weight: 40 }
materialStatArmor Titanium   = ArmorStat { defence: 5, weight: 45 }
materialStatArmor Adamantine = ArmorStat { defence: 7, weight: 35 }
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: -2, attackSpeed:   50, attackBonus: -4 }
prefixStatWeapon Rusty      = WeaponStat { damage: -2, weight:  0, 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:  0 }
prefixStatWeapon Lethal     = WeaponStat { damage:  2, weight:  0, attackSpeed:    0, attackBonus:  1 }
prefixStatWeapon Masterwork = WeaponStat { damage:  3, weight: -1, attackSpeed:  -50, attackBonus:  2 }
prefixStatWeapon Godly      = WeaponStat { damage:  4, weight:  0, attackSpeed: -200, attackBonus:  4 }
prefixStatWeapon Light      = WeaponStat { damage:  0, weight: -2, attackSpeed: -150, attackBonus:  1 }
prefixStatWeapon Balanced   = WeaponStat { damage:  1, weight:  0, attackSpeed:  -50, attackBonus:  3 }
prefixStatWeapon Heavy      = WeaponStat { damage:  2, weight:  3, attackSpeed:  150, attackBonus: -1 }
prefixStatWeapon _          = mempty

prefixStatArmor :: ArmorPrefix -> ArmorStat
prefixStatArmor BrokenA     = ArmorStat { defence: -1, weight:  -5 }
prefixStatArmor RustyA      = ArmorStat { defence:  0, weight:   0 }
prefixStatArmor MasterworkA = ArmorStat { defence:  1, weight:  -5 }
prefixStatArmor GodlyA      = ArmorStat { defence:  4, weight:   0 }
prefixStatArmor LightA      = ArmorStat { defence: -1, weight:  -5 }
prefixStatArmor HeavyA      = ArmorStat { defence:  1, 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: 4, weight:  6, attackSpeed:  800, attackBonus: 2 }
weaponTypeStat Axe       = WeaponStat { damage: 5, weight:  7, attackSpeed: 1200, attackBonus: 0 }
weaponTypeStat Dagger    = WeaponStat { damage: 2, weight:  3, attackSpeed:  600, attackBonus: 3 }
weaponTypeStat Spear     = WeaponStat { damage: 4, weight:  6, attackSpeed:  900, attackBonus: 2 }
weaponTypeStat Mace      = WeaponStat { damage: 5, weight:  8, attackSpeed: 1000, attackBonus: 1 }
weaponTypeStat BattleAxe = WeaponStat { damage: 9, weight: 12, attackSpeed: 1800, attackBonus:-1 }

--------- 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 | 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


Fix: empty lists displayed as strings

Fix: empty lists displayed as strings

module Web
  ( exprToJQuery
  , getPath
  ) where

import Prelude
import Data.Foldable (all)
import Data.Traversable (for)
import Data.List
import Data.String (joinWith)
import Data.Foreign (unsafeFromForeign)
import Data.Maybe (Maybe(..))

import Control.Apply ((*>))
import Control.Bind ((=<<), (>=>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.JQuery as J
import DOM (DOM)

import AST
import Evaluator (Path(..))

pathPropName :: String
pathPropName = "clickyEvaluation_path"

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

exprToJQuery :: forall eff. Expr -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery expr = go id expr
  where
  go :: (Path -> Path) -> Expr -> Eff (dom :: DOM | eff) J.JQuery
  go p e = J.setProp pathPropName (p End) =<< case e of
    Atom a -> atom a
    Binary op e1 e2 -> do
      j1 <- go (p <<< Fst) e1
      j2 <- go (p <<< Snd) e2
      binary op j1 j2
    List es -> case toStr es of
      Just str -> string str
      Nothing  -> do
        js <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length es - 1)) es
        list js
    NTuple es -> do
      js <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length es - 1)) es
      tuple js
    SectL e op -> do
      j <- go (p <<< Fst) e
      jop <- makeDiv (pPrintOp op) (singleton "op")
      section j jop
    SectR op e -> do
      jop <- makeDiv (pPrintOp op) (singleton "op")
      j <- go (p <<< Snd) e
      section jop j
    PrefixOp op -> makeDiv ("(" ++ pPrintOp op ++ ")") (toList ["prefix", "op"])
    IfExpr cond thenExpr elseExpr -> do
      jc <- go (p <<< Fst) cond
      jt <- go (p <<< Snd) thenExpr
      je <- go (p <<< Thrd) elseExpr
      ifexpr jc jt je
    Lambda binds body -> do
      jBinds <- for binds binding
      jBody <- go (p <<< Fst) body
      lambda jBinds jBody
    App func args -> do
      jFunc <- go (p <<< Fst) func
      jArgs <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length args - 1)) args
      app jFunc jArgs

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

binding :: forall eff. Binding -> Eff (dom :: DOM | eff) J.JQuery
binding b = case b of
  Lit a        -> atom a
  ConsLit b bs -> do
    jCons <- makeDiv "" Nil
    makeDiv "(" (singleton "brace") >>= flip J.append jCons
    binding b             >>= flip J.append jCons
    makeDiv ":" (singleton "colon") >>= flip J.append jCons
    binding bs            >>= flip J.append jCons
    makeDiv ")" (singleton "brace") >>= flip J.append jCons
  ListLit bs -> do
    jList <- makeDiv "" Nil
    makeDiv "[" (singleton "brace") >>= flip J.append jList
    for bs $ \b -> do
      binding b >>= flip J.append jList
      makeDiv "," (singleton "comma") >>= flip J.append jList
    makeDiv "]" (singleton "brace") >>= flip J.append jList
  NTupleLit bs -> do
    jTuple <- makeDiv "" Nil
    makeDiv "(" (singleton "brace") >>= flip J.append jTuple
    interleaveM_ (binding >=> flip J.append jTuple) (makeDiv "," (singleton "comma") >>= flip J.append jTuple) bs
    makeDiv ")" (singleton "brace") >>= flip J.append jTuple
    return jTuple

lambda :: forall eff. List J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
lambda jBinds jBody = do
  jLam <- makeDiv "" (singleton "lambda")
  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 -> J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
binary op j1 j2 = do
  dBin <- makeDiv "" (singleton "binary")
  J.append j1 dBin
  dOp <- makeDiv (pPrintOp op) (singleton "op")
  J.append dOp dBin
  J.append j2 dBin
  return dBin

section :: forall eff. J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
section j1 j2 = do
  jSect <- makeDiv "" (singleton "section")
  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 -> Eff (dom :: DOM | eff) J.JQuery
ifexpr cond thenExpr elseExpr = do
  dIf <- makeDiv "" (singleton "if")
  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 -> Eff (dom :: DOM | eff) J.JQuery
tuple js = do
  dtuple <- makeDiv "" (singleton "tuple")
  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 -> Eff (dom :: DOM | eff) J.JQuery
list js = do
  dls <- makeDiv "" (singleton "list")
  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. String -> Eff (dom :: DOM | eff) J.JQuery
string str = makeDiv ("\"" ++ str ++ "\"") (toList ["list", "string"])

toStr :: List Expr -> Maybe String
toStr Nil = Nothing
toStr ls  = (joinWith "" <<< fromList) <$> for ls extract
  where
   extract:: Expr -> Maybe String
   extract (Atom (Char s)) = Just s
   extract _               = Nothing

app :: forall eff. J.JQuery -> List J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
app jFunc jArgs = do
  dApp <- makeDiv "" (singleton "app")
  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

module Web
  ( exprToJQuery
  , getPath
  ) where

import Prelude
import Data.Foldable (all)
import Data.Traversable (for)
import Data.List
import Data.String (joinWith)
import Data.Foreign (unsafeFromForeign)
import Data.Maybe (Maybe(..))

import Control.Apply ((*>))
import Control.Bind ((=<<), (>=>))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.JQuery as J
import DOM (DOM)

import AST
import Evaluator (Path(..))

pathPropName :: String
pathPropName = "clickyEvaluation_path"

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

exprToJQuery :: forall eff. Expr -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery expr = go id expr
  where
  go :: (Path -> Path) -> Expr -> Eff (dom :: DOM | eff) J.JQuery
  go p e = J.setProp pathPropName (p End) =<< case e of
    Atom a -> atom a
    Binary op e1 e2 -> do
      j1 <- go (p <<< Fst) e1
      j2 <- go (p <<< Snd) e2
      binary op j1 j2
    List es -> case toStr es of
      Just str -> string str
      Nothing  -> do
        js <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length es - 1)) es
        list js
    NTuple es -> do
      js <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length es - 1)) es
      tuple js
    SectL e op -> do
      j <- go (p <<< Fst) e
      jop <- makeDiv (pPrintOp op) (singleton "op")
      section j jop
    SectR op e -> do
      jop <- makeDiv (pPrintOp op) (singleton "op")
      j <- go (p <<< Snd) e
      section jop j
    PrefixOp op -> makeDiv ("(" ++ pPrintOp op ++ ")") (toList ["prefix", "op"])
    IfExpr cond thenExpr elseExpr -> do
      jc <- go (p <<< Fst) cond
      jt <- go (p <<< Snd) thenExpr
      je <- go (p <<< Thrd) elseExpr
      ifexpr jc jt je
    Lambda binds body -> do
      jBinds <- for binds binding
      jBody <- go (p <<< Fst) body
      lambda jBinds jBody
    App func args -> do
      jFunc <- go (p <<< Fst) func
      jArgs <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length args - 1)) args
      app jFunc jArgs

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

binding :: forall eff. Binding -> Eff (dom :: DOM | eff) J.JQuery
binding b = case b of
  Lit a        -> atom a
  ConsLit b bs -> do
    jCons <- makeDiv "" Nil
    makeDiv "(" (singleton "brace") >>= flip J.append jCons
    binding b             >>= flip J.append jCons
    makeDiv ":" (singleton "colon") >>= flip J.append jCons
    binding bs            >>= flip J.append jCons
    makeDiv ")" (singleton "brace") >>= flip J.append jCons
  ListLit bs -> do
    jList <- makeDiv "" Nil
    makeDiv "[" (singleton "brace") >>= flip J.append jList
    for bs $ \b -> do
      binding b >>= flip J.append jList
      makeDiv "," (singleton "comma") >>= flip J.append jList
    makeDiv "]" (singleton "brace") >>= flip J.append jList
  NTupleLit bs -> do
    jTuple <- makeDiv "" Nil
    makeDiv "(" (singleton "brace") >>= flip J.append jTuple
    interleaveM_ (binding >=> flip J.append jTuple) (makeDiv "," (singleton "comma") >>= flip J.append jTuple) bs
    makeDiv ")" (singleton "brace") >>= flip J.append jTuple
    return jTuple

lambda :: forall eff. List J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
lambda jBinds jBody = do
  jLam <- makeDiv "" (singleton "lambda")
  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 -> J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
binary op j1 j2 = do
  dBin <- makeDiv "" (singleton "binary")
  J.append j1 dBin
  dOp <- makeDiv (pPrintOp op) (singleton "op")
  J.append dOp dBin
  J.append j2 dBin
  return dBin

section :: forall eff. J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
section j1 j2 = do
  jSect <- makeDiv "" (singleton "section")
  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 -> Eff (dom :: DOM | eff) J.JQuery
ifexpr cond thenExpr elseExpr = do
  dIf <- makeDiv "" (singleton "if")
  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 -> Eff (dom :: DOM | eff) J.JQuery
tuple js = do
  dtuple <- makeDiv "" (singleton "tuple")
  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 -> Eff (dom :: DOM | eff) J.JQuery
list js = do
  dls <- makeDiv "" (singleton "list")
  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. String -> Eff (dom :: DOM | eff) J.JQuery
string str = makeDiv ("\"" ++ str ++ "\"") (toList ["list", "string"])

toStr :: List Expr -> Maybe String
toStr ls = (joinWith "" <<< fromList) <$> for ls extract
  where
   extract:: Expr -> Maybe String
   extract (Atom (Char s)) = Just s
   extract _               = Nothing

app :: forall eff. J.JQuery -> List J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
app jFunc jArgs = do
  dApp <- makeDiv "" (singleton "app")
  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


switch to https

switch to https

module Main where

import Api
import Control.Monad.Eff
import Debug.Trace
import React
import React.DOM
import Data.Maybe
import Control.Monad.Cont.Trans(runContT)
import Control.Apply((<*))
import Control.Bind
import Data.Traversable
import Data.Tuple
import Data.Array(head)
import Data.JSON(decode, FromJSON)
import qualified Data.Map as M

theList :: [React.UI] -> {} -> React.UI
theList trs = mkUI spec do
  return $ table [
      className "list"
    ] trs

theForm :: [ColumnDetails] -> {} -> React.UI
theForm columns = mkUI spec {
    getInitialState = return {}
  } do
    state <- readState
    pure $ div [ className "formbox" ] [ commentForm { columns: columns} ]

commentForm = mkUI spec do
  props <- getProps
  return $ form [
      className "dbform",
      onSubmit create
    ] ((input [typeProp "Submit"] []) : (getComponent <$> props.columns))

makeInput :: String -> React.UI
makeInput x = input [typeProp "text", placeholder x, name x, ref x] []

makeText :: String -> React.UI
makeText x = textarea [placeholder x, name x, ref x] []

getComponent :: ColumnDetails -> React.UI
getComponent (ColumnDetails cd) = getCorrectComponent cd.name
  where
    getCorrectComponent = case cd.kind of
      "character varying" -> makeInput
      "text" -> makeText
      _ -> makeInput

foreign import preventDefault
  "function preventDefault(e) {\
  \  e.preventDefault(); \
  \  return function(){ return e; } \
  \}" :: Event -> forall eff. Eff eff Event

--this should be done in ps
foreign import refsToObj
  "function refsToObj(xs) { \
  \ return function() { \
  \   return JSON.stringify(Object.keys(xs).reduce(function(acc, x){ acc[x] = xs[x].state.value; return acc;}, {})); \
  \  }\
  \}" ::forall eff. {} -> Eff eff {}

create e = do
  _ <- preventDefault e
  rs <- getRefs
  t <- refsToObj rs
  runContT (save "https://localhost:3000/speakers" t) (\y-> return unit)

createForm :: Maybe Schema -> React.UI
createForm = maybe (div' [text "no go"]) renderComponents
  where
    renderComponents (Schema x) = theForm x.columns {}

renderListHead:: Row -> React.UI
renderListHead (Row x) = tr' ((th' <<< pure <<< text) <$> M.keys x)

renderListItem :: Row -> React.UI
renderListItem (Row x) = tr' ((td' <<< pure <<< text) <$> M.values x)

createTable :: [Row] -> React.UI
createTable xs = theList ((getTheTopRow xs) : (renderComponents xs)) $ {}
  where
    getTheTopRow (x:xs) = renderListHead x
    renderComponents xs = renderListItem <$> xs

createList :: Maybe [Row] -> React.UI
createList = maybe (div' [text "no go"]) createTable

main = do
  let listWidget = (createList <<< decode) <$> (findAll "https://localhost:3000/speakers")
  runContT listWidget $ \widget -> return unit <* (renderToElementById "list" widget)

  let formWidget = (createForm <<< decode) <$> (getSchema "https://localhost:3000/speakers")
  runContT formWidget $ \y -> return unit <* (renderToElementById "create" y)

module Main where

import Api
import Control.Monad.Eff
import Debug.Trace
import React
import React.DOM
import Data.Maybe
import Control.Monad.Cont.Trans(runContT)
import Control.Apply((<*))
import Control.Bind
import Data.Traversable
import Data.Tuple
import Data.Array(head)
import Data.JSON(decode, FromJSON)
import qualified Data.Map as M

theList :: [React.UI] -> {} -> React.UI
theList trs = mkUI spec do
  return $ table [
      className "list"
    ] trs

theForm :: [ColumnDetails] -> {} -> React.UI
theForm columns = mkUI spec {
    getInitialState = return {}
  } do
    state <- readState
    pure $ div [ className "formbox" ] [ commentForm { columns: columns} ]

commentForm = mkUI spec do
  props <- getProps
  return $ form [
      className "dbform",
      onSubmit create
    ] ((input [typeProp "Submit"] []) : (getComponent <$> props.columns))

makeInput :: String -> React.UI
makeInput x = input [typeProp "text", placeholder x, name x, ref x] []

makeText :: String -> React.UI
makeText x = textarea [placeholder x, name x, ref x] []

getComponent :: ColumnDetails -> React.UI
getComponent (ColumnDetails cd) = getCorrectComponent cd.name
  where
    getCorrectComponent = case cd.kind of
      "character varying" -> makeInput
      "text" -> makeText
      _ -> makeInput

foreign import preventDefault
  "function preventDefault(e) {\
  \  e.preventDefault(); \
  \  return function(){ return e; } \
  \}" :: Event -> forall eff. Eff eff Event

--this should be done in ps
foreign import refsToObj
  "function refsToObj(xs) { \
  \ return function() { \
  \   return JSON.stringify(Object.keys(xs).reduce(function(acc, x){ acc[x] = xs[x].state.value; return acc;}, {})); \
  \  }\
  \}" ::forall eff. {} -> Eff eff {}

create e = do
  _ <- preventDefault e
  rs <- getRefs
  t <- refsToObj rs
  runContT (save "http://localhost:3000/speakers" t) (\y-> return unit)

createForm :: Maybe Schema -> React.UI
createForm = maybe (div' [text "no go"]) renderComponents
  where
    renderComponents (Schema x) = theForm x.columns {}

renderListHead:: Row -> React.UI
renderListHead (Row x) = tr' ((th' <<< pure <<< text) <$> M.keys x)

renderListItem :: Row -> React.UI
renderListItem (Row x) = tr' ((td' <<< pure <<< text) <$> M.values x)

createTable :: [Row] -> React.UI
createTable xs = theList ((getTheTopRow xs) : (renderComponents xs)) $ {}
  where
    getTheTopRow (x:xs) = renderListHead x
    renderComponents xs = renderListItem <$> xs

createList :: Maybe [Row] -> React.UI
createList = maybe (div' [text "no go"]) createTable

main = do
  let listWidget = (createList <<< decode) <$> (findAll "http://localhost:3000/speakers")
  runContT listWidget $ \widget -> return unit <* (renderToElementById "list" widget)

  let formWidget = (createForm <<< decode) <$> (getSchema "http://localhost:3000/speakers")
  runContT formWidget $ \y -> return unit <* (renderToElementById "create" y)


Make Pending card compile

Make Pending card compile

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Pending.Component
  ( pendingCardComponent
  , module SlamData.Workspace.Card.Pending.Component.Query
  , module SlamData.Workspace.Card.Pending.Component.State
  ) where

import SlamData.Prelude

import SlamData.Monad (Slam)
import SlamData.Workspace.Card.Pending.Component.Query (Query, initiality)
import SlamData.Workspace.Card.Pending.Component.State (State, initialState)

import Halogen as H
import Halogen.HTML as HH

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

pendingCardComponent ∷ H.Component HH.HTML Query Unit Void Slam
pendingCardComponent =
  H.component
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }

render ∷ State → HTML
render st =
  HH.div_
    [ HH.i_ []
    , HH.span_ [ HH.text st.message ]
    ]

eval ∷ Query ~> DSL
eval = initiality

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Pending.Component
  ( pendingCardComponent
  , module SlamData.Workspace.Card.Pending.Component.Query
  , module SlamData.Workspace.Card.Pending.Component.State
  ) where

import SlamData.Prelude

import SlamData.Monad (Slam)
import SlamData.Workspace.Card.Pending.Component.Query (Query, initiality)
import SlamData.Workspace.Card.Pending.Component.State (State, initialState)

import Halogen as H
import Halogen.HTML as HH

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

pendingCardComponent ∷ H.Component State Query Slam
pendingCardComponent = H.component { render, eval }

render ∷ State → HTML
render st =
  HH.div_
    [ HH.i_ []
    , HH.span_ [ HH.text st.message ]
    ]

eval ∷ Query ~> DSL
eval = initiality


Relax timestamp default value parsing slightly

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.FormBuilder.Item.Model
  ( Model
  , _name
  , _fieldType
  , _defaultValue
  , initialModel
  , genModel
  , encode
  , decode
  , EqModel(..)
  , runEqModel
  , defaultValueToVarMapValue
  , module SlamData.Workspace.FormBuilder.Item.FieldType
  ) where

import SlamData.Prelude

import Data.Argonaut ((~>), (:=), (.?))
import Data.Argonaut as J
import Data.DateTime as DT
import Data.Json.Extended as EJSON
import Data.Json.Extended.Signature.Parse as EJP
import Data.Lens (Lens', lens)
import Data.String as Str

import SlamData.Workspace.Card.Port.VarMap as Port
import SlamData.Workspace.FormBuilder.Item.FieldType (FieldType(..), _FieldTypeDisplayName, allFieldTypes, fieldTypeToInputType)

import Text.Parsing.Parser (runParser) as P
import Text.Parsing.Parser.Combinators (try) as P

import Test.StrongCheck.Arbitrary as SC
import Test.StrongCheck.Gen as Gen

type Model =
  { name ∷ String
  , fieldType ∷ FieldType
  , defaultValue ∷ Maybe String
  }

genModel ∷ Gen.Gen Model
genModel = do
  name ← SC.arbitrary
  fieldType ← SC.arbitrary
  defaultValue ← SC.arbitrary
  pure { name, fieldType, defaultValue }

_name ∷ Lens' Model String
_name = lens _.name _ { name = _ }

_fieldType ∷ Lens' Model FieldType
_fieldType = lens _.fieldType _ { fieldType = _ }

_defaultValue ∷ Lens' Model (Maybe String)
_defaultValue = lens _.defaultValue _ { defaultValue = _ }

newtype EqModel = EqModel Model

runEqModel
  ∷ EqModel
  → Model
runEqModel (EqModel m) =
  m

derive instance eqEqModel ∷ Eq EqModel

initialModel ∷ Model
initialModel =
  { name : ""
  , fieldType : StringFieldType
  , defaultValue : Nothing
  }

encode
  ∷ Model
  → J.Json
encode st =
  "name" := st.name
  ~> "fieldType" := st.fieldType
  ~> "defaultValue" := st.defaultValue
  ~> J.jsonEmptyObject

decode
  ∷ J.Json
  → Either String Model
decode =
  J.decodeJson >=> \obj → do
    name ← obj .? "name"
    fieldType ← obj .? "fieldType"
    let fixValue = if fieldType == DateFieldType then fixupDate else id
    defaultValue ← map fixValue <$> obj .? "defaultValue"
    pure { name, fieldType, defaultValue }

defaultValueToVarMapValue
  ∷ FieldType
  → String
  → Maybe Port.VarMapValue
defaultValueToVarMapValue ty str =
  case ty of
    StringFieldType → Just $ Port.Literal $ EJSON.string str
    DateTimeFieldType → Port.Literal <$> parseTimestamp str
    DateFieldType → Port.Literal <$> parseDate str
    TimeFieldType → Port.Literal <$> parseTime str
    IntervalFieldType → Just $ Port.Literal $ EJSON.interval str
    ObjectIdFieldType → Just $ Port.Literal $ EJSON.objectId str
    SqlExprFieldType → Just $ Port.QueryExpr $ str
    SqlIdentifierFieldType → Just $ Port.QueryExpr $ "`" ⊕ str ⊕ "`"
    _ | str == "" → Nothing
    _ →
      P.runParser str EJSON.parseEJson
        # either (\_ → Nothing) (Port.Literal >>> Just)

parseTimestamp ∷ String → Maybe EJSON.EJson
parseTimestamp str =
  case P.runParser (tweak str) EJP.parseTimestamp of
    Left _ → Nothing
    Right dt → Just $ EJSON.timestamp dt
  where
  tweak ∷ String → String
  tweak s
    | Str.length s == 19 = s <> "Z"
    | Str.charAt 10 s == Just ' ' = tweak (Str.take 10 s <> "T" <> Str.drop 11 s)
    | otherwise = s

parseTime ∷ String → Maybe EJSON.EJson
parseTime str =
  either (const Nothing) (Just ∘ EJSON.time) $
    P.runParser str (P.try fromTimestamp <|> EJP.parseTime)
  where
  fromTimestamp = DT.time <$> EJP.parseTimestamp

parseDate ∷ String → Maybe EJSON.EJson
parseDate str =
  either (const Nothing) (Just ∘ EJSON.date) $
    P.runParser str (P.try fromTimestamp <|> EJP.parseDate)
  where
  fromTimestamp = DT.date <$> EJP.parseTimestamp

-- Truncate value to only include YYYY-MM-DD part, in case of Quasar mongo
-- connector issue that cannot represent dates distinct from datetimes.
fixupDate :: String -> String
fixupDate = Str.take 10

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.FormBuilder.Item.Model
  ( Model
  , _name
  , _fieldType
  , _defaultValue
  , initialModel
  , genModel
  , encode
  , decode
  , EqModel(..)
  , runEqModel
  , defaultValueToVarMapValue
  , module SlamData.Workspace.FormBuilder.Item.FieldType
  ) where

import SlamData.Prelude

import Data.Argonaut ((~>), (:=), (.?))
import Data.Argonaut as J
import Data.DateTime as DT
import Data.Json.Extended as EJSON
import Data.Json.Extended.Signature.Parse as EJP
import Data.Lens (Lens', lens)
import Data.String as Str

import SlamData.Workspace.Card.Port.VarMap as Port
import SlamData.Workspace.FormBuilder.Item.FieldType (FieldType(..), _FieldTypeDisplayName, allFieldTypes, fieldTypeToInputType)

import Text.Parsing.Parser (runParser) as P
import Text.Parsing.Parser.Combinators (try) as P

import Test.StrongCheck.Arbitrary as SC
import Test.StrongCheck.Gen as Gen

type Model =
  { name ∷ String
  , fieldType ∷ FieldType
  , defaultValue ∷ Maybe String
  }

genModel ∷ Gen.Gen Model
genModel = do
  name ← SC.arbitrary
  fieldType ← SC.arbitrary
  defaultValue ← SC.arbitrary
  pure { name, fieldType, defaultValue }

_name ∷ Lens' Model String
_name = lens _.name _ { name = _ }

_fieldType ∷ Lens' Model FieldType
_fieldType = lens _.fieldType _ { fieldType = _ }

_defaultValue ∷ Lens' Model (Maybe String)
_defaultValue = lens _.defaultValue _ { defaultValue = _ }

newtype EqModel = EqModel Model

runEqModel
  ∷ EqModel
  → Model
runEqModel (EqModel m) =
  m

derive instance eqEqModel ∷ Eq EqModel

initialModel ∷ Model
initialModel =
  { name : ""
  , fieldType : StringFieldType
  , defaultValue : Nothing
  }

encode
  ∷ Model
  → J.Json
encode st =
  "name" := st.name
  ~> "fieldType" := st.fieldType
  ~> "defaultValue" := st.defaultValue
  ~> J.jsonEmptyObject

decode
  ∷ J.Json
  → Either String Model
decode =
  J.decodeJson >=> \obj → do
    name ← obj .? "name"
    fieldType ← obj .? "fieldType"
    let fixValue = if fieldType == DateFieldType then fixupDate else id
    defaultValue ← map fixValue <$> obj .? "defaultValue"
    pure { name, fieldType, defaultValue }

defaultValueToVarMapValue
  ∷ FieldType
  → String
  → Maybe Port.VarMapValue
defaultValueToVarMapValue ty str =
  case ty of
    StringFieldType → Just $ Port.Literal $ EJSON.string str
    DateTimeFieldType → Port.Literal <$> parseTimestamp str
    DateFieldType → Port.Literal <$> parseDate str
    TimeFieldType → Port.Literal <$> parseTime str
    IntervalFieldType → Just $ Port.Literal $ EJSON.interval str
    ObjectIdFieldType → Just $ Port.Literal $ EJSON.objectId str
    SqlExprFieldType → Just $ Port.QueryExpr $ str
    SqlIdentifierFieldType → Just $ Port.QueryExpr $ "`" ⊕ str ⊕ "`"
    _ | str == "" → Nothing
    _ →
      P.runParser str EJSON.parseEJson
        # either (\_ → Nothing) (Port.Literal >>> Just)

parseTimestamp ∷ String → Maybe EJSON.EJson
parseTimestamp str = case P.runParser str EJP.parseTimestamp of
  Left _ → Nothing
  Right dt → Just $ EJSON.timestamp dt

parseTime ∷ String → Maybe EJSON.EJson
parseTime str =
  either (const Nothing) (Just ∘ EJSON.time) $
    P.runParser str (P.try fromTimestamp <|> EJP.parseTime)
  where
  fromTimestamp = DT.time <$> EJP.parseTimestamp

parseDate ∷ String → Maybe EJSON.EJson
parseDate str =
  either (const Nothing) (Just ∘ EJSON.date) $
    P.runParser str (P.try fromTimestamp <|> EJP.parseDate)
  where
  fromTimestamp = DT.date <$> EJP.parseTimestamp

-- Truncate value to only include YYYY-MM-DD part, in case of Quasar mongo
-- connector issue that cannot represent dates distinct from datetimes.
fixupDate :: String -> String
fixupDate = Str.take 10


Finished work on Sugar module

Finished work on Sugar module

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.Sugar.TypeClasses
-- Copyright   :  (c) Phil Freeman 2013-14
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- This module implements the desugaring pass which creates type synonyms for type class dictionaries
-- and dictionary expressions for type class instances.
--
-----------------------------------------------------------------------------

module Language.PureScript.Sugar.TypeClasses (
    desugarTypeClasses
  ) where

import Data.Tuple
import Data.Array
import Data.Maybe
import Data.Either
import Data.Foldable (foldl, lookup)
import Data.Traversable (traverse)
import Data.String (joinWith)

import qualified Data.Map as M

import Control.Apply
import Control.Arrow (first, second)

import Control.Monad.Trans
import Control.Monad.Error
import Control.Monad.Error.Class
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class

import Language.PureScript.Declarations
import Language.PureScript.Names
import Language.PureScript.Types
import Language.PureScript.Sugar.CaseDeclarations
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Supply
import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)

import qualified Language.PureScript.Constants as C

type MemberMap = M.Map (Tuple ModuleName ProperName) Declaration

type Desugar = StateT MemberMap (SupplyT (Either ErrorStack))

-- |
-- Add type synonym declarations for type class dictionary types, and value declarations for type class
-- instance dictionary expressions.
--
desugarTypeClasses :: [Module] -> SupplyT (Either ErrorStack) [Module]
desugarTypeClasses = flip evalStateT M.empty <<< traverse desugarModule

desugarModule :: Module -> Desugar Module
desugarModule (Module name decls (Just exps)) = do
  (Tuple newExpss declss) <- unzip <$> traverse (desugarDecl name) decls
  return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)
desugarModule _ = theImpossibleHappened "Exports should have been elaborated in name desugaring"

{- Desugar type class and type class instance declarations
--
-- Type classes become type synonyms for their dictionaries, and type instances become dictionary declarations.
-- Additional values are generated to access individual members of a dictionary, with the appropriate type.
--
-- E.g. the following
--
--   module Test where
--
--   class Foo a where
--     foo :: a -> a
--
--   instance fooString :: Foo String where
--     foo s = s ++ s
--
--   instance fooArray :: (Foo a) => Foo [a] where
--     foo = map foo
--
--   {- Superclasses -}
--
--   class (Foo a) <= Sub a where
--     sub :: a
--
--   instance subString :: Sub String where
--     sub = ""
--
-- becomes
--
--   type Foo a = { foo :: a -> a }
--
--   foreign import foo "function foo(dict) {\
--                      \  return dict.foo;\
--                      \}" :: forall a. (Foo a) => a -> a
--
--   fooString :: {} -> Foo String
--   fooString _ = { foo: \s -> s ++ s }
--
--   fooArray :: forall a. (Foo a) => Foo [a]
--   fooArray = { foo: map foo }
--
--   {- Superclasses -}
--
--   ...
--
--   subString :: {} -> { __superclasses :: { "Foo": {} -> Foo String }, sub :: String }
--   subString _ = {
--     __superclasses: {
--       "Foo": \_ -> <dictionary placeholder to be inserted during type checking\>
--     }
--     sub: ""
--   }
-}
desugarDecl :: ModuleName -> Declaration -> Desugar (Tuple (Maybe DeclarationRef) [Declaration])
desugarDecl mn d@(TypeClassDeclaration name args implies members) = do
  modify (M.insert (Tuple mn name) d)
  return $ (Tuple Nothing (d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members))
desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
  desugared <- lift $ desugarCases members
  dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
  return $ (Tuple (Just (TypeInstanceRef name)) [d, dictDecl])
desugarDecl mn (PositionedDeclaration pos d) = do
  (Tuple dr ds) <- rethrowWithPosition pos $ desugarDecl mn d
  return (Tuple dr (map (PositionedDeclaration pos) ds))
desugarDecl _ other = return (Tuple Nothing [other])

memberToNameAndType :: Declaration -> (Tuple Ident Type)
memberToNameAndType (TypeDeclaration ident ty) = (Tuple ident ty)
memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d
memberToNameAndType _ = theImpossibleHappened "Invalid declaration in type class definition"

identToProperty :: Ident -> String
identToProperty (Ident name) = name
identToProperty (Op op) = op

typeClassDictionaryDeclaration :: ProperName -> [String] -> [Tuple (Qualified ProperName) [Type]] -> [Declaration] -> Declaration
typeClassDictionaryDeclaration name args implies members =
  let rowProperties =
    do Tuple index (Tuple superclass tyArgs) <- zip (range 0 (length implies - 1)) implies
       let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs
       let fieldName = mkSuperclassDictionaryName superclass index
       return (Tuple fieldName (function unitType tySynApp)) in
  let superclassesType = TypeApp tyObject (rowFromList (Tuple rowProperties REmpty))
  in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (Tuple ((Tuple C.__superclasses superclassesType) : map (first identToProperty <<< memberToNameAndType) members) REmpty))

typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration
typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
  ValueDeclaration ident TypeClassAccessorImport [] Nothing $
    TypedValue false (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $
    moveQuantifiersToFront (quantify (ConstrainedType [Tuple (Qualified (Just mn) name) (map TypeVar args)] ty))
typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =
  PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d
typeClassMemberToDictionaryAccessor _ _ _ _ = theImpossibleHappened "Invalid declaration in type class definition"

mkSuperclassDictionaryName :: Qualified ProperName -> Number -> String
mkSuperclassDictionaryName pn index = show pn ++ "_" ++ show index

unitType :: Type
unitType = TypeApp tyObject REmpty

typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [Tuple (Qualified ProperName) [Type]] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
typeInstanceDictionaryDeclaration name mn deps className tys decls =
  rethrow (\e -> strMsg ("Error in type class instance " ++ show className ++ " " ++ joinWith " " (map prettyPrintTypeAtom tys) ++ ": ") <> (e :: ErrorStack)) $ do
  m <- get

  -- Lookup the type arguments and member types for the type class
  (TypeClassDeclaration _ args implies tyDecls) <- lift <<< lift $
    maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
      M.lookup (qualify mn className) m

  case mapMaybe declName tyDecls \\ mapMaybe declName decls of
    x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing
    [] -> do

      let instanceTys = map memberToNameAndType tyDecls

      -- Replace the type arguments with the appropriate types in the member types
      let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
      -- Create values for the type instance members
      memberNames <- map (first identToProperty) <$> traverse (memberToNameAndValue memberTypes) decls
      -- Create the type of the dictionary
      -- The type is an object type, but depending on type instance dependencies, may be constrained.
      -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary
      -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no
      -- dependencies, we introduce an unnamed function parameter.
      let superclasses = ObjectLiteral $
        do (Tuple index (Tuple superclass suTyArgs)) <- zip (range 0 (length implies - 1)) implies
           let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs
           let fieldName = mkSuperclassDictionaryName superclass index
           return (Tuple fieldName (Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs)))

      let memberNames' = (Tuple C.__superclasses superclasses) : memberNames
          dictTy = foldl TypeApp (TypeConstructor className) tys
          constrainedTy = quantify (if null deps then function unitType dictTy else ConstrainedType deps dictTy)
          dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'

      return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue true dict constrainedTy)

  where

  declName :: Declaration -> Maybe Ident
  declName (PositionedDeclaration _ d) = declName d
  declName (ValueDeclaration ident _ _ _ _) = Just ident
  declName (TypeDeclaration ident _) = Just ident
  declName _ = Nothing

  memberToNameAndValue :: [Tuple Ident Type] -> Declaration -> Desugar (Tuple Ident Value)
  memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
    lift <<< lift <<< maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
    let memberValue = typeInstanceDictionaryEntryValue d
    return (Tuple ident memberValue)
  memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do
    (Tuple ident val) <- memberToNameAndValue tys' d
    return (Tuple ident (PositionedValue pos val))
  memberToNameAndValue _ _ = theImpossibleHappened "Invalid declaration in type instance definition"

  typeInstanceDictionaryEntryValue :: Declaration -> Value
  typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val
  typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)
  typeInstanceDictionaryEntryValue _ = theImpossibleHappened "Invalid declaration in type instance definition"

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.Sugar.TypeClasses
-- Copyright   :  (c) Phil Freeman 2013-14
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- This module implements the desugaring pass which creates type synonyms for type class dictionaries
-- and dictionary expressions for type class instances.
--
-----------------------------------------------------------------------------

module Language.PureScript.Sugar.TypeClasses (
    desugarTypeClasses
  ) where

import Data.Tuple
import Data.Array
import Data.Maybe
import Data.Either
import Data.Traversable (traverse)

import qualified Data.Map as M

import Control.Apply
import Control.Arrow (first, second)

import Control.Monad.Error
import Control.Monad.Error.Class
import Control.Monad.State
import Control.Monad.State.Trans
import Control.Monad.State.Class

import Language.PureScript.Declarations
import Language.PureScript.Names
import Language.PureScript.Types
import Language.PureScript.Sugar.CaseDeclarations
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Supply
import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)

import qualified Language.PureScript.Constants as C

type MemberMap = M.Map (Tuple ModuleName ProperName) Declaration

type Desugar = StateT MemberMap (SupplyT (Either ErrorStack))

-- |
-- Add type synonym declarations for type class dictionary types, and value declarations for type class
-- instance dictionary expressions.
--
desugarTypeClasses :: [Module] -> SupplyT (Either ErrorStack) [Module]
desugarTypeClasses = flip evalStateT M.empty <<< traverse desugarModule

desugarModule :: Module -> Desugar Module
desugarModule (Module name decls (Just exps)) = do
  (Tuple newExpss declss) <- unzip <$> traverse (desugarDecl name) decls
  return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)
desugarModule _ = theImpossibleHappened "Exports should have been elaborated in name desugaring"

{- Desugar type class and type class instance declarations
--
-- Type classes become type synonyms for their dictionaries, and type instances become dictionary declarations.
-- Additional values are generated to access individual members of a dictionary, with the appropriate type.
--
-- E.g. the following
--
--   module Test where
--
--   class Foo a where
--     foo :: a -> a
--
--   instance fooString :: Foo String where
--     foo s = s ++ s
--
--   instance fooArray :: (Foo a) => Foo [a] where
--     foo = map foo
--
--   {- Superclasses -}
--
--   class (Foo a) <= Sub a where
--     sub :: a
--
--   instance subString :: Sub String where
--     sub = ""
--
-- becomes
--
--   type Foo a = { foo :: a -> a }
--
--   foreign import foo "function foo(dict) {\
--                      \  return dict.foo;\
--                      \}" :: forall a. (Foo a) => a -> a
--
--   fooString :: {} -> Foo String
--   fooString _ = { foo: \s -> s ++ s }
--
--   fooArray :: forall a. (Foo a) => Foo [a]
--   fooArray = { foo: map foo }
--
--   {- Superclasses -}
--
--   ...
--
--   subString :: {} -> { __superclasses :: { "Foo": {} -> Foo String }, sub :: String }
--   subString _ = {
--     __superclasses: {
--       "Foo": \_ -> <dictionary placeholder to be inserted during type checking\>
--     }
--     sub: ""
--   }
-}
foreign import desugarDecl :: ModuleName -> Declaration -> Desugar (Tuple (Maybe DeclarationRef) [Declaration])
{-
desugarDecl mn d@(TypeClassDeclaration name args implies members) = do
  modify (M.insert (mn, name) d)
  return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
  desugared <- lift $ desugarCases members
  dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
  return $ (Just $ TypeInstanceRef name, [d, dictDecl])
desugarDecl mn (PositionedDeclaration pos d) = do
  (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn d
  return (dr, map (PositionedDeclaration pos) ds)
desugarDecl _ other = return (Nothing, [other])
-}

memberToNameAndType :: Declaration -> (Tuple Ident Type)
memberToNameAndType (TypeDeclaration ident ty) = (Tuple ident ty)
memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d
memberToNameAndType _ = theImpossibleHappened "Invalid declaration in type class definition"

identToProperty :: Ident -> String
identToProperty (Ident name) = name
identToProperty (Op op) = op

foreign import typeClassDictionaryDeclaration :: ProperName -> [String] -> [Tuple (Qualified ProperName) [Type]] -> [Declaration] -> Declaration
{-
typeClassDictionaryDeclaration name args implies members =
  let superclassesType = TypeApp tyObject (rowFromList ([ (fieldName, function unit tySynApp)
                                                        | (index, (superclass, tyArgs)) <- zip [0..] implies
                                                        , let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs
                                                        , let fieldName = mkSuperclassDictionaryName superclass index
                                                        ], REmpty))

  in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList ((C.__superclasses, superclassesType) : map (first identToProperty . memberToNameAndType) members, REmpty))

typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration
typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
  ValueDeclaration ident TypeClassAccessorImport [] Nothing $
    TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $
    moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))
typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =
  PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d
typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
-}

mkSuperclassDictionaryName :: Qualified ProperName -> Number -> String
mkSuperclassDictionaryName pn index = show pn ++ "_" ++ show index

unitType :: Type
unitType = TypeApp tyObject REmpty

foreign import typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [Tuple (Qualified ProperName) [Type]] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
{-typeInstanceDictionaryDeclaration name mn deps className tys decls =
  rethrow (\e -> strMsg ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") <> (e :: ErrorStack)) $ do
  m <- get

  -- Lookup the type arguments and member types for the type class
  (TypeClassDeclaration _ args implies tyDecls) <- lift <<< lift $
    maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
      M.lookup (qualify mn className) m

  case mapMaybe declName tyDecls \\ mapMaybe declName decls of
    x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing
    [] -> do

      let instanceTys = map memberToNameAndType tyDecls

      -- Replace the type arguments with the appropriate types in the member types
      let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
      -- Create values for the type instance members
      memberNames <- map (first identToProperty) <$> mapM (memberToNameAndValue memberTypes) decls
      -- Create the type of the dictionary
      -- The type is an object type, but depending on type instance dependencies, may be constrained.
      -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary
      -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no
      -- dependencies, we introduce an unnamed function parameter.
      let superclasses = ObjectLiteral
            [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))
            | (index, (superclass, suTyArgs)) <- zip [0..] implies
            , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs
            , let fieldName = mkSuperclassDictionaryName superclass index
            ]

      let memberNames' = (C.__superclasses, superclasses) : memberNames
          dictTy = foldl TypeApp (TypeConstructor className) tys
          constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
          dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames') else ObjectLiteral memberNames'

      return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)

  where

  declName :: Declaration -> Maybe Ident
  declName (PositionedDeclaration _ d) = declName d
  declName (ValueDeclaration ident _ _ _ _) = Just ident
  declName (TypeDeclaration ident _) = Just ident
  declName _ = Nothing

  memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
  memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
    _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
    let memberValue = typeInstanceDictionaryEntryValue d
    return (ident, memberValue)
  memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do
    (ident, val) <- memberToNameAndValue tys' d
    return (ident, PositionedValue pos val)
  memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"

  typeInstanceDictionaryEntryValue :: Declaration -> Value
  typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val
  typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)
  typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"
-}