Add basic validation on TrackSource config templates

module Genetics.Browser.Events.TrackSource where
       -- ( TrackSource
       -- , emptyTrackSource
       -- , mkTrackSource
       -- , appendTrackSources
       -- , applyTrackSource
       -- ) where

import Prelude

import Control.Monad.Except (throwError)
import Control.MonadPlus (guard)
import Data.Argonaut (JCursor(JField), Json, JsonPrim, cursorGet, cursorSet, jsonEmptyObject, primToJson)
import Data.Argonaut as Json
import Data.Array (catMaybes, singleton)
import Data.Array as Array
import Data.Either (Either)
import Data.Foldable (all, any, foldMap, foldr)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.StrMap (StrMap)
import Data.StrMap as StrMap
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Genetics.Browser.Events.Types (Event)

{-
TrackSources are defined with two parts:
1. A JSON structure defining what the event to be produced looks like,
where the leaves are all singleton maps with Strings denoting the types of the respective leaf

2. A JSON structure defining what the raw event looks like,
and how to map it to the produced event.

-}

-- TODO keep track of which event names have been used
newtype TrackSource a = TrackSource (Array (Json -> Maybe a))

derive instance functorTrackSource :: Functor TrackSource
derive instance newtypeTrackSource :: Newtype (TrackSource a) _

instance semigroupTrackSource :: Semigroup (TrackSource a) where
  append (TrackSource s1) (TrackSource s2) = TrackSource (s1 <> s2)

instance monoidTrackSource :: Monoid (TrackSource a) where
  mempty = TrackSource mempty

emptyTrackSource :: ∀ a. TrackSource a
emptyTrackSource = TrackSource mempty

type SourceConfig = { eventName :: String
                    , eventTemplate :: Json
                    , rawTemplate :: Json
                    }

type ValueCursor = { cursor :: JCursor
                   , name :: String
                   , vType :: String
                   }

type RawCursor = { cursor :: JCursor
                 , name :: String
                 }

parseTemplatePath :: Tuple JCursor JsonPrim
                  -> Maybe ValueCursor
parseTemplatePath (Tuple cursor t) = do
  vType <- Json.toString $ primToJson t
  name <- case Json.insideOut cursor of
    JField s _ -> Just s
    _          -> Nothing
  pure { cursor, name, vType }

parseTemplateConfig :: Json -> Maybe (Array ValueCursor)
parseTemplateConfig = traverse parseTemplatePath <<< Array.fromFoldable <<< Json.toPrims

parseRawTemplatePath :: Tuple JCursor JsonPrim
                     -> Maybe RawCursor
parseRawTemplatePath (Tuple cursor t) = do
  name <- Json.toString $ primToJson t
  pure { cursor, name }

parseRawTemplateConfig :: Json
                       -> Maybe (Array RawCursor)
parseRawTemplateConfig = traverse parseRawTemplatePath <<< Array.fromFoldable <<< Json.toPrims

fillTemplate :: Array ValueCursor -> StrMap Json -> Maybe Json
fillTemplate t vs = foldr f (Just jsonEmptyObject) t
  where f :: ValueCursor -> Maybe Json -> Maybe Json
        f _ Nothing  = Nothing
        f ec (Just j) = do
          val <- StrMap.lookup ec.name vs
          cursorSet ec.cursor val j

parseRawEvent :: Array RawCursor -> Json -> Maybe (StrMap Json)
parseRawEvent paths json = do
  vals <- traverse (\path -> map (Tuple path.name) (cursorGet path.cursor json)) paths
  pure $ StrMap.fromFoldable vals

-- templates match if each name of the event values
-- occur among the raw template cursors at least once
-- (really it's should be only once but TODO)
matchTemplates :: Array RawCursor -> Array ValueCursor -> Boolean
matchTemplates rcs vcs =
  all (\vc -> any (\rc -> vc.name == rc.name) rcs) vcs
makeTrackSource :: SourceConfig -> Maybe (TrackSource Event)
makeTrackSource sc = do
  -- parse the templates
  eventTemplate <- parseTemplateConfig sc.eventTemplate
  rawTemplate <- parseRawTemplateConfig sc.rawTemplate
  let parseRaw = parseRawEvent rawTemplate
      fillEvent = fillTemplate eventTemplate

  guard $ matchTemplates rawTemplate eventTemplate

  pure $ TrackSource $ singleton $ \rawEvent -> do
    vals <- parseRaw rawEvent
    evData <- fillEvent vals
    pure $ { name: sc.eventName, evData }

runTrackSource :: TrackSource Event -> Json -> Array Event
runTrackSource (TrackSource ts) raw = catMaybes $ map (\f -> f raw) ts

makeTrackSources :: Array SourceConfig -> Maybe (TrackSource Event)
makeTrackSources scs = foldMap makeTrackSource scs

module Genetics.Browser.Events.TrackSource where
       -- ( TrackSource
       -- , emptyTrackSource
       -- , mkTrackSource
       -- , appendTrackSources
       -- , applyTrackSource
       -- ) where

import Prelude

import Data.Argonaut (JCursor(JField), Json, JsonPrim, cursorGet, cursorSet, jsonEmptyObject, primToJson)
import Data.Argonaut as Json
import Data.Array (catMaybes, singleton)
import Data.Array as Array
import Data.Foldable (foldMap, foldr)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.StrMap (StrMap)
import Data.StrMap as StrMap
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Genetics.Browser.Events.Types (Event)

{-
TrackSources are defined with two parts:
1. A JSON structure defining what the event to be produced looks like,
where the leaves are all singleton maps with Strings denoting the types of the respective leaf

2. A JSON structure defining what the raw event looks like,
and how to map it to the produced event.

-}

-- TODO keep track of which event names have been used
newtype TrackSource a = TrackSource (Array (Json -> Maybe a))

derive instance functorTrackSource :: Functor TrackSource
derive instance newtypeTrackSource :: Newtype (TrackSource a) _

instance semigroupTrackSource :: Semigroup (TrackSource a) where
  append (TrackSource s1) (TrackSource s2) = TrackSource (s1 <> s2)

instance monoidTrackSource :: Monoid (TrackSource a) where
  mempty = TrackSource mempty

emptyTrackSource :: ∀ a. TrackSource a
emptyTrackSource = TrackSource mempty

type SourceConfig = { eventName :: String
                    , eventTemplate :: Json
                    , rawTemplate :: Json
                    }

type ValueCursor = { cursor :: JCursor
                   , name :: String
                   , vType :: String
                   }

type RawCursor = { cursor :: JCursor
                 , name :: String
                 }

parseTemplatePath :: Tuple JCursor JsonPrim
                  -> Maybe ValueCursor
parseTemplatePath (Tuple cursor t) = do
  vType <- Json.toString $ primToJson t
  name <- case Json.insideOut cursor of
    JField s _ -> Just s
    _          -> Nothing
  pure { cursor, name, vType }

parseTemplateConfig :: Json -> Maybe (Array ValueCursor)
parseTemplateConfig = traverse parseTemplatePath <<< Array.fromFoldable <<< Json.toPrims

parseRawTemplatePath :: Tuple JCursor JsonPrim
                     -> Maybe RawCursor
parseRawTemplatePath (Tuple cursor t) = do
  name <- Json.toString $ primToJson t
  pure { cursor, name }

parseRawTemplateConfig :: Json
                       -> Maybe (Array RawCursor)
parseRawTemplateConfig = traverse parseRawTemplatePath <<< Array.fromFoldable <<< Json.toPrims

fillTemplate :: Array ValueCursor -> StrMap Json -> Maybe Json
fillTemplate t vs = foldr f (Just jsonEmptyObject) t
  where f :: ValueCursor -> Maybe Json -> Maybe Json
        f _ Nothing  = Nothing
        f ec (Just j) = do
          val <- StrMap.lookup ec.name vs
          cursorSet ec.cursor val j

parseRawEvent :: Array RawCursor -> Json -> Maybe (StrMap Json)
parseRawEvent paths json = do
  vals <- traverse (\path -> map (Tuple path.name) (cursorGet path.cursor json)) paths
  pure $ StrMap.fromFoldable vals

makeTrackSource :: SourceConfig -> Maybe (TrackSource Event)
makeTrackSource sc = do
  -- parse the templates
  eventTemplate <- parseTemplateConfig sc.eventTemplate
  rawTemplate <- parseRawTemplateConfig sc.rawTemplate
  let parseRaw = parseRawEvent rawTemplate
      fillEvent = fillTemplate eventTemplate

  pure $ TrackSource $ singleton $ \rawEvent -> do
    vals <- parseRaw rawEvent
    evData <- fillEvent vals
    pure $ { name: sc.eventName, evData }

runTrackSource :: TrackSource Event -> Json -> Array Event
runTrackSource (TrackSource ts) raw = catMaybes $ map (\f -> f raw) ts

makeTrackSources :: Array SourceConfig -> Maybe (TrackSource Event)
makeTrackSources scs = foldMap makeTrackSource scs


Fixed default stats

Fixed default stats

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 }

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 archer", "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: 11, dex: 12, int: 10 } -- Archer
                , { 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 -- Archer
                      , 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: -2, weight: -2 }
