Updated to do partial search

Updated to do partial search

module SearchEngine where

import Data.Maybe.Unsafe (fromJust)
import Data.Map (Map(), fromList, lookup, insert, empty, values, keys)
import Control.Apply
import Data.Tuple
import Data.String (trim, split, toCharArray, fromCharArray, toLower, indexOf, joinWith)
import Data.Char
import Data.Array (range, length, filter, null, sort, sortBy, groupBy, drop, concatMap, concat)
import Data.Foldable (foldl, all)
import Data.Maybe
import Data.Function (on)
import Data.Array.Unsafe (head)

type Doc = [Line]
type Line = String
type Word = String
type LineNumber = Number
type Pos = Number
type Index = Map Word [Tuple Pos LineNumber]

data IndexedWord = IndexedWord { word:: Word, pos:: Pos, line:: LineNumber }

data PartialTermIndex = D (Map Char (Tuple [[Char]] PartialTermIndex))

both :: forall a. (a -> Boolean) -> (a -> Boolean) -> a -> Boolean
both = lift2 (&&)

lines :: String -> [Line]
lines s = trim <$> (split "\n" s)

words :: String -> [Word]
words s = trim <$> (split " " s)

numLines :: Doc -> [Tuple Line LineNumber]
numLines doc = flip zip ns doc
    where ns = range 0 (length doc)

numWords :: Line -> [Tuple Word Pos]
numWords line = flip zip ns ws
    where ns = range 0 (length ws)
          ws = cleanWords (words line)

isUpperCaseLetter :: Char -> Boolean
isUpperCaseLetter ch = toCharCode ch >= 65 && toCharCode ch <= 90

isLowerCaseLetter :: Char -> Boolean
isLowerCaseLetter ch = toCharCode ch >= 97 && toCharCode ch <= 122

isLetter :: Char -> Boolean
isLetter ch = isUpperCaseLetter ch || isLowerCaseLetter ch

isAscii :: Char -> Boolean
isAscii ch = toCharCode ch >= 0 && toCharCode ch <= 127

cleanWords :: [Word] -> [Word]
cleanWords = (<$>) toLower <<<
             (<$>) fromCharArray <<<
             filter (not <<< null) <<<
             (<$>) (filter (both isLetter isAscii)) <<<
             (<$>) toCharArray

allNumWords :: [Tuple Line LineNumber] -> [Tuple Word (Tuple Pos LineNumber)]
allNumWords = (>>= (\(Tuple l i) -> (<$>) (\(Tuple w p) -> Tuple w (Tuple p i)) $ numWords l))

makeLists :: [Tuple Word (Tuple Pos LineNumber)] -> [Tuple Word [Tuple Pos LineNumber]]
makeLists = (<$>) (\(Tuple w (Tuple p i)) -> Tuple w [Tuple p i])

accumulate :: [Tuple Word [Tuple Pos LineNumber]] -> [Tuple Word [Tuple Pos LineNumber]]
accumulate = foldl f []
           where f [] x = [x]
                 f ((Tuple w ls):xs) (Tuple w2 [l]) | w == w2 = (Tuple w (l:ls)):xs
                 f ((Tuple w ls):xs) (Tuple w2 [l]) | w /= w2 = (Tuple w2 [l]):((Tuple w ls):xs)

createTermIndex :: Doc -> Index
createTermIndex =  fromList <<< accumulate <<< makeLists <<< sort <<< allNumWords <<< numLines

createPartialTermIndex :: [String] -> PartialTermIndex
createPartialTermIndex = createPartialTermIndex' <<< (<$>) toCharArray
  where
    createPartialTermIndex' []  = D empty
    createPartialTermIndex' ws  =
        foldl (\(D m) (Tuple k ws') -> D $ insert k (Tuple ws' (createPartialTermIndex' ((<$>) (drop 1) ws'))) m) (D empty) <<<
        (<$>) (\ws' -> Tuple (head (head ws')) ws') <<<
        groupBy ((==) `on` head) <<<
        sortBy (compare `on` head) <<<
        filter (not <<< null) $ ws

searchTermsFromPartial :: [Char] -> PartialTermIndex -> Tuple Boolean [[Char]]
searchTermsFromPartial s d = findTerms s d
  where
    flattenValues = (<$>) (s ++) <<< concatMap fst <<< values

    findTerms [] (D d') = Tuple true (flattenValues d')
    findTerms (x:xs) (D d') =
      case lookup x d' of
            Just (Tuple _ d'') -> findTerms xs d''
            Nothing -> Tuple false (flattenValues d')

createIndex :: Doc -> Tuple Index PartialTermIndex
createIndex doc = Tuple index (createPartialTermIndex (keys index))
  where index = createTermIndex doc

getWordIndex :: Tuple Index PartialTermIndex -> String -> [Tuple Pos LineNumber]
getWordIndex (Tuple i pti) w = fromMaybe (if fst matches then concatMap (\m -> fromJust (lookup m i)) (fromCharArray <$> (snd matches))
                                                    else [])
                                    (lookup w i)
              where matches = searchTermsFromPartial (toCharArray w) pti

pos :: IndexedWord -> Pos
pos (IndexedWord { word:w, pos:p, line:l }) = p

line :: IndexedWord -> LineNumber
line (IndexedWord { word:w, pos:p, line:l }) = l

word :: IndexedWord -> Word
word (IndexedWord { word:w, pos:p, line:l }) = w

getIndexedWords :: Tuple Index PartialTermIndex -> [Word] -> [IndexedWord]
getIndexedWords i = concatMap (\w -> (<$>) (\(Tuple p l) -> IndexedWord{word:w,pos:p,line:l}) (getWordIndex i w))

groupByLine :: [IndexedWord] -> [[IndexedWord]]
groupByLine = (<$>) (sortBy(compare `on` pos)) <<<
              groupBy ((==) `on` line) <<<
              sortBy(compare `on` line)

equalTermsAndResults :: [Word] -> [IndexedWord] -> Boolean
equalTermsAndResults ws rs = (length ws) <= (length ws') && ((indexOf (joinWith "," (sort ws)) (joinWith "," (sort ws'))) > -1)
        where ws' = word <$> rs

consecutiveWords :: [IndexedWord] -> Boolean
consecutiveWords rs = all (\(Tuple x y) -> y - x <= 2) (zip ps (drop 1 ps))
              where ps = pos <$> rs

toTuple :: IndexedWord -> Tuple Word (Tuple Pos LineNumber)
toTuple iw = Tuple (word iw) (Tuple (pos iw) (line iw))

search :: Tuple Index PartialTermIndex -> String -> [Tuple Word (Tuple Pos LineNumber)]
search i s = toTuple <$> (concat (filter predicate (groupByLine plwords)))
      where
            predicate = both (equalTermsAndResults cleaned_words) consecutiveWords
            cleaned_words = (cleanWords <<< words) s
            plwords = getIndexedWords i cleaned_words

module SearchEngine where

import Data.Maybe.Unsafe (fromJust)
import Data.Map (Map(), fromList, lookup, insert, empty, values, keys)
import Control.Apply
import Data.Tuple
import Data.String (trim, split, toCharArray, fromCharArray, toLower)
import Data.Char
import Data.Array (range, length, filter, null, sort, sortBy, groupBy, drop, concatMap, concat)
import Data.Foldable (foldl)
import Data.Maybe
import Data.Function (on)
import Data.Array.Unsafe (head)

type Doc = [Line]
type Line = String
type Word = String
type LineNumber = Number
type Pos = Number
type Index = Map Word [Tuple Pos LineNumber]

data PartialTermIndex = D (Map Char (Tuple [[Char]] PartialTermIndex))

both :: forall a. (a -> Boolean) -> (a -> Boolean) -> a -> Boolean
both = lift2 (&&)

lines :: String -> [Line]
lines s = trim <$> (split "\n" s)

words :: String -> [Word]
words s = trim <$> (split " " s)

numLines :: Doc -> [Tuple Line LineNumber]
numLines doc = flip zip ns doc
    where ns = range 0 (length doc)

numWords :: Line -> [Tuple Word Pos]
numWords line = flip zip ns ws
    where ns = range 0 (length ws)
          ws = cleanWords (words line)

isUpperCaseLetter :: Char -> Boolean
isUpperCaseLetter ch = toCharCode ch >= 65 && toCharCode ch <= 90

isLowerCaseLetter :: Char -> Boolean
isLowerCaseLetter ch = toCharCode ch >= 97 && toCharCode ch <= 122

isLetter :: Char -> Boolean
isLetter ch = isUpperCaseLetter ch || isLowerCaseLetter ch

isAscii :: Char -> Boolean
isAscii ch = toCharCode ch >= 0 && toCharCode ch <= 127

cleanWords :: [Word] -> [Word]
cleanWords = (<$>) toLower <<<
             (<$>) fromCharArray <<<
             filter (not <<< null) <<<
             (<$>) (filter (both isLetter isAscii)) <<<
             (<$>) toCharArray

allNumWords :: [Tuple Line LineNumber] -> [Tuple Word (Tuple Pos LineNumber)]
allNumWords = (>>= (\(Tuple l i) -> (<$>) (\(Tuple w p) -> Tuple w (Tuple p i)) $ numWords l))

makeLists :: [Tuple Word (Tuple Pos LineNumber)] -> [Tuple Word [Tuple Pos LineNumber]]
makeLists = (<$>) (\(Tuple w (Tuple p i)) -> Tuple w [Tuple p i])

accumulate :: [Tuple Word [Tuple Pos LineNumber]] -> [Tuple Word [Tuple Pos LineNumber]]
accumulate = foldl f []
           where f [] x = [x]
                 f ((Tuple w ls):xs) (Tuple w2 [l]) | w == w2 = (Tuple w (l:ls)):xs
                 f ((Tuple w ls):xs) (Tuple w2 [l]) | w /= w2 = (Tuple w2 [l]):((Tuple w ls):xs)

createTermIndex :: Doc -> Index
createTermIndex =  fromList <<< accumulate <<< makeLists <<< sort <<< allNumWords <<< numLines

createPartialTermIndex :: [String] -> PartialTermIndex
createPartialTermIndex = createPartialTermIndex' <<< (<$>) toCharArray
  where
    createPartialTermIndex' []  = D empty
    createPartialTermIndex' ws  =
        foldl (\(D m) (Tuple k ws') -> D $ insert k (Tuple ws' (createPartialTermIndex' ((<$>) (drop 1) ws'))) m) (D empty) <<<
        (<$>) (\ws' -> Tuple (head (head ws')) ws') <<<
        groupBy ((==) `on` head) <<<
        sortBy (compare `on` head) <<<
        filter (not <<< null) $ ws