materialStatArmor Copper     = ArmorStat { defence: -1, weight: -1 }
materialStatArmor Iron       = ArmorStat { defence:  0, weight:  1 }
materialStatArmor Steel      = ArmorStat { defence:  1, weight:  2 }
materialStatArmor Titanium   = ArmorStat { defence:  2, weight:  3 }
materialStatArmor Adamantine = ArmorStat { defence:  3, weight:  4 }
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: -3, weight: -3 }
prefixStatArmor RustyA      = ArmorStat { defence: -2, weight:  1 }
prefixStatArmor MasterworkA = ArmorStat { defence:  3, weight:  0 }
prefixStatArmor GodlyA      = ArmorStat { defence:  5, weight:  0 }
prefixStatArmor LightA      = ArmorStat { defence:  0, weight: -3 }
prefixStatArmor HeavyA      = ArmorStat { defence:  4, weight:  5 }
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

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 = { maxHp: 10, hp: 10, def: 10, str: 10, dex: 10, int: 10 }

guardStats = { maxHp: 20, hp: 20, def: 10, str: 8, dex: 8, 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 archer", "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: 11, dex: 12, int: 10 } -- Archer
                , { 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 -- Archer
                      , 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: -2, weight: -2 }
materialStatArmor Copper     = ArmorStat { defence: -1, weight: -1 }
materialStatArmor Iron       = ArmorStat { defence:  0, weight:  1 }
materialStatArmor Steel      = ArmorStat { defence:  1, weight:  2 }
materialStatArmor Titanium   = ArmorStat { defence:  2, weight:  3 }
materialStatArmor Adamantine = ArmorStat { defence:  3, weight:  4 }
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: -3, weight: -3 }
prefixStatArmor RustyA      = ArmorStat { defence: -2, weight:  1 }
prefixStatArmor MasterworkA = ArmorStat { defence:  3, weight:  0 }
prefixStatArmor GodlyA      = ArmorStat { defence:  5, weight:  0 }
prefixStatArmor LightA      = ArmorStat { defence:  0, weight: -3 }
prefixStatArmor HeavyA      = ArmorStat { defence:  4, weight:  5 }
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


Update Ignore

Update Ignore

Original commit 15752290328b447ffe5560307f4d2cf4c9c62e1e

module Language.Swift
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isAlphaNum, isDigit)
import Data.Foldable (for_, null)
import Data.FoldableWithIndex (forWithIndex_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (camelCase, capitalize, decapitalize, genericStringEscape, intToHex, legalizeCharacters, startWithLetter)
import Data.Tuple (Tuple(..))
import Utils (removeElement)

keywords :: Array String
keywords =
    [ "associatedtype", "class", "deinit", "enum", "extension", "fileprivate", "func", "import", "init", "inout", "internal", "let", "open", "operator", "private", "protocol", "public", "static", "struct", "subscript", "typealias", "var"
    , "break", "case", "continue", "default", "defer", "do", "else", "fallthrough", "for", "guard", "if", "in", "repeat", "return", "switch", "where", "while"
    , "as", "Any", "catch", "false", "is", "nil", "rethrows", "super", "self", "Self", "throw", "throws", "true", "try"
    , "_"
    , "associativity", "convenience", "dynamic", "didSet", "final", "get", "infix", "indirect", "lazy", "left", "mutating", "nonmutating", "optional", "override", "postfix", "precedence", "prefix", "Protocol", "required", "right", "set", "Type", "unowned", "weak", "willSet"
    , "String", "Int", "Double", "Bool", "Data", "CommandLine", "FileHandle", "JSONSerialization"
    , "checkNull", "removeNSNull", "nilToNSNull", "convertArray", "convertOptional", "convertDict", "convertDouble"
    ]

renderer :: Renderer
renderer =
    { name: "Swift"
    , aceMode: "swift"
    , extension: "swift"
    , doc: swiftDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: keywords
        , topLevelName: forbidNamer (swiftNameStyle true) (\n -> [swiftNameStyle true n])
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (swiftNameStyle true <<< combineNames)
            , nameFromTypes: simpleNamer (unionNameIntercalated (swiftNameStyle true) "Or")
            }
        }
    }

swiftNameStyle :: Boolean -> String -> String
swiftNameStyle isUpper =
    legalizeCharacters isPartCharacter >>> camelCase >>> startWithLetter isStartCharacter isUpper
    where
        isStartCharacter :: Char -> Boolean
        isStartCharacter c = c == '_' || (isAlphaNum c && not (isDigit c))

        isPartCharacter :: Char -> Boolean
        isPartCharacter c = c == '_' || isAlphaNum c

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

stringEscape :: String -> String
stringEscape =
    genericStringEscape unicodeEscape
    where
        unicodeEscape i =
            ['\\', 'u', '{'] <> intToHex 0 i <> ['}']

swiftDoc :: Doc Unit
swiftDoc = do
    line "// To parse the JSON, add this file to your project and do:"
    line "//"
    forEachTopLevel_ \topLevelName topLevelType -> do
        typ <- renderType topLevelType
        line $ "//   let " <> decapitalize topLevelName <> " = " <> topLevelName <> "(fromString: jsonString)!"
    blank
    line "import Foundation"

    forEachTopLevel_ \topLevelName topLevelType -> do
        blank
        top <- renderType topLevelType
        line $ "typealias "<> topLevelName <> " = " <> top

    forEachClass_ \className properties -> do
        blank
        renderClassDefinition className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionDefinition unionName unionTypes

    blank
    line $ "// Serialization extensions"

    forEachTopLevel_ renderTopLevelExtensions

    forEachClass_ \className properties -> do
        blank
        renderClassExtension className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionExtension unionName unionTypes

    blank
    supportFunctions

supportFunctions :: Doc Unit
supportFunctions = do
    line """// Helpers

fileprivate func convertArray<T>(_ converter: (Any) -> T?, _ json: Any) -> [T]? {
    guard let jsonArr = json as? [Any] else { return nil }
    var arr = [T]()
    for v in jsonArr {
        if let converted = converter(v) {
            arr.append(converted)
        } else {
            return nil
        }
    }
    return arr
}

fileprivate func convertOptional<T>(_ converter: (Any) -> T?, _ json: Any?) -> T?? {
    guard let v = json else { return .some(nil) }
    return converter(v)
}

fileprivate func convertDict<T>(_ converter: (Any) -> T?, _ json: Any?) -> [String: T]? {
    guard let jsonDict = json as? [String: Any] else { return nil }
    var dict = [String: T]()
    for (k, v) in jsonDict {
        if let converted = converter(v) {
            dict[k] = converted
        } else {
            return nil
        }
    }
    return dict
}

fileprivate func convertToAny<T>(_ dictionary: [String: T], _ converter: (T) -> Any) -> Any {
    var result = [String: Any]()
    for (k, v) in dictionary {
        result[k] = converter(v)
    }
    return result
}

fileprivate func convertDouble(_ v: Any) -> Double? {
    if let w = v as? Double { return w }
    if let w = v as? Int { return Double(w) }
    return nil
}

fileprivate let falseType = NSNumber(value: false).objCType
fileprivate let trueNumber = NSNumber(value: true)
fileprivate let trueType = trueNumber.objCType

fileprivate func convertBool(_ v: Any?) -> Bool? {
    guard let number = v as? NSNumber
    else {
        if let b = v as? Bool {
            return b
        }
        return nil
    }

    if number.objCType != falseType && number.objCType != trueType {
        return nil
    }
    return number.isEqual(trueNumber)
}

fileprivate func removeNSNull(_ v: Any?) -> Any? {
    if let w = v {
        if w is NSNull {
            return nil
        }
        return w
    }
    return nil
}

fileprivate func checkNull(_ v: Any?) -> Any?? {
    if v != nil { return .none }
    return .some(nil)
}"""

renderUnion :: IRUnionRep -> Doc String
renderUnion ur =
    case nullableFromSet $ unionToSet ur of
    Just r -> do
        rendered <- renderType r
        pure $ rendered <> "?"
    Nothing -> lookupUnionName ur

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "Any?"
    IRNull -> pure "Any?"
    IRInteger -> pure "Int"
    IRDouble -> pure "Double"
    IRBool -> pure "Bool"
    IRString -> pure "String"
    IRArray a -> do
        rendered <- renderType a
        pure $ "[" <> rendered <> "]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "[String: " <> rendered <> "]"
    IRUnion ur -> renderUnion ur

convertAny :: IRType -> String -> Doc String
convertAny (IRArray a) var = do
    converter <- convertAnyFunc a
    pure $ "convertArray(" <> converter <> ", " <> var <> ")"
convertAny (IRMap m) var = do
    converter <- convertAnyFunc m
    pure $ "convertDict(" <> converter <> ", " <> var <> ")"
convertAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        converter <- convertAnyFunc t
        pure $ "convertOptional(" <> converter <> ", " <> var <> ")"
    Nothing -> do
        name <- lookupUnionName ur
        pure $ name <> ".fromJson(" <> var <> ")"
convertAny IRNothing var =
    pure var
convertAny IRBool var =
    pure $ "convertBool(" <> var <> ")"
convertAny IRInteger var =
    pure $ var <> " as? Int"
convertAny IRString var =
    pure $ var <> " as? String"
convertAny t var = do
    converter <- convertAnyFunc t
    pure $ converter <> "(" <> var <> ")"

convertAnyFunc :: IRType -> Doc String
convertAnyFunc = case _ of
    IRClass i -> do
        name <- lookupClassName i
        -- TODO make this look less alien
        pure $ "{ " <> name <> "(fromAny: $0) }"
    IRUnion ur ->
        case nullableFromSet $ unionToSet ur of
        Just t -> do
            converter <- convertAnyFunc t
            pure $ "{ (json: Any) in convertOptional(" <> converter <> ", json) }"
        Nothing -> do
            name <- lookupUnionName ur
            pure $ name <> ".fromJson"
    IRDouble -> pure "convertDouble"
    IRNull -> pure "checkNull"
    t -> do
        converted <- convertAny t "$0"
        pure $ "{ " <> converted <> " }"

convertToAny :: IRType -> String -> Doc String
convertToAny (IRArray a) var = do
    convertCode <- convertToAny a "$0"
    pure $ var <> ".map({ " <> convertCode <> " }) as Any"
convertToAny (IRMap m) var = do
    convertCode <- convertToAny m "$0"
    pure $ "convertToAny(" <> var <> ", { "<> convertCode <> " })"
convertToAny (IRClass i) var =
    pure $ var <> ".any"
convertToAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        convertCode <- convertToAny t "$0"
        pure $ var <> ".map({ " <> convertCode  <> " }) ?? NSNull()"
    Nothing ->
        pure $ var <> ".any"
convertToAny IRNothing var =
    pure $ var <> " ?? NSNull()"
convertToAny IRNull var =
    pure $ "NSNull() as Any"
convertToAny _ var =
    pure $ var <> " as Any"

renderClassDefinition :: String -> Map String IRType -> Doc Unit
renderClassDefinition className properties = do
    let forbidden = keywords <> ["json", "any"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "struct " <> className <> " {"
    indent do
        forEachProperty_ properties propertyNames \_ ptype fieldName _ -> do
            rendered <- renderType ptype
            line $ "let " <> fieldName <> ": " <> rendered
    line "}"

renderTopLevelExtensions :: String -> IRType -> Doc Unit
renderTopLevelExtensions topLevelName topLevelType = do
    blank

    topLevelRendered <- renderType topLevelType
    extensionType <- case topLevelType of
        IRArray t -> ("Array where Element == " <> _) <$> renderType t
        IRMap t -> ("Dictionary where Key == String, Value == " <> _) <$> renderType t
        _ -> pure topLevelRendered

    line $ "extension " <> extensionType <> " {"
    indent do
        line $ "init?(fromString json: String, using encoding: String.Encoding = .utf8) {"
        indent do
            line "guard let data = json.data(using: encoding) else { return nil }"
            line "self.init(fromData: data)"
        line "}"
        blank
        line $ "init?(fromData data: Data) {"
        indent do
            line "guard let json = try? JSONSerialization.jsonObject(with: data, options: []) else { return nil }"
            line "self.init(fromAny: json)"
        line "}"

        case topLevelType of
            IRArray _ ->  do
                blank
                line $ "init?(fromAny untyped: Any) {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "self.init(elements)"
                line "}"
            IRMap _ -> do
                blank
                line $ "init?(fromAny untyped: Any) {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "self.init()"
                    line $ "elements.forEach { self[$0.key] = $0.value }"
                line "}"
            _ -> pure unit

        blank
        line $ "var jsonData: Data? {"
        indent do
            convertCode <- convertToAny topLevelType "self"
            line $ "let json = " <> convertCode
            line "return try? JSONSerialization.data(withJSONObject: json, options: [])"
        line "}"

        blank
        line $ "var jsonString: String? {"
        indent do
            line $ "guard let data = self.jsonData else { return nil }"
            line $ "return String(data: data, encoding: .utf8)"
        line "}"

    line "}"

renderClassExtension :: String -> Map String IRType -> Doc Unit
renderClassExtension className properties = do
    let forbidden = keywords <> ["jsonUntyped", "json"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "extension " <> className <> " {"
    indent do
        line $ "fileprivate init?(fromAny any: Any) {"
        indent do
            line "guard let json = any as? [String: Any] else { return nil }"
            let forbiddenForUntyped = forbidden <> (A.fromFoldable $ M.keys propertyNames)
            let untypedNames = makePropertyNames properties "Untyped" forbiddenForUntyped
            let forbiddenForConverted = forbiddenForUntyped <> (A.fromFoldable $ M.keys untypedNames)
            let convertedNames = makePropertyNames properties "" forbidden
            forEachProperty_ properties untypedNames \pname ptype untypedName _ -> do
                when (canBeNull ptype) do
                    line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"])"
            unless (M.isEmpty properties) do
                line "guard"
                indent do
                    forEachProperty_ properties untypedNames \pname ptype untypedName isLast -> do
                        let convertedName = lookupName pname convertedNames
                        unless (canBeNull ptype) do
                            line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"]),"
                        convertCode <- convertAny ptype untypedName
                        line $ "let " <> convertedName <> " = " <> convertCode <> (if isLast then "" else ",")
                    line "else { return nil }"
            forEachProperty_ properties propertyNames \pname _ fieldName _ -> do
                let convertedName = lookupName pname convertedNames
                line $ "self." <> fieldName <> " = " <> convertedName
        line "}"
        blank
        line "fileprivate var any: Any {"
        indent do
            if null properties
                then line "return [String: Any]()"
                else do
                    line "return ["
                    indent do
                        forEachProperty_ properties propertyNames \pname ptype fieldName _ -> do
                            convertCode <- convertToAny ptype ("self." <> fieldName)
                            line $ "\"" <> stringEscape pname <> "\": " <> convertCode <> ","
                    line "]"
        line "}"
    line "}"

forEachProperty_ :: Map String IRType -> Map String String -> (String -> IRType -> String -> Boolean -> Doc Unit) -> Doc Unit
forEachProperty_ properties propertyNames f =
    let propertyArray = M.toUnfoldable properties :: Array _
        lastIndex = A.length propertyArray - 1
    in
        forWithIndex_ propertyArray \i (Tuple pname ptype) -> do
            let fieldName = lookupName pname propertyNames
            f pname ptype fieldName (i == lastIndex)

makePropertyNames :: Map String IRType -> String -> Array String -> Map String String
makePropertyNames properties suffix forbidden =
    transformPropertyNames (fieldNamer suffix) otherField forbidden properties
    where
        fieldNamer :: String -> Namer String
        fieldNamer suffix = simpleNamer \name -> swiftNameStyle false name <> suffix

        otherField :: String -> String
        otherField name = "other" <> capitalize name

renderUnionDefinition :: String -> Set IRType -> Doc Unit
renderUnionDefinition unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "enum " <> unionName <> " {"
    indent do
        for_ nonNullTypes \typ -> do
            name <- caseName typ
            rendered <- renderType typ
            line $ "case " <> name <> "(" <> rendered <> ")"
        case emptyOrNull of
            Just t -> do
                name <- caseName t
                line $ "case " <> name
            Nothing -> pure unit
    line "}"

renderUnionExtension :: String -> Set IRType -> Doc Unit
renderUnionExtension unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "extension " <> unionName <> " {"
    indent do
        line $ "fileprivate static func fromJson(_ v: Any) -> " <> unionName <> "? {"
        indent do
            case emptyOrNull of
                Just t -> do
                    name <- caseName t
                    line "guard let v = removeNSNull(v)"
                    line "else {"
                    indent do
                        line $ "return ." <> name
                    line "}"
                Nothing -> pure unit
            when (S.member IRBool unionTypes) do
                renderCase IRBool
            when (S.member IRInteger unionTypes) do
                renderCase IRInteger
            for_ (S.difference nonNullTypes $ S.fromFoldable [IRBool, IRInteger]) \typ -> do
                renderCase typ
            line "return nil"
        line "}"
        blank
        line $ "fileprivate var any: Any {"
        indent do
            line $ "switch self {"
            for_ unionTypes \typ -> do
                name <- caseName typ
                let letString = if typ == IRNull then "" else "(let x)"
                convertCode <- convertToAny typ "x"
                line $ "case ." <> name <> letString <> ": return " <> convertCode
            line "}"
        line "}"
    line "}"
    where
    renderCase :: IRType -> Doc Unit
    renderCase t = do
        convertCode <- convertAny t "v"
        name <- caseName t
        line $ "if let x = " <> convertCode <> " { return ." <> name <> "(x) }"

caseName :: IRType -> Doc String
caseName t = swiftNameStyle false <$> getTypeNameForUnion t

module Language.Swift
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isAlphaNum, isDigit)
import Data.Foldable (for_, null)
import Data.FoldableWithIndex (forWithIndex_)
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.Set as S
import Data.String.Util (camelCase, capitalize, decapitalize, genericStringEscape, intToHex, legalizeCharacters, startWithLetter)
import Data.Tuple (Tuple(..))
import Utils (removeElement)

keywords :: Array String
keywords =
    [ "associatedtype", "class", "deinit", "enum", "extension", "fileprivate", "func", "import", "init", "inout", "internal", "let", "open", "operator", "private", "protocol", "public", "static", "struct", "subscript", "typealias", "var"
    , "break", "case", "continue", "default", "defer", "do", "else", "fallthrough", "for", "guard", "if", "in", "repeat", "return", "switch", "where", "while"
    , "as", "Any", "catch", "false", "is", "nil", "rethrows", "super", "self", "Self", "throw", "throws", "true", "try"
    , "_"
    , "associativity", "convenience", "dynamic", "didSet", "final", "get", "infix", "indirect", "lazy", "left", "mutating", "nonmutating", "optional", "override", "postfix", "precedence", "prefix", "Protocol", "required", "right", "set", "Type", "unowned", "weak", "willSet"
    , "String", "Int", "Double", "Bool", "Data", "CommandLine", "FileHandle", "JSONSerialization"
    , "checkNull", "removeNSNull", "nilToNSNull", "convertArray", "convertOptional", "convertDict", "convertDouble"
    ]

renderer :: Renderer
renderer =
    { name: "Swift"
    , aceMode: "swift"
    , extension: "swift"
    , doc: swiftDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: keywords
        , topLevelName: forbidNamer (swiftNameStyle true) (\n -> [swiftNameStyle true n])
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer (swiftNameStyle true <<< combineNames)
            , nameFromTypes: simpleNamer (unionNameIntercalated (swiftNameStyle true) "Or")
            }
        }
    }