searchTermsFromPartial :: [Char] -> PartialTermIndex -> Tuple Boolean [[Char]]
searchTermsFromPartial s d = findTerms s d
  where
    flattenValues = (<$>) (s ++) <<< concatMap fst <<< values

    findTerms [] (D d') = Tuple true (flattenValues d')
    findTerms (x:xs) (D d') =
      case lookup x d' of
            Just (Tuple _ d'') -> findTerms xs d''
            Nothing -> Tuple false (flattenValues d')

createIndex :: Doc -> Tuple Index PartialTermIndex
createIndex doc = Tuple index (createPartialTermIndex (keys index))
  where index = createTermIndex doc


bug fix

bug fix

module KanColle.DamageAnalysis.DamageAnalysis
  ( analyzeBattle
  , analyzeNightBattle

  , analyzeSTFBattle
  , analyzeCTFBattle
  , analyzeTECFBattle
  , analyzeCombinedNightBattle

  , analyzeAbyssalCTFBattle
  , analyzeAbyssalCTFNightBattle
  ) where

import Prelude
import Data.Array
import Data.Tuple
import Data.Maybe
import Data.Unfoldable
import KanColle.KCAPI.Battle
import KanColle.Util

import KanColle.DamageAnalysis.DamageVector
import KanColle.DamageAnalysis.Stages
import KanColle.DamageAnalysis.Types

normalSplit :: forall a. Array a -> LR (Array a)
normalSplit = fleetSplit false

-- in KCAPI there are cases where the length of the HP array
-- is neither 7 or 13, and it seems terminating "-1" elements
-- have a chance to disappear, so instead of using data from KCAPI
-- directly, we make sure the array is of the correct length
-- by applying this wrapper. "Nothing" will be appended to the
-- end of the list if the length is insufficient
ensureHpsLen :: Int -> Array (Maybe Int) -> Array (Maybe Int)
ensureHpsLen expectLen xs = case expectLen `compare` actualLen of
    LT -> throwWith "ensureHpsLen: array length is longer than expected"
    EQ -> xs
    GT -> (xs <> replicate (expectLen - actualLen) Nothing)
  where
    actualLen = length xs

-- get initial fleet info
getInitFleet :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo Ship
getInitFleet ds battle = { main: allyShips, enemy: enemyShips }
  where
    nowHps = normalSplit (ensureHpsLen 12 $ getInitHps battle)
    allyNowHps = nowHps.left
    enemyNowHps = nowHps.right

    maxHps = normalSplit (ensureHpsLen 12 $ getMaxHps battle)
    allyMaxHps = maxHps.left
    enemyMaxHps = maxHps.right

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    allyShips :: FleetInfo Ship
    allyShips = zipWith addDameCon (zipWith mkShip allyNowHps allyMaxHps) ds

    enemyShips :: FleetInfo Ship
    enemyShips = zipWith mkShip enemyNowHps enemyMaxHps

getInitFleetCombined :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo Ship
getInitFleetCombined ds battle =
    { main: initFleet.main
    , escort: escortShips
    , enemy: initFleet.enemy
    }
  where
    dsSplitted = normalSplit ds
    dsMain = dsSplitted.left
    dsEscort = dsSplitted.right

    initFleet = getInitFleet dsMain battle

    escortNowHps = ensureHpsLen 6 $ getInitHpsCombined battle
    escortMaxHps = ensureHpsLen 6 $ getMaxHpsCombined battle

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    escortShips :: FleetInfo Ship
    escortShips = zipWith addDameCon (zipWith mkShip escortNowHps escortMaxHps) dsEscort

getInitFleetAC :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfoAC Ship
getInitFleetAC ds battle =
    { main: allyShips
    , enemyMain: enemyMainShips
    , enemyEscort: enemyEscortShips
    }
  where
    -- ally vs. enemy main
    allyEMainNowHps = normalSplit (ensureHpsLen 12 $ getInitHps battle)
    allyNowHps = allyEMainNowHps.left
    enemyMainNowHps = allyEMainNowHps.right

    allyEMainMaxHps = normalSplit (ensureHpsLen 12 $ getMaxHps battle)
    allyMaxHps = allyEMainMaxHps.left
    enemyMainMaxHps = allyEMainMaxHps.right

    -- <null> vs. enemy escort
    nullEEscortNowHps = normalSplit (ensureHpsLen 12 $ getInitHpsCombined battle)
    enemyEscortNowHps = nullEEscortNowHps.right

    nullEEscortMaxHps = normalSplit (ensureHpsLen 12 $ getMaxHpsCombined battle)
    enemyEscortMaxHps = nullEEscortMaxHps.right

    mkShip (Just hp) (Just fullHp) = Just
        { hp: hp, fullHp: fullHp
        , sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    allyShips :: FleetInfo Ship
    allyShips = zipWith addDameCon (zipWith mkShip allyNowHps allyMaxHps) ds

    enemyMainShips :: FleetInfo Ship
    enemyMainShips = zipWith mkShip enemyMainNowHps enemyMainMaxHps

    enemyEscortShips :: FleetInfo Ship
    enemyEscortShips = zipWith mkShip enemyEscortNowHps enemyEscortMaxHps

analyzeBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeBattle = analyzeBattleBy battleDV

analyzeNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeNightBattle = analyzeBattleBy nightBattleDV

analyzeBattleBy :: (Battle -> NormalDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> NormalFleetInfo ShipResult
analyzeBattleBy getDVFromBattle ds battle =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    initFleet = getInitFleet ds battle
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeCombinedBattleBy :: (Battle -> CombinedDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> CombinedFleetInfo ShipResult
analyzeCombinedBattleBy getDVFromBattle ds battle =
    dupAsCombinedBattle (zipWith getShipResult')
      `appCombinedBattle` initFleet
      `appCombinedBattle` finalFleet
  where
    initFleet = getInitFleetCombined ds battle
    finalFleet = applyCombinedDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeSTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeSTFBattle = analyzeCombinedBattleBy battleSurfaceTaskForceDV

analyzeCTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeCTFBattle = analyzeCombinedBattleBy battleCarrierTaskForceDV

analyzeTECFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeTECFBattle = analyzeCTFBattle

analyzeCombinedNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeCombinedNightBattle ds b =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    nightBattleInfo = getInitFleetCombined (replicate 6 Nothing <> ds) b
    initFleet =
      { main: nightBattleInfo.escort
      , enemy: nightBattleInfo.enemy
      }
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (nightBattleDV b) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeAbyssalCTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfoAC ShipResult
analyzeAbyssalCTFBattle ds b =
    { main: z (_.main)
    , enemyMain: z (_.enemyMain)
    , enemyEscort: z (_.enemyEscort)
    }
  where
    z prj = zipWith getShipResult' (prj initFleet) (prj finalFleet)
    initFleet = getInitFleetAC ds b
    resultDV = battleEnemyCarrierTaskForceDV b
    finalFleet =
      { main: applyDamageVector resultDV.main initFleet.main
      , enemyMain: applyDamageVector resultDV.enemyMain initFleet.enemyMain
      , enemyEscort: applyDamageVector resultDV.enemyEscort initFleet.enemyEscort
      }
    getShipResult' :: Maybe Ship -> Maybe Ship -> Maybe ShipResult
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeAbyssalCTFNightBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfoAC ShipResult
analyzeAbyssalCTFNightBattle ds b =
    { main: z (_.main)
    , enemyMain: z (_.enemyMain)
    , enemyEscort: z (_.enemyEscort)
    }
  where
    z prj = zipWith getShipResult' (prj allInitFleet) (prj allFinalFleet)
    getShipResult' :: Maybe Ship -> Maybe Ship -> Maybe ShipResult
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

    allInitFleet = getInitFleetAC ds b
    enemySplitted = case getEnemyActiveDeck b of
        1 -> Tuple allInitFleet.enemyMain allInitFleet.enemyEscort
        2 -> Tuple allInitFleet.enemyEscort allInitFleet.enemyMain
        _ -> throwWith "invalid api_active_deck value"
    resultDV = nightBattleDV b
    initFleet = { main: allInitFleet.main, enemy: fst enemySplitted }
    finalFleet = applyNormalDamageVector resultDV initFleet
    allFinalFleet = case getEnemyActiveDeck b of
        1 ->
          { main: finalFleet.main
          , enemyMain: finalFleet.enemy
          , enemyEscort: snd enemySplitted }
        2 ->
          { main: finalFleet.main
          , enemyMain: snd enemySplitted
          , enemyEscort: finalFleet.enemy }
        _ -> throwWith "invalid api_active_deck value"

module KanColle.DamageAnalysis.DamageAnalysis
  ( analyzeBattle
  , analyzeNightBattle

  , analyzeSTFBattle
  , analyzeCTFBattle
  , analyzeTECFBattle
  , analyzeCombinedNightBattle

  , analyzeAbyssalCTFBattle
  , analyzeAbyssalCTFNightBattle
  ) where

import Prelude
import Data.Array
import Data.Tuple
import Data.Maybe
import Data.Unfoldable
import KanColle.KCAPI.Battle
import KanColle.Util

import KanColle.DamageAnalysis.DamageVector
import KanColle.DamageAnalysis.Stages
import KanColle.DamageAnalysis.Types

normalSplit :: forall a. Array a -> LR (Array a)
normalSplit = fleetSplit false

-- in KCAPI there are cases where the length of the HP array
-- is neither 7 or 13, and it seems terminating "-1" elements
-- have a chance to disappear, so instead of using data from KCAPI
-- directly, we make sure the array is of the correct length
-- by applying this wrapper. "Nothing" will be appended to the
-- end of the list if the length is insufficient
ensureHpsLen :: Int -> Array (Maybe Int) -> Array (Maybe Int)
ensureHpsLen expectLen xs = case expectLen `compare` actualLen of
    LT -> throwWith "ensureHpsLen: array length is longer than expected"
    EQ -> xs
    GT -> (xs <> replicate (expectLen - actualLen) Nothing)
  where
    actualLen = length xs

-- get initial fleet info
getInitFleet :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo Ship
getInitFleet ds battle = { main: allyShips, enemy: enemyShips }
  where
    nowHps = normalSplit (ensureHpsLen 12 $ getInitHps battle)
    allyNowHps = nowHps.left
    enemyNowHps = nowHps.right

    maxHps = normalSplit (ensureHpsLen 12 $ getMaxHps battle)
    allyMaxHps = maxHps.left
    enemyMaxHps = maxHps.right

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    allyShips :: FleetInfo Ship
    allyShips = zipWith addDameCon (zipWith mkShip allyNowHps allyMaxHps) ds

    enemyShips :: FleetInfo Ship
    enemyShips = zipWith mkShip enemyNowHps enemyMaxHps

getInitFleetCombined :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo Ship
getInitFleetCombined ds battle =
    { main: initFleet.main
    , escort: escortShips
    , enemy: initFleet.enemy
    }
  where
    dsSplitted = normalSplit ds
    dsMain = dsSplitted.left
    dsEscort = dsSplitted.right

    initFleet = getInitFleet dsMain battle

    escortNowHps = ensureHpsLen 6 $ getInitHpsCombined battle
    escortMaxHps = ensureHpsLen 6 $ getMaxHpsCombined battle

    mkShip (Just hp) (Just fullHp) = Just { hp: hp, fullHp: fullHp, sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    escortShips :: FleetInfo Ship
    escortShips = zipWith addDameCon (zipWith mkShip escortNowHps escortMaxHps) dsEscort

getInitFleetAC :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfoAC Ship
getInitFleetAC ds battle =
    { main: allyShips
    , enemyMain: enemyMainShips
    , enemyEscort: enemyEscortShips
    }
  where
    -- ally vs. enemy main
    allyEMainNowHps = normalSplit (ensureHpsLen 12 $ getInitHps battle)
    allyNowHps = allyEMainNowHps.left
    enemyMainNowHps = allyEMainNowHps.right

    allyEMainMaxHps = normalSplit (ensureHpsLen 12 $ getMaxHps battle)
    allyMaxHps = allyEMainMaxHps.left
    enemyMainMaxHps = allyEMainMaxHps.right

    -- <null> vs. enemy escort
    nullEEscortNowHps = normalSplit (ensureHpsLen 12 $ getMaxHpsCombined battle)
    enemyEscortNowHps = nullEEscortNowHps.right

    nullEEscortMaxHps = normalSplit (ensureHpsLen 12 $ getInitHpsCombined battle)
    enemyEscortMaxHps = nullEEscortMaxHps.right

    mkShip (Just hp) (Just fullHp) = Just
        { hp: hp, fullHp: fullHp
        , sunk: hp <= 0, dameCon: Nothing }
    mkShip _ _ = Nothing

    addDameCon (Just ship) dc = Just (ship { dameCon = dc })
    addDameCon _ _ = Nothing

    allyShips :: FleetInfo Ship
    allyShips = zipWith addDameCon (zipWith mkShip allyNowHps allyMaxHps) ds

    enemyMainShips :: FleetInfo Ship
    enemyMainShips = zipWith mkShip enemyMainNowHps enemyMainMaxHps

    enemyEscortShips :: FleetInfo Ship
    enemyEscortShips = zipWith mkShip enemyEscortNowHps enemyEscortMaxHps

analyzeBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeBattle = analyzeBattleBy battleDV

analyzeNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeNightBattle = analyzeBattleBy nightBattleDV

analyzeBattleBy :: (Battle -> NormalDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> NormalFleetInfo ShipResult
analyzeBattleBy getDVFromBattle ds battle =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    initFleet = getInitFleet ds battle
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeCombinedBattleBy :: (Battle -> CombinedDamageVector)
                -> Array (Maybe DameCon)
                -> Battle
                -> CombinedFleetInfo ShipResult
analyzeCombinedBattleBy getDVFromBattle ds battle =
    dupAsCombinedBattle (zipWith getShipResult')
      `appCombinedBattle` initFleet
      `appCombinedBattle` finalFleet
  where
    initFleet = getInitFleetCombined ds battle
    finalFleet = applyCombinedDamageVector (getDVFromBattle battle) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeSTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeSTFBattle = analyzeCombinedBattleBy battleSurfaceTaskForceDV

analyzeCTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeCTFBattle = analyzeCombinedBattleBy battleCarrierTaskForceDV

analyzeTECFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfo ShipResult
analyzeTECFBattle = analyzeCTFBattle

analyzeCombinedNightBattle :: Array (Maybe DameCon) -> Battle -> NormalFleetInfo ShipResult
analyzeCombinedNightBattle ds b =
    dupAsNormalBattle (zipWith getShipResult')
      `appNormalBattle` initFleet
      `appNormalBattle` finalFleet
  where
    nightBattleInfo = getInitFleetCombined (replicate 6 Nothing <> ds) b
    initFleet =
      { main: nightBattleInfo.escort
      , enemy: nightBattleInfo.enemy
      }
    finalFleet :: NormalFleetInfo Ship
    finalFleet = applyNormalDamageVector (nightBattleDV b) initFleet
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeAbyssalCTFBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfoAC ShipResult
analyzeAbyssalCTFBattle ds b =
    { main: z (_.main)
    , enemyMain: z (_.enemyMain)
    , enemyEscort: z (_.enemyEscort)
    }
  where
    z prj = zipWith getShipResult' (prj initFleet) (prj finalFleet)
    initFleet = getInitFleetAC ds b
    resultDV = battleEnemyCarrierTaskForceDV b
    finalFleet =
      { main: applyDamageVector resultDV.main initFleet.main
      , enemyMain: applyDamageVector resultDV.enemyMain initFleet.enemyMain
      , enemyEscort: applyDamageVector resultDV.enemyEscort initFleet.enemyEscort
      }
    getShipResult' :: Maybe Ship -> Maybe Ship -> Maybe ShipResult
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

analyzeAbyssalCTFNightBattle :: Array (Maybe DameCon) -> Battle -> CombinedFleetInfoAC ShipResult
analyzeAbyssalCTFNightBattle ds b =
    { main: z (_.main)
    , enemyMain: z (_.enemyMain)
    , enemyEscort: z (_.enemyEscort)
    }
  where
    z prj = zipWith getShipResult' (prj allInitFleet) (prj allFinalFleet)
    getShipResult' :: Maybe Ship -> Maybe Ship -> Maybe ShipResult
    getShipResult' ms1 ms2 = getShipResult <$> ms1 <*> ms2

    allInitFleet = getInitFleetAC ds b
    enemySplitted = case getEnemyActiveDeck b of
        1 -> Tuple allInitFleet.enemyMain allInitFleet.enemyEscort
        2 -> Tuple allInitFleet.enemyEscort allInitFleet.enemyMain
        _ -> throwWith "invalid api_active_deck value"
    resultDV = nightBattleDV b
    initFleet = { main: allInitFleet.main, enemy: fst enemySplitted }
    finalFleet = applyNormalDamageVector resultDV initFleet
    allFinalFleet = case getEnemyActiveDeck b of
        1 ->
          { main: finalFleet.main
          , enemyMain: finalFleet.enemy
          , enemyEscort: snd enemySplitted }
        2 ->
          { main: finalFleet.main
          , enemyMain: snd enemySplitted
          , enemyEscort: finalFleet.enemy }
        _ -> throwWith "invalid api_active_deck value"


Add FromSQLValue Boolean instance

Add FromSQLValue Boolean instance

module Database.PostgreSQL
( POSTGRESQL
, PoolConfiguration
, Pool
, Connection
, Query(..)
, class ToSQLRow
, class FromSQLRow
, class ToSQLValue
, class FromSQLValue
, toSQLRow
, fromSQLRow
, toSQLValue
, fromSQLValue
, newPool
, withConnection
, withTransaction
, execute
, query
, scalar
) where

import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (catchError, throwError)
import Control.Monad.Except (runExcept)
import Data.Array (head)
import Data.ByteString (ByteString)
import Data.DateTime.Instant (Instant)
import Data.Either (Either(..))
import Data.Foreign (Foreign, isNull, readArray, readBoolean, readChar, readInt, readString, toForeign, unsafeFromForeign)
import Data.Foreign.Null (writeNull)
import Data.List (List)
import Data.List as List
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
import Data.Traversable (traverse)
import Data.Tuple (fst, Tuple)
import Data.Tuple.Nested ((/\), tuple1, tuple2, tuple3, tuple4, tuple5)
import Prelude

foreign import data POSTGRESQL :: !

-- | PostgreSQL connection pool configuration.
type PoolConfiguration =
    { user              :: String
    , password          :: String
    , host              :: String
    , port              :: Int
    , database          :: String
    , max               :: Int
    , idleTimeoutMillis :: Int
    }

-- | PostgreSQL connection pool.
foreign import data Pool :: *

-- | PostgreSQL connection.
foreign import data Connection :: *

-- | PostgreSQL query with parameter (`$1`, `$2`, …) and return types.
newtype Query i o = Query String

derive instance newtypeQuery :: Newtype (Query i o) _

-- | Convert things to SQL rows.
class ToSQLRow a where
    toSQLRow :: a -> Array Foreign

-- | Convert things from SQL rows.
class FromSQLRow a where
    fromSQLRow :: Array Foreign -> Maybe a

-- | Convert things to SQL values.
class ToSQLValue a where
    toSQLValue :: a -> Foreign

-- | Convert things from SQL values.
class FromSQLValue a where
    fromSQLValue :: Foreign -> Maybe a

instance toSQLRowUnit :: ToSQLRow Unit where
    toSQLRow _ = []

instance toSQLRowTuple :: (ToSQLValue a, ToSQLRow b) => ToSQLRow (Tuple a b) where
    toSQLRow (a /\ b) = [toSQLValue a] <> toSQLRow b

instance fromSQLRowUnit :: FromSQLRow Unit where
    fromSQLRow [] = Just unit
    fromSQLRow _ = Nothing

instance fromSQLRowTuple1 :: (FromSQLValue a) => FromSQLRow (Tuple a Unit) where
    fromSQLRow [a] = tuple1 <$> fromSQLValue a
    fromSQLRow _ = Nothing

instance fromSQLRowTuple2 :: (FromSQLValue a, FromSQLValue b) => FromSQLRow (Tuple a (Tuple b Unit)) where
    fromSQLRow [a, b] = tuple2 <$> fromSQLValue a <*> fromSQLValue b
    fromSQLRow _ = Nothing

instance fromSQLRowTuple3 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c) => FromSQLRow (Tuple a (Tuple b (Tuple c Unit))) where
    fromSQLRow [a, b, c] = tuple3 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c
    fromSQLRow _ = Nothing

instance fromSQLRowTuple4 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c, FromSQLValue d) => FromSQLRow (Tuple a (Tuple b (Tuple c (Tuple d Unit)))) where
    fromSQLRow [a, b, c, d] = tuple4 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c <*> fromSQLValue d
    fromSQLRow _ = Nothing

instance fromSQLRowTuple5 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c, FromSQLValue d, FromSQLValue e) => FromSQLRow (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e Unit))))) where
    fromSQLRow [a, b, c, d, e] = tuple5 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c <*> fromSQLValue d <*> fromSQLValue e
    fromSQLRow _ = Nothing

instance toSQLValueBoolean :: ToSQLValue Boolean where
    toSQLValue = toForeign

instance fromSQLValueBoolean :: FromSQLValue Boolean where
    fromSQLValue = fromRight <<< runExcept <<< readBoolean

instance toSQLValueChar :: ToSQLValue Char where
    toSQLValue = toForeign

instance fromSQLValueChar :: FromSQLValue Char where
    fromSQLValue = fromRight <<< runExcept <<< readChar

instance toSQLValueInt :: ToSQLValue Int where
    toSQLValue = toForeign

instance fromSQLValueInt :: FromSQLValue Int where
    fromSQLValue = fromRight <<< runExcept <<< readInt

instance toSQLValueNumber :: ToSQLValue Number where
    toSQLValue = toForeign

instance toSQLValueString :: ToSQLValue String where
    toSQLValue = toForeign

instance fromSQLValueString :: FromSQLValue String where
    fromSQLValue = fromRight <<< runExcept <<< readString

instance fromSQLValueArray :: (FromSQLValue a) => FromSQLValue (Array a) where
    fromSQLValue = traverse fromSQLValue <=< fromRight <<< runExcept <<< readArray

instance fromSQLValueList :: (FromSQLValue a) => FromSQLValue (List a) where
    fromSQLValue = map List.fromFoldable <<< traverse fromSQLValue <=< fromRight <<< runExcept <<< readArray

instance toSQLValueByteString :: ToSQLValue ByteString where
    toSQLValue = toForeign

instance fromSQLValueByteString :: FromSQLValue ByteString where
    fromSQLValue x
        | unsafeIsBuffer x = Just $ unsafeFromForeign x
        | otherwise = Nothing

instance toSQLValueInstant :: ToSQLValue Instant where
    toSQLValue = instantToString

instance toSQLValueMaybe :: (ToSQLValue a) => ToSQLValue (Maybe a) where
    toSQLValue Nothing = writeNull
    toSQLValue (Just x) = toSQLValue x

instance fromSQLValueMaybe :: (FromSQLValue a) => FromSQLValue (Maybe a) where
    fromSQLValue x | isNull x  = Just Nothing
                   | otherwise = Just <$> fromSQLValue x

foreign import instantToString :: Instant -> Foreign
foreign import unsafeIsBuffer :: ∀ a. a -> Boolean

-- | Create a new connection pool.
foreign import newPool
    :: ∀ eff
     . PoolConfiguration
    -> Aff (postgreSQL :: POSTGRESQL | eff) Pool

-- | Run an action with a connection. The connection is released to the pool
-- | when the action returns.
foreign import withConnection
    :: ∀ eff a
     . Pool
    -> (Connection -> Aff (postgreSQL :: POSTGRESQL | eff) a)
    -> Aff (postgreSQL :: POSTGRESQL | eff) a

-- | Run an action within a transaction. The transaction is committed if the
-- | action returns, and rolled back when the action throws. If you want to
-- | change the transaction mode, issue a separate `SET TRANSACTION` statement
-- | within the transaction.
withTransaction
    :: ∀ eff a
     . Connection
    -> Aff (postgreSQL :: POSTGRESQL | eff) a
    -> Aff (postgreSQL :: POSTGRESQL | eff) a
withTransaction conn action =
    execute conn (Query "BEGIN TRANSACTION") unit
    *> catchError (Right <$> action) (pure <<< Left) >>= case _ of
        Right a -> execute conn (Query "COMMIT TRANSACTION") unit $> a
        Left e -> execute conn (Query "ROLLBACK TRANSACTION") unit *> throwError e

-- | Execute a PostgreSQL query and discard its results.
execute
    :: ∀ i o eff
     . (ToSQLRow i)
    => Connection
    -> Query i o
    -> i
    -> Aff (postgreSQL :: POSTGRESQL | eff) Unit
execute conn (Query sql) values =
    void $ _query conn sql (toSQLRow values)

-- | Execute a PostgreSQL query and return its results.
query
    :: ∀ i o eff
     . (ToSQLRow i, FromSQLRow o)
    => Connection
    -> Query i o
    -> i
    -> Aff (postgreSQL :: POSTGRESQL | eff) (Array o)
query conn (Query sql) values =
    _query conn sql (toSQLRow values)
    >>= traverse (fromSQLRow >>> case _ of
          Just row -> pure row
          Nothing  -> throwError (error "incompatible row structure"))

scalar
    :: ∀ i o eff
     . (ToSQLRow i, FromSQLValue o)
    => Connection
    -> Query i (Tuple o Unit)
    -> i
    -> Aff (postgreSQL :: POSTGRESQL | eff) (Maybe o)
scalar conn sql values =
    query conn sql values
    <#> map fst <<< head

foreign import _query
    :: ∀ eff
     . Connection
    -> String
    -> Array Foreign
    -> Aff (postgreSQL :: POSTGRESQL | eff) (Array (Array Foreign))

fromRight :: ∀ a b. Either a b -> Maybe b
fromRight (Left _) = Nothing
fromRight (Right a) = Just a

module Database.PostgreSQL
( POSTGRESQL
, PoolConfiguration
, Pool
, Connection
, Query(..)
, class ToSQLRow
, class FromSQLRow
, class ToSQLValue
, class FromSQLValue
, toSQLRow
, fromSQLRow
, toSQLValue
, fromSQLValue
, newPool
, withConnection
, withTransaction
, execute
, query
, scalar
) where

import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (catchError, throwError)
import Control.Monad.Except (runExcept)
import Data.Array (head)
import Data.ByteString (ByteString)
import Data.DateTime.Instant (Instant)
import Data.Either (Either(..))
import Data.Foreign (Foreign, isNull, readArray, readChar, readInt, readString, toForeign, unsafeFromForeign)
import Data.Foreign.Null (writeNull)
import Data.List (List)
import Data.List as List
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
import Data.Traversable (traverse)
import Data.Tuple (fst, Tuple)
import Data.Tuple.Nested ((/\), tuple1, tuple2, tuple3, tuple4, tuple5)
import Prelude

foreign import data POSTGRESQL :: !

-- | PostgreSQL connection pool configuration.
type PoolConfiguration =
    { user              :: String
    , password          :: String
    , host              :: String
    , port              :: Int
    , database          :: String
    , max               :: Int
    , idleTimeoutMillis :: Int
    }

-- | PostgreSQL connection pool.
foreign import data Pool :: *

-- | PostgreSQL connection.
foreign import data Connection :: *

-- | PostgreSQL query with parameter (`$1`, `$2`, …) and return types.
newtype Query i o = Query String

derive instance newtypeQuery :: Newtype (Query i o) _

-- | Convert things to SQL rows.
class ToSQLRow a where
    toSQLRow :: a -> Array Foreign

-- | Convert things from SQL rows.
class FromSQLRow a where
    fromSQLRow :: Array Foreign -> Maybe a

-- | Convert things to SQL values.
class ToSQLValue a where
    toSQLValue :: a -> Foreign

-- | Convert things from SQL values.
class FromSQLValue a where
    fromSQLValue :: Foreign -> Maybe a

instance toSQLRowUnit :: ToSQLRow Unit where
    toSQLRow _ = []

instance toSQLRowTuple :: (ToSQLValue a, ToSQLRow b) => ToSQLRow (Tuple a b) where
    toSQLRow (a /\ b) = [toSQLValue a] <> toSQLRow b

instance fromSQLRowUnit :: FromSQLRow Unit where
    fromSQLRow [] = Just unit
    fromSQLRow _ = Nothing

instance fromSQLRowTuple1 :: (FromSQLValue a) => FromSQLRow (Tuple a Unit) where
    fromSQLRow [a] = tuple1 <$> fromSQLValue a
    fromSQLRow _ = Nothing

instance fromSQLRowTuple2 :: (FromSQLValue a, FromSQLValue b) => FromSQLRow (Tuple a (Tuple b Unit)) where
    fromSQLRow [a, b] = tuple2 <$> fromSQLValue a <*> fromSQLValue b
    fromSQLRow _ = Nothing

instance fromSQLRowTuple3 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c) => FromSQLRow (Tuple a (Tuple b (Tuple c Unit))) where
    fromSQLRow [a, b, c] = tuple3 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c
    fromSQLRow _ = Nothing

instance fromSQLRowTuple4 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c, FromSQLValue d) => FromSQLRow (Tuple a (Tuple b (Tuple c (Tuple d Unit)))) where
    fromSQLRow [a, b, c, d] = tuple4 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c <*> fromSQLValue d
    fromSQLRow _ = Nothing

instance fromSQLRowTuple5 :: (FromSQLValue a, FromSQLValue b, FromSQLValue c, FromSQLValue d, FromSQLValue e) => FromSQLRow (Tuple a (Tuple b (Tuple c (Tuple d (Tuple e Unit))))) where
    fromSQLRow [a, b, c, d, e] = tuple5 <$> fromSQLValue a <*> fromSQLValue b <*> fromSQLValue c <*> fromSQLValue d <*> fromSQLValue e
    fromSQLRow _ = Nothing

instance toSQLValueBoolean :: ToSQLValue Boolean where
    toSQLValue = toForeign

instance toSQLValueChar :: ToSQLValue Char where
    toSQLValue = toForeign

instance fromSQLValueChar :: FromSQLValue Char where
    fromSQLValue = fromRight <<< runExcept <<< readChar

instance toSQLValueInt :: ToSQLValue Int where
    toSQLValue = toForeign

instance fromSQLValueInt :: FromSQLValue Int where
    fromSQLValue = fromRight <<< runExcept <<< readInt

instance toSQLValueNumber :: ToSQLValue Number where
    toSQLValue = toForeign

instance toSQLValueString :: ToSQLValue String where
    toSQLValue = toForeign

instance fromSQLValueString :: FromSQLValue String where
    fromSQLValue = fromRight <<< runExcept <<< readString

instance fromSQLValueArray :: (FromSQLValue a) => FromSQLValue (Array a) where
    fromSQLValue = traverse fromSQLValue <=< fromRight <<< runExcept <<< readArray

instance fromSQLValueList :: (FromSQLValue a) => FromSQLValue (List a) where
    fromSQLValue = map List.fromFoldable <<< traverse fromSQLValue <=< fromRight <<< runExcept <<< readArray

instance toSQLValueByteString :: ToSQLValue ByteString where
    toSQLValue = toForeign

instance fromSQLValueByteString :: FromSQLValue ByteString where
    fromSQLValue x
        | unsafeIsBuffer x = Just $ unsafeFromForeign x
        | otherwise = Nothing

instance toSQLValueInstant :: ToSQLValue Instant where
    toSQLValue = instantToString

instance toSQLValueMaybe :: (ToSQLValue a) => ToSQLValue (Maybe a) where
    toSQLValue Nothing = writeNull
    toSQLValue (Just x) = toSQLValue x

instance fromSQLValueMaybe :: (FromSQLValue a) => FromSQLValue (Maybe a) where
    fromSQLValue x | isNull x  = Just Nothing
                   | otherwise = Just <$> fromSQLValue x

foreign import instantToString :: Instant -> Foreign
foreign import unsafeIsBuffer :: ∀ a. a -> Boolean

-- | Create a new connection pool.
foreign import newPool
    :: ∀ eff
     . PoolConfiguration
    -> Aff (postgreSQL :: POSTGRESQL | eff) Pool

-- | Run an action with a connection. The connection is released to the pool
-- | when the action returns.
foreign import withConnection
    :: ∀ eff a
     . Pool
    -> (Connection -> Aff (postgreSQL :: POSTGRESQL | eff) a)
    -> Aff (postgreSQL :: POSTGRESQL | eff) a

-- | Run an action within a transaction. The transaction is committed if the
-- | action returns, and rolled back when the action throws. If you want to
-- | change the transaction mode, issue a separate `SET TRANSACTION` statement
-- | within the transaction.
withTransaction
    :: ∀ eff a
     . Connection
    -> Aff (postgreSQL :: POSTGRESQL | eff) a
    -> Aff (postgreSQL :: POSTGRESQL | eff) a
withTransaction conn action =
    execute conn (Query "BEGIN TRANSACTION") unit
    *> catchError (Right <$> action) (pure <<< Left) >>= case _ of
        Right a -> execute conn (Query "COMMIT TRANSACTION") unit $> a
        Left e -> execute conn (Query "ROLLBACK TRANSACTION") unit *> throwError e

-- | Execute a PostgreSQL query and discard its results.
execute
    :: ∀ i o eff
     . (ToSQLRow i)
    => Connection
    -> Query i o
    -> i
    -> Aff (postgreSQL :: POSTGRESQL | eff) Unit
execute conn (Query sql) values =
    void $ _query conn sql (toSQLRow values)

-- | Execute a PostgreSQL query and return its results.
query
    :: ∀ i o eff
     . (ToSQLRow i, FromSQLRow o)
    => Connection
    -> Query i o
    -> i
    -> Aff (postgreSQL :: POSTGRESQL | eff) (Array o)
query conn (Query sql) values =
    _query conn sql (toSQLRow values)
    >>= traverse (fromSQLRow >>> case _ of
          Just row -> pure row
          Nothing  -> throwError (error "incompatible row structure"))

scalar
    :: ∀ i o eff
     . (ToSQLRow i, FromSQLValue o)
    => Connection
    -> Query i (Tuple o Unit)
    -> i
    -> Aff (postgreSQL :: POSTGRESQL | eff) (Maybe o)
scalar conn sql values =
    query conn sql values
    <#> map fst <<< head

foreign import _query
    :: ∀ eff
     . Connection
    -> String
    -> Array Foreign
    -> Aff (postgreSQL :: POSTGRESQL | eff) (Array (Array Foreign))

fromRight :: ∀ a b. Either a b -> Maybe b
fromRight (Left _) = Nothing
fromRight (Right a) = Just a


Drop Helpers.purs

Drop Helpers.purs

module Pux.Routing.Bob.Helpers where

import Prelude
import Pux.Routing.Bob as Pux.Routing.Bob
import Control.Monad.Eff (Eff)
import DOM (DOM)
import Data.Bifunctor (bimap, class Bifunctor)
import Data.Bifunctor.Wrap (Wrap(Wrap), unwrap)
import Data.Generic (class Generic)
import Pux.Html (a, Html, Attribute)
import Pux.Html.Attributes (href)
import Pux.Html.Events (onClick)
import Pux.Routing.Bob (RouterAction(Route))
import Routing.Bob (Router, toUrl)
import Signal (Signal, (~>))

data RouteOrAction routes actions
  = RouterAction (RouterAction routes)
  | RawAction actions

instance bifunctorRouteOrAction :: Bifunctor RouteOrAction where
  bimap f _ (RouterAction r) =
    RouterAction (f <$> r)
  bimap _ h (RawAction a) =
    RawAction (h a)

type HtmlRouteOrAction route rawAction = Html (RouteOrAction route rawAction)

newtype RoutingContext route route' =
  RoutingContext
    { router :: Router route'
    , addContext :: (route -> route')
    }

instance semigroupoidRoutingContext :: Semigroupoid RoutingContext where
  compose (RoutingContext { router: r, addContext: c })
          (RoutingContext { router: r', addContext: c' }) =
    RoutingContext { router: r, addContext: c <<< c' }

routingContext :: forall route route'. (Generic route') =>
                  Router route' ->
                  (route -> route') ->
                  RoutingContext route route'
routingContext router addContext = RoutingContext { router, addContext }

idRoutingContext :: forall route.
                    Router route ->
                    RoutingContext route route
idRoutingContext router = RoutingContext { router, addContext: id }

type View route rawAction state =
  forall route'. (Generic route') =>
  RoutingContext route route' ->
  state ->
  HtmlRouteOrAction route' rawAction

link :: forall action route route'. (Generic route') =>
        RoutingContext route route' ->
        route ->
        Array (Attribute (RouteOrAction route action)) ->
        Array (HtmlRouteOrAction route action) ->
        HtmlRouteOrAction route' action
link (RoutingContext rc) route attrs children =
  a attrs' children'
 where
  route' = rc.addContext route
  attrs' =
    [ href (toUrl rc.router route')
    , onClick (const <<< RouterAction <<< Route $ route')
    ] <> ((bimap rc.addContext id <$> _) <$> attrs)
  children' = ((bimap rc.addContext id <$> _) <$> children)

newtype HtmlWrapper route rawAction = HtmlWrapper (Html (RouteOrAction route rawAction))

unwrapHtml :: forall route rawAction. HtmlWrapper route rawAction -> Html (RouteOrAction route rawAction)
unwrapHtml (HtmlWrapper html) = html

instance bifunctorHtmlWrapper :: Bifunctor HtmlWrapper where
  bimap f g (HtmlWrapper html) =
    HtmlWrapper (bimap f g <$> html)

instance functorHtmlWrapper :: Functor (HtmlWrapper r) where
  map f = unwrap <<< map f <<< Wrap

-- | Creates a signal with current location (`UrlChanged String`) which should
-- | be passed to `Pux.Routing.Bob.update`
sampleUrl :: forall action route eff.
               Eff (dom :: DOM | eff) (Signal (RouteOrAction route action))
sampleUrl = Pux.Routing.Bob.sampleUrl RouterAction


dismiss button adding button classes

dismiss button adding button classes

{-
Copyright 2017 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Setups.Dialog where

import SlamData.Prelude

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA

import SlamData.Render.ClassName as CN
import SlamData.Render.Icon as I

type DialogOptions s p i =
  { onDismiss ∷ H.Action i
  , onConfirm ∷ s → H.Action i
  , classes ∷ Array HH.ClassName
  , selection ∷ Maybe s
  , isSelectable ∷ s → Boolean
  , title ∷ Array (H.HTML p i)
  , content ∷ Array (H.HTML p i)
  }

pickerDialog ∷ forall s p i. DialogOptions s p i → H.HTML p i
pickerDialog opts =
  HH.div
    [ HP.classes ([ HH.ClassName "sd-picker-dialog" ] <> opts.classes) ]
    [ HH.div
        [ HP.classes [ HH.ClassName "sd-picker-dialog-title" ] ]
        [ HH.h1_ opts.title
        , HH.button
            [ HP.classes [ CN.btn, CN.btnDefault, HH.ClassName "sd-dismiss-button" ]
            , HP.title "Dismiss"
            , ARIA.label "Dismiss"
            , HE.onClick $ HE.input_ opts.onDismiss
            ]
            [ I.closeSm ]
        ]
    , HH.div
        [ HP.classes [ HH.ClassName "sd-picker-dialog-content" ] ]
        opts.content
    , HH.div
        [ HP.classes [ HH.ClassName "sd-picker-dialog-toolbar" ] ]
        [ HH.button
            [ HP.classes [ CN.btn, CN.btnDefault ]
            , ARIA.label "Dismiss"
            , HE.onClick $ HE.input_ opts.onDismiss
            ]
            [ HH.text "Dismiss" ]
        , HH.button
            ([ HP.classes [ CN.btn, CN.btnPrimary ]
            , ARIA.label ""
            ] <>
              case opts.selection of
                Just sel | opts.isSelectable sel →
                  [ HE.onClick $ HE.input_ $ opts.onConfirm sel
                  , HP.disabled false
                  ]
                _ →
                  [ HP.disabled true ])
            [ HH.text "Confirm" ]
        ]
    ]

{-
Copyright 2017 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Setups.Dialog where

import SlamData.Prelude

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA

import SlamData.Render.ClassName as CN
import SlamData.Render.Icon as I

type DialogOptions s p i =
  { onDismiss ∷ H.Action i
  , onConfirm ∷ s → H.Action i
  , classes ∷ Array HH.ClassName
  , selection ∷ Maybe s
  , isSelectable ∷ s → Boolean
  , title ∷ Array (H.HTML p i)
  , content ∷ Array (H.HTML p i)
  }

pickerDialog ∷ forall s p i. DialogOptions s p i → H.HTML p i
pickerDialog opts =
  HH.div
    [ HP.classes ([ HH.ClassName "sd-picker-dialog" ] <> opts.classes) ]
    [ HH.div
        [ HP.classes [ HH.ClassName "sd-picker-dialog-title" ] ]
        [ HH.h1_ opts.title
        , HH.button
            [ HP.classes [ HH.ClassName "sd-dismiss-button" ]
            , HP.title "Dismiss"
            , ARIA.label "Dismiss"
            , HE.onClick $ HE.input_ opts.onDismiss
            ]
            [ I.closeSm ]
        ]
    , HH.div
        [ HP.classes [ HH.ClassName "sd-picker-dialog-content" ] ]
        opts.content
    , HH.div
        [ HP.classes [ HH.ClassName "sd-picker-dialog-toolbar" ] ]
        [ HH.button
            [ HP.classes [ CN.btn, CN.btnDefault ]
            , ARIA.label "Dismiss"
            , HE.onClick $ HE.input_ opts.onDismiss
            ]
            [ HH.text "Dismiss" ]
        , HH.button
            ([ HP.classes [ CN.btn, CN.btnPrimary ]
            , ARIA.label ""
            ] <>
              case opts.selection of
                Just sel | opts.isSelectable sel →
                  [ HE.onClick $ HE.input_ $ opts.onConfirm sel
                  , HP.disabled false
                  ]
                _ →
                  [ HP.disabled true ])
            [ HH.text "Confirm" ]
        ]
    ]


resolve confiliction

resolve confiliction

remove <<<<<<< HEAD =======

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Viz.Component (vizComponent) where

import SlamData.Prelude

import Control.Monad.Eff.Exception (Error)

import Data.Argonaut (JArray, JCursor)
import Data.Array (length, null, cons, index)
import Data.Int as Int
import Data.Lens as Lens
import Data.Lens ((.~), (^?))
import Data.List as L
import Data.Map as M
import Data.Set as Set

import CSS.Geometry (marginBottom)
import CSS.Size (px)

import Halogen as H
import Halogen.CustomProps as Cp
import Halogen.HTML.CSS.Indexed as CSS
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Effects (Slam)
import SlamData.Form.Select (Select, autoSelect, newSelect, (⊝), ifSelected, trySelect', _value)
import SlamData.Quasar.Query as Quasar
import SlamData.Render.Common (row)
import SlamData.Render.CSS as Rc
import SlamData.Workspace.Card.CardType (CardType(Viz))
import SlamData.Workspace.Card.Chart.Aggregation (aggregationSelect)
import SlamData.Workspace.Card.Chart.Axis (analyzeJArray, Axis)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration, depends, dependsOnArr)
import SlamData.Workspace.Card.Chart.ChartType (ChartType(..), isPie, isArea)
import SlamData.Workspace.Card.Common.Render (renderLowLOD)
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Port as P
import SlamData.Workspace.Card.Viz.Component.Query (QueryC, Query(..))
import SlamData.Workspace.Card.Viz.Component.State as VCS
import SlamData.Workspace.Card.Viz.Form.Component (formComponent)
import SlamData.Workspace.Card.Viz.Form.Component as Form
import SlamData.Workspace.LevelOfDetails (LevelOfDetails(..))

type VizHTML = H.ParentHTML Form.StateP QueryC Form.QueryP Slam ChartType
type VizDSL = H.ParentDSL VCS.State Form.StateP QueryC Form.QueryP Slam ChartType

-- | How does this module work?
-- | + Take a TaggedResource case of Port
-- | + Check that resource exists and if so analyze sample to extract Map from
-- |   JCursors to Axes otherwise leave it Map.empty and set available chart types
-- |   to Set.empty. Following steps don't do anything useful if sample is empty.
-- |   Localized in first part of EvalCard handler and updateForm function.
-- | + Load all resource and if it's not too big produce output port
-- |   Second part of EvalCard handler
-- |
-- | + Output port is response of currently active subcomponent which is `Form`
-- | + Form's state (ChartConfiguration) is record with `dimensions`,
-- |   `aggregations`, `series` and `measures` fields.
-- |   These fields are arrays of `Select JCursor`  where `Select α`
-- |   Is model of html combobox with maybe selected α and list of α choices.
-- | + Form can render any kind of `ChartConfiguration` and has weird logic
-- |   for doing this :)
-- |
-- | + Peeking form signals and running CardEval call `configure` func
-- |   (second through `updateForms`)
-- | + `configure` takes all subcomponent configuration and filters them
-- |   e.g. it removes already selected in first measure combobox value from
-- |   available to select choices of second measure combobox -->
-- |   nonsense output is forbidden (one shouldn't be able to make chart
-- |   from `foo` to `foo` groupped by `foo`)
-- | + After filtering (That's important!) previoiusly selected values must
-- |   be set with func `setPreviousValueFrom`.
-- | + Then we have updated config and set it back as subcomponent state.
-- |
-- | About `needToUpdate`
-- | This flag is set when we need to update `records` and `sample` fields.
-- | Basically it's true after parent in deck has changed its output.
-- | And it's false when we just re`configure`d subcomponents.
-- |
-- |   >>> TODO: update this note, or fix the code to restore the old needToUpdate
-- |       logic, if needed. -js
-- |
-- | cryogenian 04/29/2016

vizComponent ∷ H.Component CC.CardStateP CC.CardQueryP Slam
vizComponent = CC.makeCardComponent
  { cardType: Viz
  , component: H.parentComponent { render, eval, peek: Just peek }
  , initialState: H.parentState VCS.initialState
  , _State: CC._VizState
  , _Query: CC.makeQueryPrism' CC._VizQuery
  }

render ∷ VCS.State → VizHTML
render state =
  HH.div_
    [ renderHighLOD state
    , renderLowLOD B.glyphiconPicture left state.levelOfDetails
    ]

renderHighLOD ∷ VCS.State → VizHTML
renderHighLOD state =
    HH.div
      [ HP.classes
          $ [ Rc.cardInput, HH.className "card-input-maximum-lod" ]
          ⊕ (guard (state.levelOfDetails ≠ High) $> B.hidden)
      ]
      [ renderEmpty $ not Set.isEmpty state.availableChartTypes
      , renderForm state
      ]

renderEmpty ∷ Boolean → VizHTML
renderEmpty hidden =
  HH.div
    [ HP.classes
        $ [ B.alert, B.alertDanger ]
        ⊕ (guard hidden $> B.hide)
    , CSS.style $ marginBottom $ px 12.0
    ]
    [ HH.text "There is no available chart for this dataset" ]

renderForm ∷ VCS.State → VizHTML
renderForm state =
  HH.div
    [ HP.classes
        $ [ Rc.vizCardEditor ]
        ⊕ (guard hidden $> B.hide)
    ]
    [ renderChartTypeSelector state
    , renderChartConfiguration state
    ]
  where
  hidden ∷ Boolean
  hidden = Set.isEmpty state.availableChartTypes

renderChartTypeSelector ∷ VCS.State → VizHTML
renderChartTypeSelector state =
  HH.div
    [ HP.classes [ Rc.vizChartTypeSelector ] ]
    $ foldl (foldFn state.chartType) empty state.availableChartTypes
  where
  foldFn ∷ ChartType → Array VizHTML → ChartType → Array VizHTML
  foldFn selected accum current =
    flip cons accum $
      HH.img
        [ HP.src $ src current
        , HP.classes
            $ [ cls state.chartType ]
            ⊕ (guard (selected ≡ current) $> B.active)
        , HE.onClick (HE.input_ (right ∘ SetChartType current))
        ]

  src ∷ ChartType → String
  src Pie = "img/pie.svg"
  src Line = "img/line.svg"
  src Bar = "img/bar.svg"
  src Area = "img/area.svg"

  cls ∷ ChartType → HH.ClassName
  cls Pie = Rc.pieChartIcon
  cls Line = Rc.lineChartIcon
  cls Bar = Rc.barChartIcon
  cls Area = Rc.areaChartIcon

renderChartConfiguration ∷ VCS.State → VizHTML
renderChartConfiguration state =
  HH.div
    [ HP.classes [ Rc.vizChartConfiguration ] ]
    [ renderTab Pie
    , renderTab Line
    , renderTab Bar
    , renderTab Area
    , renderDimensions state
    ]
  where
  renderTab ∷ ChartType → VizHTML
  renderTab ty =
    showIf (state.chartType ≡ ty)
    [ HH.slot ty \_ →
        { component: formComponent
        , initialState: H.parentState Form.initialState
        }
    ]

  showIf ∷ Boolean → Array VizHTML → VizHTML
  showIf ok content = HH.div [ HP.classes $ (guard (not ok) $> B.hide) ] content

renderDimensions ∷ VCS.State → VizHTML
renderDimensions state =
  row
  [ intChartInput Rc.axisLabelParam "Axis label angle"
      (_.axisLabelAngle ⋙ show) RotateAxisLabel (isPie state.chartType)
  , intChartInput Rc.axisLabelParam "Axis font size"
      (_.axisLabelFontSize ⋙ show) SetAxisFontSize (isPie state.chartType)
  , boolChartInput Rc.chartDetailParam "If stack"
      (_.areaStacked ⋙ show) SetStacked (not $ isArea state.chartType)
  , boolChartInput Rc.chartDetailParam "If smooth"
      (_.smooth ⋙ show) SetSmooth (not $ isArea state.chartType)
  ]
  where
  intChartInput
    ∷ HH.ClassName
    → String
    → (VCS.State → String)
    → (Int → Unit → Query Unit)
    → Boolean → VizHTML
  intChartInput cls labelText valueFromState queryCtor isHidden =
    HH.form
      [ HP.classes
          $ [ B.colXs6, cls ]
          ⊕ (guard isHidden $> B.hide)
      , Cp.nonSubmit
      ]
      [ label labelText
      , HH.input
          [ HP.classes [ B.formControl ]
          , HP.value $ valueFromState state
          , ARIA.label labelText
          , HE.onValueInput
              $ pure ∘ map (right ∘ flip queryCtor unit) ∘ stringToInt
          ]
      ]

  boolChartInput
    ∷ HH.ClassName
    → String
    → (VCS.State → String)
    → (Boolean → Unit → Query Unit)
    → Boolean → VizHTML
  boolChartInput cls labelText valueFromState queryCtor isHidden =
    HH.form
      [ HP.classes
          $ [ B.colXs6, cls ]
          ⊕ (guard isHidden $> B.hide)
      , Cp.nonSubmit
      ]
      [ label labelText
      , HH.input
          [ HP.classes [ B.formControl ]
          , HP.value $ valueFromState state
          , ARIA.label labelText
          , HE.onValueChange
              $ pure ∘ map (right ∘ flip queryCtor unit) ∘ stringToBool
          ]
      ]

  label ∷ String → VizHTML
  label str = HH.label [ HP.classes [ B.controlLabel ] ] [ HH.text str ]

  showIfNeqZero ∷ ∀ a. (Eq a, Show a, Semiring a) ⇒ a → String
  showIfNeqZero a = if zero ≡ a then "" else show a

  stringToInt ∷ String → Maybe Int
  stringToInt s = if s ≡ "" then Just 0 else Int.fromString s

  stringToBool ∷ String → Maybe Boolean
  stringToBool s = if s ≡ "true" || s ≡ "True" || s ≡ "t" || s ≡ "T" || s ≡ "1" then Just true
                      else Just false

-- Note: need to put running to state
eval ∷ QueryC ~> VizDSL
eval = coproduct cardEval vizEval

vizEval ∷ Query ~> VizDSL
vizEval q = do
  next <- case q of
    SetChartType ct n → H.modify (VCS._chartType .~ ct) $> n
    RotateAxisLabel angle n → H.modify (VCS._axisLabelAngle .~ angle) $> n
    SetAxisFontSize size n → H.modify (VCS._axisLabelFontSize .~ size) $> n
    SetStacked stacked n → H.modify (VCS._areaStacked .~ stacked) $> n
    SetSmooth smooth n → H.modify (VCS._smooth .~ smooth) $> n
  configure
  CC.raiseUpdatedP' CC.EvalModelUpdate
  pure next

cardEval ∷ CC.CardEvalQuery ~> VizDSL
cardEval = case _ of
  CC.EvalCard info output next → do
    for (output ^? Lens._Just ∘ P._ChartOptions) \opts → do
      sample ← either (const []) id <$>
        H.fromAff (Quasar.sample opts.resource 0 20 :: Slam (Either Error JArray))
      if null sample
        then H.modify (VCS._availableChartTypes .~ Set.empty)
        else H.modify (VCS._sample .~ analyzeJArray sample) *> configure
    pure next
  CC.Save k → do
    st ← H.get
    config ← H.query st.chartType $ left $ H.request Form.GetConfiguration
    pure ∘ k $ Card.Viz
      { chartConfig: fromMaybe Form.initialState config
      , options:
          { chartType: st.chartType
          , axisLabelFontSize: st.axisLabelFontSize
          , axisLabelAngle: st.axisLabelAngle
          , areaStacked: st.areaStacked
          , smooth: st.smooth
          }
      }
  CC.Load card next → do
    case card of
      Card.Viz model → do
        let st = VCS.fromModel model
        H.set st
        H.query st.chartType
          $ left
          $ H.action $ Form.SetConfiguration model.chartConfig
        pure unit
      _ → pure unit
    pure next
  CC.SetDimensions dims next → do
    H.modify
      $ VCS._levelOfDetails
      .~ if dims.width < 576.0 ∨ dims.height < 416.0
           then Low
           else High
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

type AxisAccum =
  { category ∷ Array JCursor
  , value ∷ Array JCursor
  , time ∷ Array JCursor
  }

configure ∷ VizDSL Unit
configure = void do
  axises ← getAxises
  pieConf ← getOrInitial Pie
  setConfFor Pie $ pieBarConfiguration axises pieConf
  lineConf ← getOrInitial Line
  setConfFor Line $ lineConfiguration axises lineConf
  barConf ← getOrInitial Bar
  setConfFor Bar $ pieBarConfiguration axises barConf
  areaConf ← getOrInitial Area
  setConfFor Area $ areaConfiguration axises areaConf
  let chartTypes = available axises
  H.modify (VCS._availableChartTypes .~ available axises)
  case Set.toList chartTypes of
    L.Cons ct L.Nil → H.modify (VCS._chartType .~ ct)
    _ → pure unit
  where
  getOrInitial ∷ ChartType → VizDSL ChartConfiguration
  getOrInitial ty =
    map (fromMaybe Form.initialState)
      $ H.query ty
      $ left (H.request Form.GetConfiguration)

  setConfFor ∷ ChartType → ChartConfiguration → VizDSL Unit
  setConfFor ty conf =
    void $ H.query ty $ left $ H.action $ Form.SetConfiguration conf

  available ∷ AxisAccum → Set.Set ChartType
  available axises =
    foldMap Set.singleton
    $ if null axises.value
      then []
      else if not $ null axises.category
           then [Pie, Bar, Line, Area]
           else if (null axises.time) && (length axises.value < 2)
                then []
                else [Line]

  getAxises ∷ VizDSL AxisAccum
  getAxises = do
    sample ← H.gets _.sample
    pure $ foldl axisFolder {category: [], value: [], time: [] } $ M.toList sample

  axisFolder ∷ AxisAccum → Tuple JCursor Axis → AxisAccum
  axisFolder accum (Tuple cursor axis)
    | Ax.isCatAxis axis = accum { category = cons cursor accum.category }
    | Ax.isValAxis axis = accum { value = cons cursor accum.value }
    | Ax.isTimeAxis axis = accum {time = cons cursor accum.time }
    | otherwise = accum

  setPreviousValueFrom
    ∷ ∀ a. (Eq a) ⇒ Maybe (Select a) → Select a → Select a
  setPreviousValueFrom mbSel target  =
    (maybe id trySelect' $ mbSel >>= Lens.view _value) $ target

  pieBarConfiguration ∷ AxisAccum → ChartConfiguration → ChartConfiguration
  pieBarConfiguration axises current =
    let allAxises = axises.category ⊕ axises.time ⊕ axises.value
        categories =
          setPreviousValueFrom (index current.series 0)
          $ autoSelect $ newSelect allAxises
        measures =
          setPreviousValueFrom (index current.measures 0)
          $ autoSelect $ newSelect $ depends categories axises.value
        firstSeries =
          setPreviousValueFrom (index current.series 1)
          $ newSelect $ ifSelected [categories] $ allAxises ⊝ categories
        secondSeries =
          setPreviousValueFrom (index current.series 2)
          $ newSelect $ ifSelected [categories, firstSeries]
          $ allAxises ⊝ categories ⊝ firstSeries
        aggregation =
          setPreviousValueFrom (index current.aggregations 0) aggregationSelect
    in { series: [categories, firstSeries, secondSeries]
       , dimensions: []
       , measures: [measures]
       , aggregations: [aggregation]
       }

  lineConfiguration ∷ AxisAccum → ChartConfiguration → ChartConfiguration
  lineConfiguration axises current =
    let allAxises = (axises.category ⊕ axises.time ⊕ axises.value)
        dimensions =
          setPreviousValueFrom (index current.dimensions 0)
          $ autoSelect $ newSelect $ dependsOnArr axises.value
          -- This is redundant, I've put it here to notify
          -- that this behaviour differs from pieBar and can be changed.
          $ allAxises
        firstMeasures =
          setPreviousValueFrom (index current.measures 0)
          $ autoSelect $ newSelect $ depends dimensions
          $ axises.value ⊝ dimensions
        secondMeasures =
          setPreviousValueFrom (index current.measures 1)
          $ newSelect $ ifSelected [firstMeasures]
          $ depends dimensions
          $ axises.value ⊝ firstMeasures ⊝ dimensions
        firstSeries =
          setPreviousValueFrom (index current.series 0)
          $ newSelect $ ifSelected [dimensions] $ allAxises ⊝ dimensions
        secondSeries =
          setPreviousValueFrom (index current.series 1)
          $ newSelect $ ifSelected [dimensions, firstSeries]
          $ allAxises ⊝ dimensions ⊝ firstSeries
        firstAggregation =
          setPreviousValueFrom (index current.aggregations 0) aggregationSelect
        secondAggregation =
          setPreviousValueFrom (index current.aggregations 1) aggregationSelect
    in { series: [firstSeries, secondSeries]
       , dimensions: [dimensions]
       , measures: [firstMeasures, secondMeasures]
       , aggregations: [firstAggregation, secondAggregation]
       }

  areaConfiguration ∷ AxisAccum → ChartConfiguration → ChartConfiguration
  areaConfiguration axises current =
    let allAxises = (axises.category ⊕ axises.time ⊕ axises.value)
        dimensions =
          setPreviousValueFrom (index current.dimensions 0)
          $ autoSelect $ newSelect $ dependsOnArr axises.value
          -- This is redundant, I've put it here to notify
          -- that this behaviour differs from pieBar and can be changed.
          $ allAxises
        firstMeasures =
          setPreviousValueFrom (index current.measures 0)
          $ autoSelect $ newSelect $ depends dimensions
          $ axises.value ⊝ dimensions
        secondMeasures =
          setPreviousValueFrom (index current.measures 1)
          $ newSelect $ ifSelected [firstMeasures]
          $ depends dimensions
          $ axises.value ⊝ firstMeasures ⊝ dimensions
        firstSeries =
          setPreviousValueFrom (index current.series 0)
          $ newSelect $ ifSelected [dimensions] $ allAxises ⊝ dimensions
        secondSeries =
          setPreviousValueFrom (index current.series 1)
          $ newSelect $ ifSelected [dimensions, firstSeries]
          $ allAxises ⊝ dimensions ⊝ firstSeries
        firstAggregation =
          setPreviousValueFrom (index current.aggregations 0) aggregationSelect
        secondAggregation =
          setPreviousValueFrom (index current.aggregations 1) aggregationSelect
    in { series: [firstSeries, secondSeries]
       , dimensions: [dimensions]
       , measures: [firstMeasures, secondMeasures]
       , aggregations: [firstAggregation, secondAggregation]
       }

peek ∷ ∀ a. H.ChildF ChartType Form.QueryP a → VizDSL Unit
peek _ = configure *> CC.raiseUpdatedP' CC.EvalModelUpdate

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Viz.Component (vizComponent) where

import SlamData.Prelude

import Control.Monad.Eff.Exception (Error)

import Data.Argonaut (JArray, JCursor)
import Data.Array (length, null, cons, index)
import Data.Int as Int
import Data.Lens as Lens
import Data.Lens ((.~), (^?))
import Data.List as L
import Data.Map as M
import Data.Set as Set

import CSS.Geometry (marginBottom)
import CSS.Size (px)

import Halogen as H
import Halogen.CustomProps as Cp
import Halogen.HTML.CSS.Indexed as CSS
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B

import SlamData.Effects (Slam)
import SlamData.Form.Select (Select, autoSelect, newSelect, (⊝), ifSelected, trySelect', _value)
import SlamData.Quasar.Query as Quasar
import SlamData.Render.Common (row)
import SlamData.Render.CSS as Rc
import SlamData.Workspace.Card.CardType (CardType(Viz))
import SlamData.Workspace.Card.Chart.Aggregation (aggregationSelect)
import SlamData.Workspace.Card.Chart.Axis (analyzeJArray, Axis)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration, depends, dependsOnArr)
<<<<<<< HEAD
import SlamData.Workspace.Card.Chart.ChartType (ChartType(..), isPie, isArea)
=======
import SlamData.Workspace.Card.Chart.ChartType (ChartType(..), isPie)
import SlamData.Workspace.Card.Common.Render (renderLowLOD)
>>>>>>> slamdata/master
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Card.Port as P
import SlamData.Workspace.Card.Viz.Component.Query (QueryC, Query(..))
import SlamData.Workspace.Card.Viz.Component.State as VCS
import SlamData.Workspace.Card.Viz.Form.Component (formComponent)
import SlamData.Workspace.Card.Viz.Form.Component as Form
import SlamData.Workspace.LevelOfDetails (LevelOfDetails(..))

type VizHTML = H.ParentHTML Form.StateP QueryC Form.QueryP Slam ChartType
type VizDSL = H.ParentDSL VCS.State Form.StateP QueryC Form.QueryP Slam ChartType

-- | How does this module work?
-- | + Take a TaggedResource case of Port
-- | + Check that resource exists and if so analyze sample to extract Map from
-- |   JCursors to Axes otherwise leave it Map.empty and set available chart types
-- |   to Set.empty. Following steps don't do anything useful if sample is empty.
-- |   Localized in first part of EvalCard handler and updateForm function.
-- | + Load all resource and if it's not too big produce output port
-- |   Second part of EvalCard handler
-- |
-- | + Output port is response of currently active subcomponent which is `Form`
-- | + Form's state (ChartConfiguration) is record with `dimensions`,
-- |   `aggregations`, `series` and `measures` fields.
-- |   These fields are arrays of `Select JCursor`  where `Select α`
-- |   Is model of html combobox with maybe selected α and list of α choices.
-- | + Form can render any kind of `ChartConfiguration` and has weird logic
-- |   for doing this :)
-- |
-- | + Peeking form signals and running CardEval call `configure` func
-- |   (second through `updateForms`)
-- | + `configure` takes all subcomponent configuration and filters them
-- |   e.g. it removes already selected in first measure combobox value from
-- |   available to select choices of second measure combobox -->
-- |   nonsense output is forbidden (one shouldn't be able to make chart
-- |   from `foo` to `foo` groupped by `foo`)
-- | + After filtering (That's important!) previoiusly selected values must
-- |   be set with func `setPreviousValueFrom`.
-- | + Then we have updated config and set it back as subcomponent state.
-- |
-- | About `needToUpdate`
-- | This flag is set when we need to update `records` and `sample` fields.
-- | Basically it's true after parent in deck has changed its output.
-- | And it's false when we just re`configure`d subcomponents.
-- |
-- |   >>> TODO: update this note, or fix the code to restore the old needToUpdate
-- |       logic, if needed. -js
-- |
-- | cryogenian 04/29/2016

vizComponent ∷ H.Component CC.CardStateP CC.CardQueryP Slam
vizComponent = CC.makeCardComponent
  { cardType: Viz
  , component: H.parentComponent { render, eval, peek: Just peek }
  , initialState: H.parentState VCS.initialState
  , _State: CC._VizState
  , _Query: CC.makeQueryPrism' CC._VizQuery
  }

render ∷ VCS.State → VizHTML
render state =
  HH.div_
    [ renderHighLOD state
    , renderLowLOD B.glyphiconPicture left state.levelOfDetails
    ]

renderHighLOD ∷ VCS.State → VizHTML
renderHighLOD state =
    HH.div
      [ HP.classes
          $ [ Rc.cardInput, HH.className "card-input-maximum-lod" ]
          ⊕ (guard (state.levelOfDetails ≠ High) $> B.hidden)
      ]
      [ renderEmpty $ not Set.isEmpty state.availableChartTypes
      , renderForm state
      ]

renderEmpty ∷ Boolean → VizHTML
renderEmpty hidden =
  HH.div
    [ HP.classes
        $ [ B.alert, B.alertDanger ]
        ⊕ (guard hidden $> B.hide)
    , CSS.style $ marginBottom $ px 12.0
    ]
    [ HH.text "There is no available chart for this dataset" ]

renderForm ∷ VCS.State → VizHTML
renderForm state =
  HH.div
    [ HP.classes
        $ [ Rc.vizCardEditor ]
        ⊕ (guard hidden $> B.hide)
    ]
    [ renderChartTypeSelector state
    , renderChartConfiguration state
    ]
  where
  hidden ∷ Boolean
  hidden = Set.isEmpty state.availableChartTypes

renderChartTypeSelector ∷ VCS.State → VizHTML
renderChartTypeSelector state =
  HH.div
    [ HP.classes [ Rc.vizChartTypeSelector ] ]
    $ foldl (foldFn state.chartType) empty state.availableChartTypes
  where
  foldFn ∷ ChartType → Array VizHTML → ChartType → Array VizHTML
  foldFn selected accum current =
    flip cons accum $
      HH.img
        [ HP.src $ src current
        , HP.classes
            $ [ cls state.chartType ]
            ⊕ (guard (selected ≡ current) $> B.active)
        , HE.onClick (HE.input_ (right ∘ SetChartType current))
        ]

  src ∷ ChartType → String
  src Pie = "img/pie.svg"
  src Line = "img/line.svg"
  src Bar = "img/bar.svg"
  src Area = "img/area.svg"

  cls ∷ ChartType → HH.ClassName
  cls Pie = Rc.pieChartIcon
  cls Line = Rc.lineChartIcon
  cls Bar = Rc.barChartIcon
  cls Area = Rc.areaChartIcon

renderChartConfiguration ∷ VCS.State → VizHTML
renderChartConfiguration state =
  HH.div
    [ HP.classes [ Rc.vizChartConfiguration ] ]
    [ renderTab Pie
    , renderTab Line
    , renderTab Bar
    , renderTab Area
    , renderDimensions state
    ]
  where
  renderTab ∷ ChartType → VizHTML
  renderTab ty =
    showIf (state.chartType ≡ ty)
    [ HH.slot ty \_ →
        { component: formComponent
        , initialState: H.parentState Form.initialState
        }
    ]

  showIf ∷ Boolean → Array VizHTML → VizHTML
  showIf ok content = HH.div [ HP.classes $ (guard (not ok) $> B.hide) ] content

renderDimensions ∷ VCS.State → VizHTML
renderDimensions state =
  row
  [ intChartInput Rc.axisLabelParam "Axis label angle"
      (_.axisLabelAngle ⋙ show) RotateAxisLabel (isPie state.chartType)
  , intChartInput Rc.axisLabelParam "Axis font size"
      (_.axisLabelFontSize ⋙ show) SetAxisFontSize (isPie state.chartType)
  , boolChartInput Rc.chartDetailParam "If stack"
      (_.areaStacked ⋙ show) SetStacked (not $ isArea state.chartType)
  , boolChartInput Rc.chartDetailParam "If smooth"
      (_.smooth ⋙ show) SetSmooth (not $ isArea state.chartType)
  ]
  where
  intChartInput
    ∷ HH.ClassName
    → String
    → (VCS.State → String)
    → (Int → Unit → Query Unit)
    → Boolean → VizHTML
  intChartInput cls labelText valueFromState queryCtor isHidden =
    HH.form
      [ HP.classes
          $ [ B.colXs6, cls ]
          ⊕ (guard isHidden $> B.hide)
      , Cp.nonSubmit
      ]
      [ label labelText
      , HH.input
          [ HP.classes [ B.formControl ]
          , HP.value $ valueFromState state
          , ARIA.label labelText
          , HE.onValueInput
              $ pure ∘ map (right ∘ flip queryCtor unit) ∘ stringToInt
          ]
      ]

  boolChartInput
    ∷ HH.ClassName
    → String
    → (VCS.State → String)
    → (Boolean → Unit → Query Unit)
    → Boolean → VizHTML
  boolChartInput cls labelText valueFromState queryCtor isHidden =
    HH.form
      [ HP.classes
          $ [ B.colXs6, cls ]
          ⊕ (guard isHidden $> B.hide)
      , Cp.nonSubmit
      ]
      [ label labelText
      , HH.input
          [ HP.classes [ B.formControl ]
          , HP.value $ valueFromState state
          , ARIA.label labelText
          , HE.onValueChange
              $ pure ∘ map (right ∘ flip queryCtor unit) ∘ stringToBool
          ]
      ]

  label ∷ String → VizHTML
  label str = HH.label [ HP.classes [ B.controlLabel ] ] [ HH.text str ]

  showIfNeqZero ∷ ∀ a. (Eq a, Show a, Semiring a) ⇒ a → String
  showIfNeqZero a = if zero ≡ a then "" else show a

  stringToInt ∷ String → Maybe Int
  stringToInt s = if s ≡ "" then Just 0 else Int.fromString s

  stringToBool ∷ String → Maybe Boolean
  stringToBool s = if s ≡ "true" || s ≡ "True" || s ≡ "t" || s ≡ "T" || s ≡ "1" then Just true
                      else Just false

-- Note: need to put running to state
eval ∷ QueryC ~> VizDSL
eval = coproduct cardEval vizEval

vizEval ∷ Query ~> VizDSL
vizEval q = do
  next <- case q of
    SetChartType ct n → H.modify (VCS._chartType .~ ct) $> n
    RotateAxisLabel angle n → H.modify (VCS._axisLabelAngle .~ angle) $> n
    SetAxisFontSize size n → H.modify (VCS._axisLabelFontSize .~ size) $> n
    SetStacked stacked n → H.modify (VCS._areaStacked .~ stacked) $> n
    SetSmooth smooth n → H.modify (VCS._smooth .~ smooth) $> n
  configure
  CC.raiseUpdatedP' CC.EvalModelUpdate
  pure next

cardEval ∷ CC.CardEvalQuery ~> VizDSL
cardEval = case _ of
  CC.EvalCard info output next → do
    for (output ^? Lens._Just ∘ P._ChartOptions) \opts → do
      sample ← either (const []) id <$>
        H.fromAff (Quasar.sample opts.resource 0 20 :: Slam (Either Error JArray))
      if null sample
        then H.modify (VCS._availableChartTypes .~ Set.empty)
        else H.modify (VCS._sample .~ analyzeJArray sample) *> configure
    pure next
  CC.Save k → do
    st ← H.get
    config ← H.query st.chartType $ left $ H.request Form.GetConfiguration
    pure ∘ k $ Card.Viz
      { chartConfig: fromMaybe Form.initialState config
      , options:
          { chartType: st.chartType
          , axisLabelFontSize: st.axisLabelFontSize
          , axisLabelAngle: st.axisLabelAngle
          , areaStacked: st.areaStacked
          , smooth: st.smooth
          }
      }
  CC.Load card next → do
    case card of
      Card.Viz model → do
        let st = VCS.fromModel model
        H.set st
        H.query st.chartType
          $ left
          $ H.action $ Form.SetConfiguration model.chartConfig
        pure unit
      _ → pure unit
    pure next
  CC.SetDimensions dims next → do
    H.modify
      $ VCS._levelOfDetails
      .~ if dims.width < 576.0 ∨ dims.height < 416.0
           then Low
           else High
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

type AxisAccum =
  { category ∷ Array JCursor
  , value ∷ Array JCursor
  , time ∷ Array JCursor
  }

configure ∷ VizDSL Unit
configure = void do
  axises ← getAxises
  pieConf ← getOrInitial Pie
  setConfFor Pie $ pieBarConfiguration axises pieConf
  lineConf ← getOrInitial Line
  setConfFor Line $ lineConfiguration axises lineConf
  barConf ← getOrInitial Bar
  setConfFor Bar $ pieBarConfiguration axises barConf
  areaConf ← getOrInitial Area
  setConfFor Area $ areaConfiguration axises areaConf
  let chartTypes = available axises
  H.modify (VCS._availableChartTypes .~ available axises)
  case Set.toList chartTypes of
    L.Cons ct L.Nil → H.modify (VCS._chartType .~ ct)
    _ → pure unit
  where
  getOrInitial ∷ ChartType → VizDSL ChartConfiguration
  getOrInitial ty =
    map (fromMaybe Form.initialState)
      $ H.query ty
      $ left (H.request Form.GetConfiguration)

  setConfFor ∷ ChartType → ChartConfiguration → VizDSL Unit
  setConfFor ty conf =
    void $ H.query ty $ left $ H.action $ Form.SetConfiguration conf

  available ∷ AxisAccum → Set.Set ChartType
  available axises =
    foldMap Set.singleton
    $ if null axises.value
      then []
      else if not $ null axises.category
           then [Pie, Bar, Line, Area]
           else if (null axises.time) && (length axises.value < 2)
                then []
                else [Line]

  getAxises ∷ VizDSL AxisAccum
  getAxises = do
    sample ← H.gets _.sample
    pure $ foldl axisFolder {category: [], value: [], time: [] } $ M.toList sample

  axisFolder ∷ AxisAccum → Tuple JCursor Axis → AxisAccum
  axisFolder accum (Tuple cursor axis)
    | Ax.isCatAxis axis = accum { category = cons cursor accum.category }
    | Ax.isValAxis axis = accum { value = cons cursor accum.value }
    | Ax.isTimeAxis axis = accum {time = cons cursor accum.time }
    | otherwise = accum

  setPreviousValueFrom
    ∷ ∀ a. (Eq a) ⇒ Maybe (Select a) → Select a → Select a
  setPreviousValueFrom mbSel target  =
    (maybe id trySelect' $ mbSel >>= Lens.view _value) $ target

  pieBarConfiguration ∷ AxisAccum → ChartConfiguration → ChartConfiguration
  pieBarConfiguration axises current =
    let allAxises = axises.category ⊕ axises.time ⊕ axises.value
        categories =
          setPreviousValueFrom (index current.series 0)
          $ autoSelect $ newSelect allAxises
        measures =
          setPreviousValueFrom (index current.measures 0)
          $ autoSelect $ newSelect $ depends categories axises.value
        firstSeries =
          setPreviousValueFrom (index current.series 1)
          $ newSelect $ ifSelected [categories] $ allAxises ⊝ categories
        secondSeries =
          setPreviousValueFrom (index current.series 2)
          $ newSelect $ ifSelected [categories, firstSeries]
          $ allAxises ⊝ categories ⊝ firstSeries
        aggregation =
          setPreviousValueFrom (index current.aggregations 0) aggregationSelect
    in { series: [categories, firstSeries, secondSeries]
       , dimensions: []
       , measures: [measures]
       , aggregations: [aggregation]
       }

  lineConfiguration ∷ AxisAccum → ChartConfiguration → ChartConfiguration
  lineConfiguration axises current =
    let allAxises = (axises.category ⊕ axises.time ⊕ axises.value)
        dimensions =
          setPreviousValueFrom (index current.dimensions 0)
          $ autoSelect $ newSelect $ dependsOnArr axises.value
          -- This is redundant, I've put it here to notify
          -- that this behaviour differs from pieBar and can be changed.
          $ allAxises
        firstMeasures =
          setPreviousValueFrom (index current.measures 0)
          $ autoSelect $ newSelect $ depends dimensions
          $ axises.value ⊝ dimensions
        secondMeasures =
          setPreviousValueFrom (index current.measures 1)
          $ newSelect $ ifSelected [firstMeasures]
          $ depends dimensions
          $ axises.value ⊝ firstMeasures ⊝ dimensions
        firstSeries =
          setPreviousValueFrom (index current.series 0)
          $ newSelect $ ifSelected [dimensions] $ allAxises ⊝ dimensions
        secondSeries =
          setPreviousValueFrom (index current.series 1)
          $ newSelect $ ifSelected [dimensions, firstSeries]
          $ allAxises ⊝ dimensions ⊝ firstSeries
        firstAggregation =
          setPreviousValueFrom (index current.aggregations 0) aggregationSelect
        secondAggregation =
          setPreviousValueFrom (index current.aggregations 1) aggregationSelect
    in { series: [firstSeries, secondSeries]
       , dimensions: [dimensions]
       , measures: [firstMeasures, secondMeasures]
       , aggregations: [firstAggregation, secondAggregation]
       }

  areaConfiguration ∷ AxisAccum → ChartConfiguration → ChartConfiguration
  areaConfiguration axises current =
    let allAxises = (axises.category ⊕ axises.time ⊕ axises.value)
        dimensions =
          setPreviousValueFrom (index current.dimensions 0)
          $ autoSelect $ newSelect $ dependsOnArr axises.value
          -- This is redundant, I've put it here to notify
          -- that this behaviour differs from pieBar and can be changed.
          $ allAxises
        firstMeasures =
          setPreviousValueFrom (index current.measures 0)
          $ autoSelect $ newSelect $ depends dimensions
          $ axises.value ⊝ dimensions
        secondMeasures =
          setPreviousValueFrom (index current.measures 1)
          $ newSelect $ ifSelected [firstMeasures]
          $ depends dimensions
          $ axises.value ⊝ firstMeasures ⊝ dimensions
        firstSeries =
          setPreviousValueFrom (index current.series 0)
          $ newSelect $ ifSelected [dimensions] $ allAxises ⊝ dimensions
        secondSeries =
          setPreviousValueFrom (index current.series 1)
          $ newSelect $ ifSelected [dimensions, firstSeries]
          $ allAxises ⊝ dimensions ⊝ firstSeries
        firstAggregation =
          setPreviousValueFrom (index current.aggregations 0) aggregationSelect
        secondAggregation =
          setPreviousValueFrom (index current.aggregations 1) aggregationSelect
    in { series: [firstSeries, secondSeries]
       , dimensions: [dimensions]
       , measures: [firstMeasures, secondMeasures]
       , aggregations: [firstAggregation, secondAggregation]
       }

peek ∷ ∀ a. H.ChildF ChartType Form.QueryP a → VizDSL Unit
peek _ = configure *> CC.raiseUpdatedP' CC.EvalModelUpdate


expose chooseN

expose chooseN

{- | This module stores utility functions
 -}
module KanColle.Util
  ( todo
  , throwWith
  , traceLog
  , traceWarn

  , jsonStringify

  , peekSTArrayUnsafe
  , pokeSTArrayUnsafe

  , times
  , chooseN
  , chooseN_FFI

  , unsafeArrIndex
  , unsafeArrHead
  , unsafeArrTail

  , LR
  , lrMap
  , memptyLR
  , lrOnlyLeft
  , lrOnlyRight
  , lrAppend

  , fleetSplit

  , toFixed
  ) where

import Prelude
import Data.Monoid
import Data.Maybe
import Data.Int
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.ST

import Data.Array
import Data.Array.Partial as PA
import Data.Array.ST hiding (peekSTArray, pokeSTArray)
import Data.List as L
import Data.Foldable
import Control.Plus
import Partial.Unsafe
import Data.Function.Uncurried

-- | `JSON.stringify`
foreign import jsonStringify :: forall a. a -> String

foreign import consoleMessage :: forall a b. Int -> a -> (Unit -> b) -> b

-- | throw anything, raise exceptions from pure code
foreign import throwWith :: forall a b. a -> b

unsafeArrIndex :: forall a. Array a -> Int -> a
unsafeArrIndex = unsafePartial unsafeIndex

unsafeArrHead :: forall a. Array a -> a
unsafeArrHead = unsafePartial PA.head

unsafeArrTail :: forall a. Array a -> Array a
unsafeArrTail = unsafePartial PA.tail

-- | use it as a placeholder for any not yet implemented
todo :: forall a b . b -> a
todo _ = throwWith "TODO"

times1p :: forall m. (Semigroup m) => Int -> m -> m
times1p y0 x0 = f x0 (y0 + 1)
  where
    f x y
      | even y = f (x <> x) (y / 2)
      | y == 1 = x
      | otherwise = g (x <> x) ((y - 1) / 2) x
    g x y z
      | even y = g (x <> x) (y / 2) z
      | y == 1 = x <> z
      | otherwise = g (x <> x) ((y - 1) / 2) (x <> z)

-- | replicate a `Monoid` for a given number of times and `mconcat` the result
times :: forall m. (Monoid m) => Int -> m -> m
times 0 _ = mempty
times n m = times1p (n-1) m

-- | similar to Haskell's `Data.List.tails`
-- | e.g. `tails [1,2,3] = [[1,2,3],[2,3],[3],[]]`
tails :: forall a. L.List a -> L.List (L.List a)
tails xs = case xs of
    L.Nil -> L.Cons L.Nil L.Nil
    L.Cons _ tl -> L.Cons xs (tails tl)

-- | `chooseN xs n` non-deterministically chooses `n` values from `xs`.
-- | It is recommended to use only small values on `n` (0,1,2,3).
chooseN :: forall a f. (Foldable f) => f a -> Int -> Array (L.List a)
chooseN xs = L.toUnfoldable <<< pickFrom xsL
  where
    xsL = L.fromFoldable xs
    pickFrom _ 0 = L.Cons L.Nil L.Nil
    pickFrom remaining i = do
      ys <- tails remaining
      case ys of
        L.Nil -> empty
        L.Cons hd tl -> do
          rs <- pickFrom tl (i-1)
          pure (L.Cons hd rs)

chooseN_FFI :: forall a. Fn2 (Array a) Int (Array (Array a))
chooseN_FFI = mkFn2 (\xs n -> L.toUnfoldable <$> chooseN xs n)

-- | `peekSTArray` without array bound checks
foreign import peekSTArrayUnsafe :: forall a h r. STArray h a -> Int -> Eff (st :: ST h | r) a
-- | `pokeSTArray` without array bound checks
foreign import pokeSTArrayUnsafe :: forall a h r. STArray h a -> Int -> a -> Eff (st :: ST h | r) Unit

-- | `console.log` anything
traceLog :: forall a b. a -> (Unit -> b) -> b
traceLog = consoleMessage 0

-- | `console.warn` anything
traceWarn :: forall a b. a -> (Unit -> b) -> b
traceWarn = consoleMessage 1

-- | something that has both "left" part and "right" part
type LR a =
  { left :: a
  , right :: a
  }

-- | `fleetSplit cutHead xs` cuts `xs` into two 6-element arrays.
-- | `xs` has to be of length 12 (or 13 when `cutHead` is true)
-- | if `cutHead` is true, the first value of `xs` is dropped before cutting.
fleetSplit :: forall a. Boolean -> Array a -> LR (Array a)
fleetSplit cutHead xs = if check
    then { left: slice 0 6 ys
         , right: slice 6 12 ys }
    else throwWith "fleetSplit: array length need to be 12 (or 13 on raw)"
  where
    ys = if cutHead
           then (unsafePartial PA.tail xs)
           else xs
    check = length ys == 12

-- | apply a function to both parts of an `LR`
lrMap :: forall a b. (a -> b) -> LR a -> LR b
lrMap f x = { left: f x.left, right: f x.right }

-- | `mempty` for `LR`
memptyLR :: forall m. Monoid m => LR m
memptyLR = {left: mempty, right: mempty}

-- | `append` for `LR`
lrAppend :: forall m. Monoid m => LR m -> LR m -> LR m
lrAppend a b = { left: a.left <> b.left, right: a.right <> b.right }

-- | lift some Monoid that has only left part into `LR`
lrOnlyLeft :: forall m. Monoid m => m -> LR m
lrOnlyLeft l = { left: l, right: mempty }

-- | lift some Monoid that has only right part into `LR`
lrOnlyRight :: forall m. Monoid m => m -> LR m
lrOnlyRight r = { left: mempty, right: r }

foreign import unsafeToFixed :: forall eff. Int -> Number -> Eff eff String

-- from: https://github.com/Jonplussed/purescript-number-format
toFixed :: Int -> Number -> Maybe String
toFixed scale num = runPure (catchException (pure <<< const Nothing) (Just <$> unsafeToFixed scale num))

{- | This module stores utility functions
 -}
module KanColle.Util
  ( todo
  , throwWith
  , traceLog
  , traceWarn

  , jsonStringify

  , peekSTArrayUnsafe
  , pokeSTArrayUnsafe

  , times
  , chooseN

  , unsafeArrIndex
  , unsafeArrHead
  , unsafeArrTail

  , LR
  , lrMap
  , memptyLR
  , lrOnlyLeft
  , lrOnlyRight
  , lrAppend

  , fleetSplit

  , toFixed
  ) where

import Prelude
import Data.Monoid
import Data.Maybe
import Data.Int
import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Control.Monad.ST

import Data.Array
import Data.Array.Partial as PA
import Data.Array.ST hiding (peekSTArray, pokeSTArray)
import Data.List as L
import Data.Foldable
import Control.Plus
import Partial.Unsafe

-- | `JSON.stringify`
foreign import jsonStringify :: forall a. a -> String

foreign import consoleMessage :: forall a b. Int -> a -> (Unit -> b) -> b

-- | throw anything, raise exceptions from pure code
foreign import throwWith :: forall a b. a -> b

unsafeArrIndex :: forall a. Array a -> Int -> a
unsafeArrIndex = unsafePartial unsafeIndex

unsafeArrHead :: forall a. Array a -> a
unsafeArrHead = unsafePartial PA.head

unsafeArrTail :: forall a. Array a -> Array a
unsafeArrTail = unsafePartial PA.tail

-- | use it as a placeholder for any not yet implemented
todo :: forall a b . b -> a
todo _ = throwWith "TODO"

times1p :: forall m. (Semigroup m) => Int -> m -> m
times1p y0 x0 = f x0 (y0 + 1)
  where
    f x y
      | even y = f (x <> x) (y / 2)
      | y == 1 = x
      | otherwise = g (x <> x) ((y - 1) / 2) x
    g x y z
      | even y = g (x <> x) (y / 2) z
      | y == 1 = x <> z
      | otherwise = g (x <> x) ((y - 1) / 2) (x <> z)

-- | replicate a `Monoid` for a given number of times and `mconcat` the result
times :: forall m. (Monoid m) => Int -> m -> m
times 0 _ = mempty
times n m = times1p (n-1) m

-- | similar to Haskell's `Data.List.tails`
-- | e.g. `tails [1,2,3] = [[1,2,3],[2,3],[3],[]]`
tails :: forall a. L.List a -> L.List (L.List a)
tails xs = case xs of
    L.Nil -> L.Cons L.Nil L.Nil
    L.Cons _ tl -> L.Cons xs (tails tl)

-- | `chooseN xs n` non-deterministically chooses `n` values from `xs`.
-- | It is recommended to use only small values on `n` (0,1,2,3).
chooseN :: forall a f. (Foldable f) => f a -> Int -> Array (L.List a)
chooseN xs = L.toUnfoldable <<< pickFrom xsL
  where
    xsL = L.fromFoldable xs
    pickFrom _ 0 = L.Cons L.Nil L.Nil
    pickFrom remaining i = do
      ys <- tails remaining
      case ys of
        L.Nil -> empty
        L.Cons hd tl -> do
          rs <- pickFrom tl (i-1)
          pure (L.Cons hd rs)

-- | `peekSTArray` without array bound checks
foreign import peekSTArrayUnsafe :: forall a h r. STArray h a -> Int -> Eff (st :: ST h | r) a
-- | `pokeSTArray` without array bound checks
foreign import pokeSTArrayUnsafe :: forall a h r. STArray h a -> Int -> a -> Eff (st :: ST h | r) Unit

-- | `console.log` anything
traceLog :: forall a b. a -> (Unit -> b) -> b
traceLog = consoleMessage 0

-- | `console.warn` anything
traceWarn :: forall a b. a -> (Unit -> b) -> b
traceWarn = consoleMessage 1

-- | something that has both "left" part and "right" part
type LR a =
  { left :: a
  , right :: a
  }

-- | `fleetSplit cutHead xs` cuts `xs` into two 6-element arrays.
-- | `xs` has to be of length 12 (or 13 when `cutHead` is true)
-- | if `cutHead` is true, the first value of `xs` is dropped before cutting.
fleetSplit :: forall a. Boolean -> Array a -> LR (Array a)
fleetSplit cutHead xs = if check
    then { left: slice 0 6 ys
         , right: slice 6 12 ys }
    else throwWith "fleetSplit: array length need to be 12 (or 13 on raw)"
  where
    ys = if cutHead
           then (unsafePartial PA.tail xs)
           else xs
    check = length ys == 12

-- | apply a function to both parts of an `LR`
lrMap :: forall a b. (a -> b) -> LR a -> LR b
lrMap f x = { left: f x.left, right: f x.right }

-- | `mempty` for `LR`
memptyLR :: forall m. Monoid m => LR m
memptyLR = {left: mempty, right: mempty}

-- | `append` for `LR`
lrAppend :: forall m. Monoid m => LR m -> LR m -> LR m
lrAppend a b = { left: a.left <> b.left, right: a.right <> b.right }

-- | lift some Monoid that has only left part into `LR`
lrOnlyLeft :: forall m. Monoid m => m -> LR m
lrOnlyLeft l = { left: l, right: mempty }

-- | lift some Monoid that has only right part into `LR`
lrOnlyRight :: forall m. Monoid m => m -> LR m
lrOnlyRight r = { left: mempty, right: r }

foreign import unsafeToFixed :: forall eff. Int -> Number -> Eff eff String

-- from: https://github.com/Jonplussed/purescript-number-format
toFixed :: Int -> Number -> Maybe String
toFixed scale num = runPure (catchException (pure <<< const Nothing) (Just <$> unsafeToFixed scale num))


Use appropriate type for tags constant

Use appropriate type for tags constant

module Mustache where

import Data.StrMap
import Prelude

type Template = String

type Tag = String

foreign import name :: String

foreign import version :: String

foreign import tags :: Array Tag

foreign import parse :: Template -> Array Tag -> Array (Array String)

foreign import render :: Template -> StrMap String -> StrMap String

foreign import escape :: String -> String

module Mustache where

import Data.StrMap
import Prelude

type Template = String

type Tag = String

foreign import name :: String

foreign import version :: String

foreign import tags :: Array String

foreign import parse :: Template -> Array Tag -> Array (Array String)

foreign import render :: Template -> StrMap String -> StrMap String

foreign import escape :: String -> String