swiftNameStyle :: Boolean -> String -> String
swiftNameStyle isUpper =
    legalizeCharacters isPartCharacter >>> camelCase >>> startWithLetter isStartCharacter isUpper
    where
        isStartCharacter :: Char -> Boolean
        isStartCharacter c = c == '_' || (isAlphaNum c && not (isDigit c))

        isPartCharacter :: Char -> Boolean
        isPartCharacter c = c == '_' || isAlphaNum c

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

stringEscape :: String -> String
stringEscape =
    genericStringEscape unicodeEscape
    where
        unicodeEscape i =
            ['\\', 'u', '{'] <> intToHex 0 i <> ['}']

swiftDoc :: Doc Unit
swiftDoc = do
    line "// To parse the JSON, add this file to your project and do:"
    line "//"
    forEachTopLevel_ \topLevelName topLevelType -> do
        typ <- renderType topLevelType
        line $ "//   let " <> decapitalize topLevelName <> " = " <> topLevelName <> "(fromString: jsonString)!"
    blank
    line "import Foundation"

    forEachTopLevel_ \topLevelName topLevelType -> do
        blank
        top <- renderType topLevelType
        line $ "typealias "<> topLevelName <> " = " <> top

    forEachClass_ \className properties -> do
        blank
        renderClassDefinition className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionDefinition unionName unionTypes

    blank
    line $ "// Serialization extensions"

    forEachTopLevel_ renderTopLevelExtensions

    forEachClass_ \className properties -> do
        blank
        renderClassExtension className properties

    forEachUnion_ \unionName unionTypes -> do
        blank
        renderUnionExtension unionName unionTypes

    blank
    supportFunctions

supportFunctions :: Doc Unit
supportFunctions = do
    line """// Helpers

fileprivate func convertArray<T>(_ converter: (Any) -> T?, _ json: Any) -> [T]? {
    guard let jsonArr = json as? [Any] else { return nil }
    var arr = [T]()
    for v in jsonArr {
        if let converted = converter(v) {
            arr.append(converted)
        } else {
            return nil
        }
    }
    return arr
}

fileprivate func convertOptional<T>(_ converter: (Any) -> T?, _ json: Any?) -> T?? {
    guard let v = json else { return .some(nil) }
    return converter(v)
}

fileprivate func convertDict<T>(_ converter: (Any) -> T?, _ json: Any?) -> [String: T]? {
    guard let jsonDict = json as? [String: Any] else { return nil }
    var dict = [String: T]()
    for (k, v) in jsonDict {
        if let converted = converter(v) {
            dict[k] = converted
        } else {
            return nil
        }
    }
    return dict
}

fileprivate func convertToAny<T>(_ dictionary: [String: T], _ converter: (T) -> Any) -> Any {
    var result = [String: Any]()
    for (k, v) in dictionary {
        result[k] = converter(v)
    }
    return result
}

fileprivate func convertDouble(_ v: Any) -> Double? {
    if let w = v as? Double { return w }
    if let w = v as? Int { return Double(w) }
    return nil
}

fileprivate let falseType = NSNumber(value: false).objCType
fileprivate let trueNumber = NSNumber(value: true)
fileprivate let trueType = trueNumber.objCType

fileprivate func convertBool(_ v: Any?) -> Bool? {
    guard let number = v as? NSNumber
    else {
        if let b = v as? Bool {
            return b
        }
        return nil
    }

    if number.objCType != falseType && number.objCType != trueType {
        return nil
    }
    return number.isEqual(trueNumber)
}

fileprivate func removeNSNull(_ v: Any?) -> Any? {
    if let w = v {
        if w is NSNull {
            return nil
        }
        return w
    }
    return nil
}

fileprivate func checkNull(_ v: Any?) -> Any?? {
    if v != nil { return .none }
    return .some(nil)
}"""

renderUnion :: IRUnionRep -> Doc String
renderUnion ur =
    case nullableFromSet $ unionToSet ur of
    Just r -> do
        rendered <- renderType r
        pure $ rendered <> "?"
    Nothing -> lookupUnionName ur

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "Any?"
    IRNull -> pure "Any?"
    IRInteger -> pure "Int"
    IRDouble -> pure "Double"
    IRBool -> pure "Bool"
    IRString -> pure "String"
    IRArray a -> do
        rendered <- renderType a
        pure $ "[" <> rendered <> "]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "[String: " <> rendered <> "]"
    IRUnion ur -> renderUnion ur

convertAny :: IRType -> String -> Doc String
convertAny (IRArray a) var = do
    converter <- convertAnyFunc a
    pure $ "convertArray(" <> converter <> ", " <> var <> ")"
convertAny (IRMap m) var = do
    converter <- convertAnyFunc m
    pure $ "convertDict(" <> converter <> ", " <> var <> ")"
convertAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        converter <- convertAnyFunc t
        pure $ "convertOptional(" <> converter <> ", " <> var <> ")"
    Nothing -> do
        name <- lookupUnionName ur
        pure $ name <> ".fromJson(" <> var <> ")"
convertAny IRNothing var =
    pure var
convertAny IRBool var =
    pure $ "convertBool(" <> var <> ")"
convertAny IRInteger var =
    pure $ var <> " as? Int"
convertAny IRString var =
    pure $ var <> " as? String"
convertAny t var = do
    converter <- convertAnyFunc t
    pure $ converter <> "(" <> var <> ")"

convertAnyFunc :: IRType -> Doc String
convertAnyFunc = case _ of
    IRClass i -> do
        name <- lookupClassName i
        -- TODO make this look less alien
        pure $ "{ " <> name <> "(fromAny: $0) }"
    IRUnion ur ->
        case nullableFromSet $ unionToSet ur of
        Just t -> do
            converter <- convertAnyFunc t
            pure $ "{ (json: Any) in convertOptional(" <> converter <> ", json) }"
        Nothing -> do
            name <- lookupUnionName ur
            pure $ name <> ".fromJson"
    IRDouble -> pure "convertDouble"
    IRNull -> pure "checkNull"
    t -> do
        converted <- convertAny t "$0"
        pure $ "{ " <> converted <> " }"

convertToAny :: IRType -> String -> Doc String
convertToAny (IRArray a) var = do
    convertCode <- convertToAny a "$0"
    pure $ var <> ".map({ " <> convertCode <> " }) as Any"
convertToAny (IRMap m) var = do
    convertCode <- convertToAny m "$0"
    pure $ "convertToAny(" <> var <> ", { "<> convertCode <> " })"
convertToAny (IRClass i) var =
    pure $ var <> ".any"
convertToAny (IRUnion ur) var =
    case nullableFromSet $ unionToSet ur of
    Just t -> do
        convertCode <- convertToAny t "$0"
        pure $ var <> ".map({ " <> convertCode  <> " }) ?? NSNull()"
    Nothing ->
        pure $ var <> ".any"
convertToAny IRNothing var =
    pure $ var <> " ?? NSNull()"
convertToAny IRNull var =
    pure $ "NSNull() as Any"
convertToAny _ var =
    pure $ var <> " as Any"

renderClassDefinition :: String -> Map String IRType -> Doc Unit
renderClassDefinition className properties = do
    let forbidden = keywords <> ["jsonUntyped", "json"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "struct " <> className <> " {"
    indent do
        forEachProperty_ properties propertyNames \_ ptype fieldName _ -> do
            rendered <- renderType ptype
            line $ "let " <> fieldName <> ": " <> rendered
    line "}"

renderTopLevelExtensions :: String -> IRType -> Doc Unit
renderTopLevelExtensions topLevelName topLevelType = do
    blank

    topLevelRendered <- renderType topLevelType
    extensionType <- case topLevelType of
        IRArray t -> ("Array where Element == " <> _) <$> renderType t
        IRMap t -> ("Dictionary where Key == String, Value == " <> _) <$> renderType t
        _ -> pure topLevelRendered

    line $ "extension " <> extensionType <> " {"
    indent do
        line $ "init?(fromString json: String, using encoding: String.Encoding = .utf8) {"
        indent do
            line "guard let data = json.data(using: encoding) else { return nil }"
            line "self.init(fromData: data)"
        line "}"
        blank
        line $ "init?(fromData data: Data) {"
        indent do
            line "guard let json = try? JSONSerialization.jsonObject(with: data, options: []) else { return nil }"
            line "self.init(fromAny: json)"
        line "}"

        case topLevelType of
            IRArray _ ->  do
                blank
                line $ "init?(fromAny untyped: Any) {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "self.init(elements)"
                line "}"
            IRMap _ -> do
                blank
                line $ "init?(fromAny untyped: Any) {"
                indent do
                    convertCode <- convertAny topLevelType "untyped"
                    line $ "guard let elements = " <> convertCode <> " else { return nil }"
                    line $ "self.init()"
                    line $ "elements.forEach { self[$0.key] = $0.value }"
                line "}"
            _ -> pure unit

        blank
        line $ "var jsonData: Data? {"
        indent do
            convertCode <- convertToAny topLevelType "self"
            line $ "let json = " <> convertCode
            line "return try? JSONSerialization.data(withJSONObject: json, options: [])"
        line "}"

        blank
        line $ "var jsonString: String? {"
        indent do
            line $ "guard let data = self.jsonData else { return nil }"
            line $ "return String(data: data, encoding: .utf8)"
        line "}"

    line "}"

renderClassExtension :: String -> Map String IRType -> Doc Unit
renderClassExtension className properties = do
    let forbidden = keywords <> ["jsonUntyped", "json"]
    let propertyNames = makePropertyNames properties "" forbidden
    line $ "extension " <> className <> " {"
    indent do
        line $ "fileprivate init?(fromAny any: Any) {"
        indent do
            line "guard let json = any as? [String: Any] else { return nil }"
            let forbiddenForUntyped = forbidden <> (A.fromFoldable $ M.keys propertyNames)
            let untypedNames = makePropertyNames properties "Untyped" forbiddenForUntyped
            let forbiddenForConverted = forbiddenForUntyped <> (A.fromFoldable $ M.keys untypedNames)
            let convertedNames = makePropertyNames properties "" forbidden
            forEachProperty_ properties untypedNames \pname ptype untypedName _ -> do
                when (canBeNull ptype) do
                    line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"])"
            unless (M.isEmpty properties) do
                line "guard"
                indent do
                    forEachProperty_ properties untypedNames \pname ptype untypedName isLast -> do
                        let convertedName = lookupName pname convertedNames
                        unless (canBeNull ptype) do
                            line $ "let " <> untypedName <> " = removeNSNull(json[\"" <> stringEscape pname <> "\"]),"
                        convertCode <- convertAny ptype untypedName
                        line $ "let " <> convertedName <> " = " <> convertCode <> (if isLast then "" else ",")
                    line "else { return nil }"
            forEachProperty_ properties propertyNames \pname _ fieldName _ -> do
                let convertedName = lookupName pname convertedNames
                line $ "self." <> fieldName <> " = " <> convertedName
        line "}"
        blank
        line "fileprivate var any: Any {"
        indent do
            if null properties
                then line "return [String: Any]()"
                else do
                    line "return ["
                    indent do
                        forEachProperty_ properties propertyNames \pname ptype fieldName _ -> do
                            convertCode <- convertToAny ptype ("self." <> fieldName)
                            line $ "\"" <> stringEscape pname <> "\": " <> convertCode <> ","
                    line "]"
        line "}"
    line "}"

forEachProperty_ :: Map String IRType -> Map String String -> (String -> IRType -> String -> Boolean -> Doc Unit) -> Doc Unit
forEachProperty_ properties propertyNames f =
    let propertyArray = M.toUnfoldable properties :: Array _
        lastIndex = A.length propertyArray - 1
    in
        forWithIndex_ propertyArray \i (Tuple pname ptype) -> do
            let fieldName = lookupName pname propertyNames
            f pname ptype fieldName (i == lastIndex)

makePropertyNames :: Map String IRType -> String -> Array String -> Map String String
makePropertyNames properties suffix forbidden =
    transformPropertyNames (fieldNamer suffix) otherField forbidden properties
    where
        fieldNamer :: String -> Namer String
        fieldNamer suffix = simpleNamer \name -> swiftNameStyle false name <> suffix

        otherField :: String -> String
        otherField name = "other" <> capitalize name

renderUnionDefinition :: String -> Set IRType -> Doc Unit
renderUnionDefinition unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "enum " <> unionName <> " {"
    indent do
        for_ nonNullTypes \typ -> do
            name <- caseName typ
            rendered <- renderType typ
            line $ "case " <> name <> "(" <> rendered <> ")"
        case emptyOrNull of
            Just t -> do
                name <- caseName t
                line $ "case " <> name
            Nothing -> pure unit
    line "}"

renderUnionExtension :: String -> Set IRType -> Doc Unit
renderUnionExtension unionName unionTypes = do
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) unionTypes
    line $ "extension " <> unionName <> " {"
    indent do
        line $ "fileprivate static func fromJson(_ v: Any) -> " <> unionName <> "? {"
        indent do
            case emptyOrNull of
                Just t -> do
                    name <- caseName t
                    line "guard let v = removeNSNull(v)"
                    line "else {"
                    indent do
                        line $ "return ." <> name
                    line "}"
                Nothing -> pure unit
            when (S.member IRBool unionTypes) do
                renderCase IRBool
            when (S.member IRInteger unionTypes) do
                renderCase IRInteger
            for_ (S.difference nonNullTypes $ S.fromFoldable [IRBool, IRInteger]) \typ -> do
                renderCase typ
            line "return nil"
        line "}"
        blank
        line $ "fileprivate var any: Any {"
        indent do
            line $ "switch self {"
            for_ unionTypes \typ -> do
                name <- caseName typ
                let letString = if typ == IRNull then "" else "(let x)"
                convertCode <- convertToAny typ "x"
                line $ "case ." <> name <> letString <> ": return " <> convertCode
            line "}"
        line "}"
    line "}"
    where
    renderCase :: IRType -> Doc Unit
    renderCase t = do
        convertCode <- convertAny t "v"
        name <- caseName t
        line $ "if let x = " <> convertCode <> " { return ." <> name <> "(x) }"

caseName :: IRType -> Doc String
caseName t = swiftNameStyle false <$> getTypeNameForUnion t


Generalize `Qual` to `QualTree` (wip) [ci skip]

module AST where

import Prelude
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe)
import Data.Tuple (Tuple)
import Data.Bifunctor (rmap)

-- | Operators
-- |
-- | Primitive infix operators that are evaluated directly by the `Evaluator`.
-- | (`Colon` is `Cons` but clashes with `Data.List.Cons`)
data Op = Composition
        | Power
        | Mul
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar
        | InfixFunc String

derive instance eqOp :: Eq Op

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Add    -> "Add"
    Sub    -> "Sub"
    Colon  -> "Colon"
    Append -> "Append"
    Equ    -> "Equ"
    Neq    -> "Neq"
    Lt     -> "Lt"
    Leq    -> "Leq"
    Gt     -> "Gt"
    Geq    -> "Geq"
    And    -> "And"
    Or     -> "Or"
    Dollar -> "Dollar"
    InfixFunc name -> "(InfixFunc " <> name <> ")"

pPrintOp :: Op -> String
pPrintOp op = case op of
  Composition -> "."
  Power  -> "^"
  Mul    -> "*"
  Add    -> "+"
  Sub    -> "-"
  Colon  -> ":"
  Append -> "++"
  Equ    -> "=="
  Neq    -> "/="
  Lt     -> "<"
  Leq    -> "<="
  Gt     -> ">"
  Geq    -> ">="
  And    -> "&&"
  Or     -> "||"
  Dollar -> "$"
  InfixFunc n -> "`" <> n <> "`"

-- | Atoms
-- |
-- | Primitive data types
data Atom = AInt Int
          | Bool Boolean
          | Char String
          | Name String

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

-- | Expressions
-- |
-- | The basic expressions the `Parser` and `Evaluator` recognize.

data Tree a b c d =
    Atom      d a
  | List      d (List (Tree a b c d))
  | NTuple    d (List (Tree a b c d))
  | Binary    d c (Tree a b c d) (Tree a b c d)
  | Unary     d c (Tree a b c d)
  | SectL     d (Tree a b c d) c
  | SectR     d c (Tree a b c d)
  | PrefixOp  d c
  | IfExpr    d (Tree a b c d) (Tree a b c d) (Tree a b c d)
  | ArithmSeq d (Tree a b c d) (Maybe (Tree a b c d)) (Maybe (Tree a b c d))
  | LetExpr   d (List (Tuple b (Tree a b c d))) (Tree a b c d)
  | Lambda    d (List b) (Tree a b c d)
  | App       d (Tree a b c d) (List (Tree a b c d))
  | ListComp  d (Tree a b c d) (List (QualTree b (Tree a b c d) d))

data QualTree b e d = Gen d b e
                    | Let d b e
                    | Guard d e

derive instance eqTree :: (Eq a, Eq b, Eq c, Eq d) => Eq (Tree a b c d)

instance functorQualTree :: Functor (QualTree b e) where
  map f (Gen d b e) = Gen (f d) b e
  map f (Let d b e) = Let (f d) b e
  map f (Guard d e) = Guard (f d) e

instance functorTree :: Functor (Tree a b c) where
  map f (Atom c a) = Atom (f c) a
  map f (List c xs) = List (f c) (map f <$> xs)
  map f (NTuple c xs) = List (f c) (map f <$> xs)
  map f (Binary c op t1 t2) = Binary (f c) op (map f t1) (map f t2)
  map f (Unary c op t) = Unary (f c) op (map f t)
  map f (SectL c t op) = SectL (f c) (map f t) op
  map f (SectR c op t) = SectR (f c) op (map f t)
  map f (PrefixOp c op) = PrefixOp (f c) op
  map f (IfExpr c t1 t2 t3) = IfExpr (f c) (map f t1) (map f t2) (map f t3)
  map f (ArithmSeq c t1 t2 t3) = ArithmSeq (f c) (map f t1) (map f <$> t2) (map f <$> t3)
  map f (LetExpr c bs t) = LetExpr (f c) (map (rmap (map f)) bs) (map f t)
  map f (Lambda c bs t) = Lambda (f c) bs (map f t)
  map f (App c t ts) = App (f c) (map f t) (map f <$> ts)
  map f (ListComp c t ts) = ListComp (f c) (map f t) (map go ts)
    where
    go (Gen d b e) = Gen (f d) b (map f e)
    go (Let d b e) = Let (f d) b (map f e)
    go (Guard d e) = Guard (f d) (map f e)

extract :: forall a b c d. Tree a b c d -> d
extract (Atom c _) = c
extract (List c _) = c
extract (NTuple c _) = c
extract (Binary c _ _ _) = c
extract (Unary c _ _) = c
extract (SectL c _ _) = c
extract (SectR c _ _) = c
extract (PrefixOp c _) = c
extract (IfExpr c _ _ _) = c
extract (ArithmSeq c _ _ _) = c
extract (LetExpr c _ _) = c
extract (Lambda c _ _) = c
extract (App c _ _) = c
extract (ListComp c _ _) = c

extractType :: TypeTree -> Type
extractType = extract

extractBindingType:: TypeBinding -> Type
extractBindingType (TLit t)         = t
extractBindingType (TConsLit _ _ t) = t
extractBindingType (TListLit _ t)   = t
extractBindingType (TNTupleLit _ t) = t

type Expr = Tree Atom Binding Op Unit

-- last type para is type of expr at this level
-- e.x. Binary (Op_Type) (Exp1_TypeTree) (Exp2_TypeTree)

type TypeTree = Tree Unit TypeBinding Type Type

type IndexTree = Tree Unit IBinding Op Int

type IndexQual = QualTree IBinding IndexTree Int

data TypeBinding  = TLit                              Type
                  | TConsLit TypeBinding TypeBinding  Type
                  | TListLit (List TypeBinding)       Type
                  | TNTupleLit (List TypeBinding)     Type

data IBinding  = ILit                       Int
               | IConsLit IBinding IBinding  Int
               | IListLit (List IBinding)    Int
               | INTupleLit (List IBinding)  Int

type TVar = String

data Type
    = TypVar TVar -- Typ Variables e.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | AD AD
    | TypeError TypeError

data AD
    = TList Type
    | TTuple (List Type)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable String
  | UnknownError String
  | NoInstanceOfEnum Type

-- derive instance eqQual :: (Eq b, Eq e) => Eq (Qual b e)

derive instance eqQualTree :: (Eq a, Eq b, Eq c) => Eq (QualTree a b c)

-- | Bindings
-- |
-- | Binding forms for pattern matching on lists and tuples
data Binding = Lit Atom
             | ConsLit Binding Binding
             | ListLit (List Binding)
             | NTupleLit (List Binding)

derive instance eqBinding :: Eq Binding

-- | Definitions
-- |
-- | Definitions for functions and constants
data Definition = Def String (List Binding) Expr

derive instance eqDefintion :: Eq Definition

type Output = {
    expr :: Expr,
    typ :: TypeTree,
    idTree :: IndexTree
  }

instance showAtom :: Show Atom where
  show atom = case atom of
    AInt number -> "AInt " <> show number
    Bool bool   -> "Bool " <> show bool
    Char string -> "Char " <> show string
    Name string -> "Name " <> show string

-- instance showQual :: (Show b, Show e) => Show (Qual b e) where
--   show q = case q of
--     Gen b e -> "Gen (" <> show b <> " " <> show e <> ")"
--     Let b e -> "Let (" <> show b <> " " <> show e <> ")"
--     Guard e -> "Guard (" <> show e <> ")"

instance showQualTree :: (Show a, Show b, Show c) => Show (QualTree a b c) where
  show (Gen a b c) = "Gen (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Let a b c) = "Let (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (Guard a c)  = "Guard (" <> show a <> " " <> show c <> ")"

instance showTree :: (Show a, Show b, Show c, Show d) => Show (Tree a b c d) where
  show tree = case tree of
    Atom c atom         -> "(Atom " <> show c <> " "<> show atom <> ")"
    List c ls           -> "(List " <> show c <> " "<> show ls <>  ")"
    NTuple c ls         -> "(NTuple " <> show c <> " "<> show ls <>  ")"
    Binary c op e1 e2   -> "(Binary " <> show c <> " "<> show op <> " " <> show e1 <> " " <> show e2 <>  ")"
    Unary c op e        -> "(Unary " <> show c <> " "<> show op <> " " <> show e <>  ")"
    SectL c expr op     -> "(SectL " <> show c <> " "<> show expr <> " " <> show op <>  ")"
    SectR c op expr     -> "(SectR " <> show c <> " "<> show op <> " " <> show expr <>  ")"
    PrefixOp c op       -> "(PrefixOp " <> show c <> " " <> show op <> ")"
    IfExpr c ce te ee   -> "(IfExpr " <> show c <> " "<> show ce <> " " <> show te <> " " <> show ee <>  ")"
    ArithmSeq c s by e  -> "(ArithmSeq " <> show c <> "(" <> show s <> ")" <> show by <> ".." <> show e <> ")"
    LetExpr c bs e     -> "(LetExpr " <> show c <> " (" <> show bs <> ") " <> " " <> show e <>  ")"
    Lambda c binds body -> "(Lambda " <> show c <> " " <> show binds <> " " <> show body <>  ")"
    App c func args     -> "(App " <> show c <> " "<> show func <> " " <> show args <>  ")"
    ListComp c expr quals -> "(ListComp " <> show c <> "(" <> show expr <> ")" <> "(" <> show quals <> "))"

instance showBinding :: Show Binding where
  show binding = case binding of
    Lit atom     -> "Lit (" <> show atom <> ")"
    ConsLit b bs -> "ConsLit (" <> show b <> ") (" <> show bs <> ")"
    ListLit bs   -> "ListLit (" <> show bs <> ")"
    NTupleLit ls -> "NTupleLit (" <> show ls <> ")"

instance showDefinition :: Show Definition where
  show (Def name bindings body) = "Def " <> show name <> " (" <> show bindings <> ") (" <> show body <> ")"

instance showType :: Show Type where
  show (TypVar var) = "(TypVar  " <> show var <> ")"
  show (TypCon con) = "(TypCon " <> show con <> ")"
  show (TypArr t1 t2) = "(TypArr "<> show t1 <>" " <> show t2 <> ")"
  show (AD ad) = "(AD "<> show ad <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

instance showAD :: Show AD where
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"

derive instance eqAD :: Eq AD

instance showTypeError :: Show TypeError where
  show (UnificationFail a b) = "(UnificationFail "<> show a <> " " <> show b <>")"
  show (InfiniteType a b ) = "(InfiniteType " <> show a <> " " <> show b <> ")"
  show (UnboundVariable a) = "(UnboundVariable " <> show a <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (NoInstanceOfEnum t) = "(" <> show t <> "is no instance of Enum)"

derive instance eqTypeError :: Eq TypeError

-- instance showTypeTree :: Show TypeTree where
--   show (TAtom t) = "(TAtom " <> show t <> ")"
--   show (TListTree lt t) = "(TListTree (" <> show lt <> ") " <> show t <> ")"
--   show (TNTuple lt t) = "(TNTuple ("<> show lt <> ") " <> show t <> ")"
--   show (TBinary t1 tt1 tt2 t) = "(TBinary " <> show t1 <> " " <> show tt1 <>  " " <> show tt2 <> " " <> show t <> ")"
--   show (TUnary t1 tt t) = "(TUnary "<> show t1 <> " " <> show tt <> " " <> show t <> ")"
--   show (TSectL tt t1 t) = "(TSectL "<> show tt <> " "<> show t1 <> " " <> show t <> ")"
--   show (TSectR t1 tt t) = "(TSectR " <> show t1 <> " " <> show tt <> " " <> show t <> ")"
--   show (TPrefixOp t) = "(TPrefixOp " <> show t <> ")"
--   show (TIfExpr tt1 tt2 tt3 t) = "(TIfExpr " <> show tt1 <> " " <> show tt2 <> " " <> show tt3 <> " " <> show t <> ")"
--   show (TArithmSeq s b e t) = "(TArithmSeq " <> show s <> " " <> show b <> " " <> show e <> ".." <> show t <> ")"
--   show (TLetExpr bin tt t) = "(TLetExpr " <> show bin <> " " <> show tt <> " " <> show t <> ")"
--   show (TLambda lb tt t ) = "(TLambda " <> show lb <> " " <> show tt <> " " <> show t <> ")"
--   show (TApp tt1 tl t) = "(TApp " <> show tt1 <> " (" <> show tl <> ") " <> show t <> ")"
--   show (TListComp e qs t) = "(TListComp " <> show e <> " (" <> show qs <> ") " <> show t <> ")"

instance showTypeBinding:: Show TypeBinding where
  show (TLit t) = "(TLit "<> show t <>")"
  show (TConsLit b1 b2 t) = "(TConsLit "<> show b1 <> " " <> show b2 <> " " <> show t <>")"
  show (TListLit lb t) = "(TListLit " <> show lb <> " "<> show t <>")"
  show (TNTupleLit lb t) = "(TNTupleLit " <> show lb <> " "<> show t <>")"

prettyPrintType :: Type -> String
prettyPrintType (TypVar tvar) = tvar
prettyPrintType (TypCon str) = str
prettyPrintType (TypeError err) = prettyPrintTypeError err
prettyPrintType (TypArr t1@(TypArr _ _) t2) = "(" <> prettyPrintType t1 <> ")" <> " -> " <> prettyPrintType t2
prettyPrintType (TypArr t1 t2) = prettyPrintType t1 <> " -> " <> prettyPrintType t2
prettyPrintType (AD (TList t)) = "[" <> prettyPrintType t <> "]"
prettyPrintType (AD (TTuple ts)) = "(" <> (fold <<< separateWith ", " <<< map prettyPrintType $ ts) <> ")"
    where
    separateWith :: String -> List String -> List String
    separateWith _ Nil = "" : Nil
    separateWith sep (t:ts) = t : map ((<>) sep) ts

prettyPrintTypeError :: TypeError -> String
prettyPrintTypeError (UnificationFail t1 t2) = "UnificationFail: Can't unify " <> prettyPrintType t1 <> " with " <> prettyPrintType t2
prettyPrintTypeError (InfiniteType tvar t) = "InfiniteType: cannot construct the infinite type: " <> tvar <> " ~ " <> prettyPrintType t
prettyPrintTypeError (UnboundVariable var) = "UnboundVariable: Not in scope " <> var
prettyPrintTypeError (NoInstanceOfEnum t) = "No instance for Enum " <> prettyPrintType t <> " defined."
prettyPrintTypeError (UnknownError str) = "UnknownError: " <> str

-- extractType:: TypeTree -> Type
-- extractType (TAtom t)            = t
-- extractType (TListTree _ t)      = t
-- extractType (TNTuple _ t)        = t
-- extractType (TBinary _ _ _ t)    = t
-- extractType (TUnary _ _ t)       = t
-- extractType (TSectL _ _ t)       = t
-- extractType (TSectR _ _ t)       = t
-- extractType (TPrefixOp t)        = t
-- extractType (TIfExpr _ _ _ t)    = t
-- extractType (TArithmSeq _ _ _ t) = t
-- extractType (TLetExpr _ _ t)     = t
-- extractType (TLambda _ _ t)      = t
-- extractType (TApp _ _ t)         = t
-- extractType (TListComp _ _ t)    = t

-- 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 (IArithmSeq _ _ _ i) = i
-- extractIndex (ILetExpr _ _ i)     = i
-- extractIndex (ILambda _ _ i)      = i
-- extractIndex (IApp _ _ i)         = i
-- extractIndex (IListComp _ _ i)    = i

-- extractBindingType:: TypeBinding -> Type
-- extractBindingType (TLit t)         = t
-- extractBindingType (TConsLit _ _ t) = t
-- extractBindingType (TListLit _ t)   = t
-- extractBindingType (TNTupleLit _ t) = t

module AST where

import Prelude
import Data.List (List(..), fold, (:))
import Data.Maybe (Maybe)
import Data.Tuple (Tuple)

-- | Operators
-- |
-- | Primitive infix operators that are evaluated directly by the `Evaluator`.
-- | (`Colon` is `Cons` but clashes with `Data.List.Cons`)
data Op = Composition
        | Power
        | Mul
        | Add | Sub
        | Colon | Append
        | Equ | Neq | Lt | Leq | Gt | Geq
        | And
        | Or
        | Dollar
        | InfixFunc String

derive instance eqOp :: Eq Op

instance showOp :: Show Op where
  show op = case op of
    Composition -> "Composition"
    Power  -> "Power"
    Mul    -> "Mul"
    Add    -> "Add"
    Sub    -> "Sub"
    Colon  -> "Colon"
    Append -> "Append"
    Equ    -> "Equ"
    Neq    -> "Neq"
    Lt     -> "Lt"
    Leq    -> "Leq"
    Gt     -> "Gt"
    Geq    -> "Geq"
    And    -> "And"
    Or     -> "Or"
    Dollar -> "Dollar"
    InfixFunc name -> "(InfixFunc " <> name <> ")"

pPrintOp :: Op -> String
pPrintOp op = case op of
  Composition -> "."
  Power  -> "^"
  Mul    -> "*"
  Add    -> "+"
  Sub    -> "-"
  Colon  -> ":"
  Append -> "++"
  Equ    -> "=="
  Neq    -> "/="
  Lt     -> "<"
  Leq    -> "<="
  Gt     -> ">"
  Geq    -> ">="
  And    -> "&&"
  Or     -> "||"
  Dollar -> "$"
  InfixFunc n -> "`" <> n <> "`"

-- | Atoms
-- |
-- | Primitive data types
data Atom = AInt Int
          | Bool Boolean
          | Char String
          | Name String

derive instance eqAtom :: Eq Atom

derive instance ordAtom :: Ord Atom

-- | Expressions
-- |
-- | The basic expressions the `Parser` and `Evaluator` recognize.

data Tree a b c =
    Atom      c a
  | List      c (List (Tree a b c))
  | NTuple    c (List (Tree a b c))
  | Binary    c Op (Tree a b c) (Tree a b c)
  | Unary     c Op (Tree a b c)
  | SectL     c (Tree a b c) Op
  | SectR     c Op (Tree a b c)
  | PrefixOp  c Op
  | IfExpr    c (Tree a b c) (Tree a b c) (Tree a b c)
  | ArithmSeq c (Tree a b c) (Maybe (Tree a b c)) (Maybe (Tree a b c))
  | LetExpr   c (List (Tuple b (Tree a b c))) (Tree a b c)
  | Lambda    c (List b) (Tree a b c)
  | App       c (Tree a b c) (List (Tree a b c))
  | ListComp  c (Tree a b c) (List (Qual b (Tree a b c)))

derive instance eqTree :: (Eq a, Eq b, Eq c) => Eq (Tree a b c)

type Expr = Tree Atom Binding Unit

data Qual b e = Gen b e | Let b e | Guard e

data QualTree b e t = TGen b e t
                    | TLet b e t
                    | TGuard e t

type ExprQual = Qual Binding Expr

-- last type para is type of expr at this level
-- e.x. Binary (Op_Type) (Exp1_TypeTree) (Exp2_TypeTree)

type TypeTree = Tree Unit TypeBinding Type

type IndexTree = Tree Unit IBinding Int

type TypeQual  = QualTree TypeBinding TypeTree Type

type IndexQual = QualTree IBinding IndexTree Int

data TypeBinding  = TLit                              Type
                  | TConsLit TypeBinding TypeBinding  Type
                  | TListLit (List TypeBinding)       Type
                  | TNTupleLit (List TypeBinding)     Type

data IBinding  = ILit                       Int
               | IConsLit IBinding IBinding  Int
               | IListLit (List IBinding)    Int
               | INTupleLit (List IBinding)  Int

type TVar = String

data Type
    = TypVar TVar -- Typ Variables e.x. a
    | TypCon String -- Typ Constants e.x Int
    | TypArr Type Type -- e.x Int -> Int
    | AD AD
    | TypeError TypeError

data AD
    = TList Type
    | TTuple (List Type)

data TypeError
  = UnificationFail Type Type
  | InfiniteType TVar Type
  | UnboundVariable String
  | UnknownError String
  | NoInstanceOfEnum Type

derive instance eqQual :: (Eq b, Eq e) => Eq (Qual b e)

derive instance eqQualTree :: (Eq a, Eq b, Eq c) => Eq (QualTree a b c)

-- | Bindings
-- |
-- | Binding forms for pattern matching on lists and tuples
data Binding = Lit Atom
             | ConsLit Binding Binding
             | ListLit (List Binding)
             | NTupleLit (List Binding)

derive instance eqBinding :: Eq Binding

-- | Definitions
-- |
-- | Definitions for functions and constants
data Definition = Def String (List Binding) Expr

derive instance eqDefintion :: Eq Definition

type Output = {
    expr :: Expr,
    typ :: TypeTree,
    idTree :: IndexTree
  }

instance showAtom :: Show Atom where
  show atom = case atom of
    AInt number -> "AInt " <> show number
    Bool bool   -> "Bool " <> show bool
    Char string -> "Char " <> show string
    Name string -> "Name " <> show string

instance showQual :: (Show b, Show e) => Show (Qual b e) where
  show q = case q of
    Gen b e -> "Gen (" <> show b <> " " <> show e <> ")"
    Let b e -> "Let (" <> show b <> " " <> show e <> ")"
    Guard e -> "Guard (" <> show e <> ")"

instance showQualTree :: (Show a, Show b, Show c) => Show (QualTree a b c) where
  show (TGen a b c) = "TGen (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (TLet a b c) = "TLet (" <> show a <> " " <> show b <> " " <> show c <> ")"
  show (TGuard a c)  = "TGuard (" <> show a <> " " <> show c <> ")"

instance showTree :: (Show a, Show b, Show c) => Show (Tree a b c) where
  show tree = case tree of
    Atom c atom         -> "(Atom " <> show c <> " "<> show atom <> ")"
    List c ls           -> "(List " <> show c <> " "<> show ls <>  ")"
    NTuple c ls         -> "(NTuple " <> show c <> " "<> show ls <>  ")"
    Binary c op e1 e2   -> "(Binary " <> show c <> " "<> show op <> " " <> show e1 <> " " <> show e2 <>  ")"
    Unary c op e        -> "(Unary " <> show c <> " "<> show op <> " " <> show e <>  ")"
    SectL c expr op     -> "(SectL " <> show c <> " "<> show expr <> " " <> show op <>  ")"
    SectR c op expr     -> "(SectR " <> show c <> " "<> show op <> " " <> show expr <>  ")"
    PrefixOp c op       -> "(PrefixOp " <> show c <> " " <> show op <> ")"
    IfExpr c ce te ee   -> "(IfExpr " <> show c <> " "<> show ce <> " " <> show te <> " " <> show ee <>  ")"
    ArithmSeq c s by e  -> "(ArithmSeq " <> show c <> "(" <> show s <> ")" <> show by <> ".." <> show e <> ")"
    LetExpr c bs e     -> "(LetExpr " <> show c <> " (" <> show bs <> ") " <> " " <> show e <>  ")"
    Lambda c binds body -> "(Lambda " <> show c <> " " <> show binds <> " " <> show body <>  ")"
    App c func args     -> "(App " <> show c <> " "<> show func <> " " <> show args <>  ")"
    ListComp c expr quals -> "(ListComp " <> show c <> "(" <> show expr <> ")" <> "(" <> show quals <> "))"

instance showBinding :: Show Binding where
  show binding = case binding of
    Lit atom     -> "Lit (" <> show atom <> ")"
    ConsLit b bs -> "ConsLit (" <> show b <> ") (" <> show bs <> ")"
    ListLit bs   -> "ListLit (" <> show bs <> ")"
    NTupleLit ls -> "NTupleLit (" <> show ls <> ")"

instance showDefinition :: Show Definition where
  show (Def name bindings body) = "Def " <> show name <> " (" <> show bindings <> ") (" <> show body <> ")"

instance showType :: Show Type where
  show (TypVar var) = "(TypVar  " <> show var <> ")"
  show (TypCon con) = "(TypCon " <> show con <> ")"
  show (TypArr t1 t2) = "(TypArr "<> show t1 <>" " <> show t2 <> ")"
  show (AD ad) = "(AD "<> show ad <> ")"
  show (TypeError err) ="(TypeError "<> show err <>")"

derive instance eqType :: Eq Type

instance showAD :: Show AD where
  show (TList t) = "(TList "<> show t <>")"
  show (TTuple tl) = "(TTuple ("<> show tl <> "))"

derive instance eqAD :: Eq AD

instance showTypeError :: Show TypeError where
  show (UnificationFail a b) = "(UnificationFail "<> show a <> " " <> show b <>")"
  show (InfiniteType a b ) = "(InfiniteType " <> show a <> " " <> show b <> ")"
  show (UnboundVariable a) = "(UnboundVariable " <> show a <> ")"
  show (UnknownError s) = "(UnknownError " <> s <> ")"
  show (NoInstanceOfEnum t) = "(" <> show t <> "is no instance of Enum)"

derive instance eqTypeError :: Eq TypeError

-- instance showTypeTree :: Show TypeTree where
--   show (TAtom t) = "(TAtom " <> show t <> ")"
--   show (TListTree lt t) = "(TListTree (" <> show lt <> ") " <> show t <> ")"
--   show (TNTuple lt t) = "(TNTuple ("<> show lt <> ") " <> show t <> ")"
--   show (TBinary t1 tt1 tt2 t) = "(TBinary " <> show t1 <> " " <> show tt1 <>  " " <> show tt2 <> " " <> show t <> ")"
--   show (TUnary t1 tt t) = "(TUnary "<> show t1 <> " " <> show tt <> " " <> show t <> ")"
--   show (TSectL tt t1 t) = "(TSectL "<> show tt <> " "<> show t1 <> " " <> show t <> ")"
--   show (TSectR t1 tt t) = "(TSectR " <> show t1 <> " " <> show tt <> " " <> show t <> ")"
--   show (TPrefixOp t) = "(TPrefixOp " <> show t <> ")"
--   show (TIfExpr tt1 tt2 tt3 t) = "(TIfExpr " <> show tt1 <> " " <> show tt2 <> " " <> show tt3 <> " " <> show t <> ")"
--   show (TArithmSeq s b e t) = "(TArithmSeq " <> show s <> " " <> show b <> " " <> show e <> ".." <> show t <> ")"
--   show (TLetExpr bin tt t) = "(TLetExpr " <> show bin <> " " <> show tt <> " " <> show t <> ")"
--   show (TLambda lb tt t ) = "(TLambda " <> show lb <> " " <> show tt <> " " <> show t <> ")"
--   show (TApp tt1 tl t) = "(TApp " <> show tt1 <> " (" <> show tl <> ") " <> show t <> ")"
--   show (TListComp e qs t) = "(TListComp " <> show e <> " (" <> show qs <> ") " <> show t <> ")"

instance showTypeBinding:: Show TypeBinding where
  show (TLit t) = "(TLit "<> show t <>")"
  show (TConsLit b1 b2 t) = "(TConsLit "<> show b1 <> " " <> show b2 <> " " <> show t <>")"
  show (TListLit lb t) = "(TListLit " <> show lb <> " "<> show t <>")"
  show (TNTupleLit lb t) = "(TNTupleLit " <> show lb <> " "<> show t <>")"

prettyPrintType :: Type -> String
prettyPrintType (TypVar tvar) = tvar
prettyPrintType (TypCon str) = str
prettyPrintType (TypeError err) = prettyPrintTypeError err
prettyPrintType (TypArr t1@(TypArr _ _) t2) = "(" <> prettyPrintType t1 <> ")" <> " -> " <> prettyPrintType t2
prettyPrintType (TypArr t1 t2) = prettyPrintType t1 <> " -> " <> prettyPrintType t2
prettyPrintType (AD (TList t)) = "[" <> prettyPrintType t <> "]"
prettyPrintType (AD (TTuple ts)) = "(" <> (fold <<< separateWith ", " <<< map prettyPrintType $ ts) <> ")"
    where
    separateWith :: String -> List String -> List String
    separateWith _ Nil = "" : Nil
    separateWith sep (t:ts) = t : map ((<>) sep) ts

prettyPrintTypeError :: TypeError -> String
prettyPrintTypeError (UnificationFail t1 t2) = "UnificationFail: Can't unify " <> prettyPrintType t1 <> " with " <> prettyPrintType t2
prettyPrintTypeError (InfiniteType tvar t) = "InfiniteType: cannot construct the infinite type: " <> tvar <> " ~ " <> prettyPrintType t
prettyPrintTypeError (UnboundVariable var) = "UnboundVariable: Not in scope " <> var
prettyPrintTypeError (NoInstanceOfEnum t) = "No instance for Enum " <> prettyPrintType t <> " defined."
prettyPrintTypeError (UnknownError str) = "UnknownError: " <> str

-- extractType:: TypeTree -> Type
-- extractType (TAtom t)            = t
-- extractType (TListTree _ t)      = t
-- extractType (TNTuple _ t)        = t
-- extractType (TBinary _ _ _ t)    = t
-- extractType (TUnary _ _ t)       = t
-- extractType (TSectL _ _ t)       = t
-- extractType (TSectR _ _ t)       = t
-- extractType (TPrefixOp t)        = t
-- extractType (TIfExpr _ _ _ t)    = t
-- extractType (TArithmSeq _ _ _ t) = t
-- extractType (TLetExpr _ _ t)     = t
-- extractType (TLambda _ _ t)      = t
-- extractType (TApp _ _ t)         = t
-- extractType (TListComp _ _ t)    = t

-- 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 (IArithmSeq _ _ _ i) = i
-- extractIndex (ILetExpr _ _ i)     = i
-- extractIndex (ILambda _ _ i)      = i
-- extractIndex (IApp _ _ i)         = i
-- extractIndex (IListComp _ _ i)    = i

-- extractBindingType:: TypeBinding -> Type
-- extractBindingType (TLit t)         = t
-- extractBindingType (TConsLit _ _ t) = t
-- extractBindingType (TListLit _ t)   = t
-- extractBindingType (TNTupleLit _ t) = t


removed useless tests (there is only one function and it's foreign)

module Test.Main where

import Control.Monad.Eff
import Debug.Trace

import Data.Minimatch

main = do
  print "true"
  print $ minimatch "foo*" "foo"
  print "true"
  print $ minimatch "foo*" "foobar"
  print "false"
  print $ minimatch "foo*" "fo"
  print "true"
  print $ minimatch "bar?" "barz"
  print "false"
  print $ minimatch "bar?" "barfoo"