paving path to the bronze age

paving path to the bronze age

module Upgrades
  ( upgradeCost
  , upgradeName
  , nextUpgrade
  , canBuyUpgrade
  , upgradeDescription
  , buyUpgrade
  , isInflectionUpgrade
  , inflectionUpgradeMessage
  , cpsFromUpgrades
  , burstFromUpgrades
  ) where

import Prelude
import Data.Foldable (elem, sum, foldl)
import Data.Array (concat)
import Data.Int (toNumber)
import Data.Lens (LensP(), (^.), (+~), (-~), (.~), view)

import Types
import Lenses
import Util

upgradeCost :: Upgrade -> Clicks
upgradeCost (Misc1 n)    = Clicks (upgradeCostPolynomial 10.0 n)
upgradeCost (Misc2 n)    = Clicks (upgradeCostPolynomial 500.0 n)
upgradeCost (Tech1 n)    = Clicks (upgradeCostPolynomial 7500.0 n)
upgradeCost (Tech2 n)    = Clicks (upgradeCostPolynomial 950000.0 n)
upgradeCost (Phil1 n)    = Clicks (upgradeCostPolynomial 8250000.0 n)
upgradeCost (Phil2 n)    = Clicks (upgradeCostPolynomial 52000000.0 n)
upgradeCost (Poli1 n)    = Clicks (upgradeCostPolynomial 800000000.0 n)
upgradeCost (Poli2 n)    = Clicks (upgradeCostPolynomial 6050000000.0 n)
upgradeCost (Science1 n) = Clicks (upgradeCostPolynomial 60050000400.0 n)
upgradeCost (Science2 n) = Clicks (upgradeCostPolynomial 650000700000.0 n)

upgradeCostPolynomial :: Number -> Int -> Number
upgradeCostPolynomial coeff level = upgradeCostModifier level * coeff * 1.2 ^ (toNumber level)

upgradeCostModifier :: Int -> Number
upgradeCostModifier n
  | n <= 10 = 1.5
  | n <= 25 = 1.0
  | n <= 50 = 0.75
  | n <= 75 = 0.5
  | n <= 100 = 0.25
  | otherwise = 0.125

upgradeName :: Upgrade -> Age -> String
upgradeName (Misc1 _) Stone = "language"
upgradeName (Misc2 _) Stone = "spear tips"
upgradeName (Tech1 _) Stone = "fire!"
upgradeName (Tech2 _) Stone = "stone tools"
upgradeName (Phil1 _) Stone = "funeral rites"
upgradeName (Phil2 _) Stone = "cave paintings"
upgradeName (Poli1 _) Stone = "basic fishing"
upgradeName (Poli2 _) Stone = "rudimentary farming"
upgradeName (Science1 _) Stone = "dog domestication"
upgradeName (Science2 _) Stone = "bronze smelting"
upgradeName (Science1 _) Bronze = "abstract numbers"

upgradeDescription :: Upgrade -> Age -> String
upgradeDescription (Misc1 _) Stone = "No more grunt-and-point for you!"
upgradeDescription (Misc2 _) Stone = "Tip: a well-balanced spear is crucial for hunting."
upgradeDescription (Tech1 _) Stone = "We DID start the fire."
upgradeDescription (Tech2 _) Stone = "Never leave the Stone Age without 'em."
upgradeDescription (Phil1 _) Stone = "Funerals are a basic human rite."
upgradeDescription (Phil2 _) Stone = "You're no Picasso, but your paintings will last longer."
upgradeDescription (Poli1 _) Stone = "Fishing for landsharks?"
upgradeDescription (Poli2 _) Stone = "Can I interest you in some delicious BEETS?"
upgradeDescription (Science1 _) Stone = "A Clickonian's best friend."
upgradeDescription (Science2 _) Stone = "The holy grail of the Stone Age, except the real holy grail was made out of wood."
upgradeDescription (Science1 _) Bronze = "You've discovered that two clicks and two dogs both share 'twoness.' You also almost discovered the ultrafilter lemma, but you couldn't write it down fast enough. Because you haven't discovered writing yet."

nextUpgrade :: Upgrade -> Upgrade
nextUpgrade (Misc1 n) = Misc1 (n + 1)
nextUpgrade (Misc2 n) = Misc2 (n + 1)
nextUpgrade (Tech1 n) = Tech1 (n + 1)
nextUpgrade (Tech2 n) = Tech2 (n + 1)
nextUpgrade (Phil1 n) = Phil1 (n + 1)
nextUpgrade (Phil2 n) = Phil2 (n + 1)
nextUpgrade (Poli1 n) = Poli1 (n + 1)
nextUpgrade (Poli2 n) = Poli2 (n + 1)
nextUpgrade (Science1 n) = Science1 (n + 1)
nextUpgrade (Science2 n) = Science2 (n + 1)

canBuyUpgrade :: State -> LensP Upgrades Upgrade -> Boolean
canBuyUpgrade state optic =
  let currClicks = state ^. currentClicks
      currUpgrade = state ^. upgrades <<< optic
      next = nextUpgrade currUpgrade
      nextCost = upgradeCost next
   in currClicks >= nextCost

upgradeBoost :: Upgrade -> Number
upgradeBoost (Misc1 n)    = 0.5 * upgradeBoostModifier n
upgradeBoost (Misc2 n)    = 4.0 * upgradeBoostModifier n
upgradeBoost (Tech1 n)    = 30.0 * upgradeBoostModifier n
upgradeBoost (Tech2 n)    = 400.0 * upgradeBoostModifier n
upgradeBoost (Phil1 n)    = 6000.0 * upgradeBoostModifier n
upgradeBoost (Phil2 n)    = 12220.5 * upgradeBoostModifier n
upgradeBoost (Poli1 n)    = 214592.6 * upgradeBoostModifier n
upgradeBoost (Poli2 n)    = 1712818.2 * upgradeBoostModifier n
upgradeBoost (Science1 n) = 49000000.0 * upgradeBoostModifier n
upgradeBoost (Science2 n) = 100000000.0 * upgradeBoostModifier n

upgradeBoostModifier :: Int -> Number
upgradeBoostModifier n
  | n <= 10 = 1.0
  | n <= 25 = 4.0
  | n <= 50 = 16.0
  | n <= 75 = 64.0
  | n <= 100 = 256.0
  | otherwise = 1024.0

buyUpgrade :: Upgrade -> State -> State
buyUpgrade up@(Misc1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up misc1
buyUpgrade up@(Misc2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up misc2
buyUpgrade up@(Tech1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up tech1
buyUpgrade up@(Tech2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up tech2
buyUpgrade up@(Phil1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up phil1
buyUpgrade up@(Phil2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up phil2
buyUpgrade up@(Poli1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up poli1
buyUpgrade up@(Poli2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up poli2
buyUpgrade up@(Science1 _) = installUpgrade up cpsNumber 0.75
                         <<< installUpgrade up burstNumber 0.3
                         <<< recordPurchase up science1
buyUpgrade up@(Science2 _) = installUpgrade up cpsNumber 0.75
                         <<< installUpgrade up burstNumber 0.3
                         <<< recordPurchase up science2

recordPurchase :: Upgrade -> LensP Upgrades Upgrade -> State -> State
recordPurchase up optic = (currentClicks -~ upgradeCost up)
                      <<< (upgrades <<< optic .~ up)

installUpgrade :: Upgrade -> LensP State Number -> Number -> State -> State
installUpgrade up optic coeff = optic +~ coeff * upgradeBoost up

isInflectionUpgrade :: Upgrade -> Boolean
isInflectionUpgrade up = (up ^. viewLevel) `elem` [10, 25, 50, 75, 100]

inflectionUpgradeMessage :: Upgrade -> Age -> String
inflectionUpgradeMessage up age = upgradeName up age ++ " cost down, boost up"

makeUpgradedState :: Upgrades -> State
makeUpgradedState u = foldl (flip buyUpgrade) initialState upArray
  where
    upArray = concat [ misc1arr, misc2arr, tech1arr, tech2arr, phil1arr
                     , phil2arr, poli1arr, poli2arr, science1arr, science2arr ]
    misc1arr    = Misc1 <$> 1 ... u ^. misc1 <<< viewLevel
    misc2arr    = Misc2 <$> 1 ... u ^. misc2 <<< viewLevel
    tech1arr    = Tech1 <$> 1 ... u ^. tech1 <<< viewLevel
    tech2arr    = Tech2 <$> 1 ... u ^. tech2 <<< viewLevel
    phil1arr    = Phil1 <$> 1 ... u ^. phil1 <<< viewLevel
    phil2arr    = Phil2 <$> 1 ... u ^. phil2 <<< viewLevel
    poli1arr    = Poli1 <$> 1 ... u ^. poli1 <<< viewLevel
    poli2arr    = Poli2 <$> 1 ... u ^. poli2 <<< viewLevel
    science1arr = Science1 <$> 1 ... u ^. science1 <<< viewLevel
    science2arr = Science2 <$> 1 ... u ^. science2 <<< viewLevel

cpsFromUpgrades :: Upgrades -> ClicksPerSecond
cpsFromUpgrades = view cps <<< makeUpgradedState

burstFromUpgrades :: Upgrades -> Clicks
burstFromUpgrades = view burst <<< makeUpgradedState

module Upgrades
  ( upgradeCost
  , upgradeName
  , nextUpgrade
  , canBuyUpgrade
  , upgradeDescription
  , buyUpgrade
  , isInflectionUpgrade
  , inflectionUpgradeMessage
  , cpsFromUpgrades
  , burstFromUpgrades
  ) where

import Prelude
import Data.Foldable (elem, sum, foldl)
import Data.Array (concat)
import Data.Int (toNumber)
import Data.Lens (LensP(), (^.), (+~), (-~), (.~), view)

import Types
import Lenses
import Util

upgradeCost :: Upgrade -> Clicks
upgradeCost (Misc1 n)    = Clicks (upgradeCostPolynomial 10.0 n)
upgradeCost (Misc2 n)    = Clicks (upgradeCostPolynomial 500.0 n)
upgradeCost (Tech1 n)    = Clicks (upgradeCostPolynomial 7500.0 n)
upgradeCost (Tech2 n)    = Clicks (upgradeCostPolynomial 950000.0 n)
upgradeCost (Phil1 n)    = Clicks (upgradeCostPolynomial 8250000.0 n)
upgradeCost (Phil2 n)    = Clicks (upgradeCostPolynomial 52000000.0 n)
upgradeCost (Poli1 n)    = Clicks (upgradeCostPolynomial 800000000.0 n)
upgradeCost (Poli2 n)    = Clicks (upgradeCostPolynomial 6050000000.0 n)
upgradeCost (Science1 n) = Clicks (upgradeCostPolynomial 60050000400.0 n)
upgradeCost (Science2 n) = Clicks (upgradeCostPolynomial 650000700000.0 n)

upgradeCostPolynomial :: Number -> Int -> Number
upgradeCostPolynomial coeff level = upgradeCostModifier level * coeff * 1.2 ^ (toNumber level)

upgradeCostModifier :: Int -> Number
upgradeCostModifier n
  | n <= 10 = 1.5
  | n <= 25 = 1.0
  | n <= 50 = 0.75
  | n <= 75 = 0.5
  | n <= 100 = 0.25
  | otherwise = 0.125

upgradeName :: Upgrade -> Age -> String
upgradeName (Misc1 _) Stone = "language"
upgradeName (Misc2 _) Stone = "spear tips"
upgradeName (Tech1 _) Stone = "fire!"
upgradeName (Tech2 _) Stone = "stone tools"
upgradeName (Phil1 _) Stone = "funeral rites"
upgradeName (Phil2 _) Stone = "cave paintings"
upgradeName (Poli1 _) Stone = "basic fishing"
upgradeName (Poli2 _) Stone = "rudimentary farming"
upgradeName (Science1 _) Stone = "dog domestication"
upgradeName (Science2 _) Stone = "abstract numbers"

upgradeDescription :: Upgrade -> Age -> String
upgradeDescription (Misc1 _) Stone = "No more grunt-and-point for you!"
upgradeDescription (Misc2 _) Stone = "Tip: a well-balanced spear is crucial for hunting."
upgradeDescription (Tech1 _) Stone = "We DID start the fire."
upgradeDescription (Tech2 _) Stone = "Never leave the Stone Age without 'em."
upgradeDescription (Phil1 _) Stone = "Funerals are a basic human rite."
upgradeDescription (Phil2 _) Stone = "You're no Picasso, but your paintings will last longer."
upgradeDescription (Poli1 _) Stone = "Fishing for landsharks?"
upgradeDescription (Poli2 _) Stone = "Can I interest you in some delicious BEETS?"
upgradeDescription (Science1 _) Stone = "A Clickonian's best friend."
upgradeDescription (Science2 _) Stone = "You've discovered that two clicks and two dogs both share 'twoness.' You also almost discovered the ultrafilter lemma, but you couldn't write it down fast enough. Because you haven't discovered writing yet."

nextUpgrade :: Upgrade -> Upgrade
nextUpgrade (Misc1 n) = Misc1 (n + 1)
nextUpgrade (Misc2 n) = Misc2 (n + 1)
nextUpgrade (Tech1 n) = Tech1 (n + 1)
nextUpgrade (Tech2 n) = Tech2 (n + 1)
nextUpgrade (Phil1 n) = Phil1 (n + 1)
nextUpgrade (Phil2 n) = Phil2 (n + 1)
nextUpgrade (Poli1 n) = Poli1 (n + 1)
nextUpgrade (Poli2 n) = Poli2 (n + 1)
nextUpgrade (Science1 n) = Science1 (n + 1)
nextUpgrade (Science2 n) = Science2 (n + 1)

canBuyUpgrade :: State -> LensP Upgrades Upgrade -> Boolean
canBuyUpgrade state optic =
  let currClicks = state ^. currentClicks
      currUpgrade = state ^. upgrades <<< optic
      next = nextUpgrade currUpgrade
      nextCost = upgradeCost next
   in currClicks >= nextCost

upgradeBoost :: Upgrade -> Number
upgradeBoost (Misc1 n)    = 0.5 * upgradeBoostModifier n
upgradeBoost (Misc2 n)    = 4.0 * upgradeBoostModifier n
upgradeBoost (Tech1 n)    = 30.0 * upgradeBoostModifier n
upgradeBoost (Tech2 n)    = 400.0 * upgradeBoostModifier n
upgradeBoost (Phil1 n)    = 6000.0 * upgradeBoostModifier n
upgradeBoost (Phil2 n)    = 12220.5 * upgradeBoostModifier n
upgradeBoost (Poli1 n)    = 214592.6 * upgradeBoostModifier n
upgradeBoost (Poli2 n)    = 1712818.2 * upgradeBoostModifier n
upgradeBoost (Science1 n) = 49000000.0 * upgradeBoostModifier n
upgradeBoost (Science2 n) = 100000000.0 * upgradeBoostModifier n

upgradeBoostModifier :: Int -> Number
upgradeBoostModifier n
  | n <= 10 = 1.0
  | n <= 25 = 4.0
  | n <= 50 = 16.0
  | n <= 75 = 64.0
  | n <= 100 = 256.0
  | otherwise = 1024.0

buyUpgrade :: Upgrade -> State -> State
buyUpgrade up@(Misc1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up misc1
buyUpgrade up@(Misc2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up misc2
buyUpgrade up@(Tech1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up tech1
buyUpgrade up@(Tech2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up tech2
buyUpgrade up@(Phil1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up phil1
buyUpgrade up@(Phil2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up phil2
buyUpgrade up@(Poli1 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up poli1
buyUpgrade up@(Poli2 _) = installUpgrade up cpsNumber 0.75
                      <<< installUpgrade up burstNumber 0.3
                      <<< recordPurchase up poli2
buyUpgrade up@(Science1 _) = installUpgrade up cpsNumber 0.75
                         <<< installUpgrade up burstNumber 0.3
                         <<< recordPurchase up science1
buyUpgrade up@(Science2 _) = installUpgrade up cpsNumber 0.75
                         <<< installUpgrade up burstNumber 0.3
                         <<< recordPurchase up science2

recordPurchase :: Upgrade -> LensP Upgrades Upgrade -> State -> State
recordPurchase up optic = (currentClicks -~ upgradeCost up)
                      <<< (upgrades <<< optic .~ up)

installUpgrade :: Upgrade -> LensP State Number -> Number -> State -> State
installUpgrade up optic coeff = optic +~ coeff * upgradeBoost up

isInflectionUpgrade :: Upgrade -> Boolean
isInflectionUpgrade up = (up ^. viewLevel) `elem` [10, 25, 50, 75, 100]

inflectionUpgradeMessage :: Upgrade -> Age -> String
inflectionUpgradeMessage up age = upgradeName up age ++ " cost down, boost up"

makeUpgradedState :: Upgrades -> State
makeUpgradedState u = foldl (flip buyUpgrade) initialState upArray
  where
    upArray = concat [ misc1arr, misc2arr, tech1arr, tech2arr, phil1arr
                     , phil2arr, poli1arr, poli2arr, science1arr, science2arr ]
    misc1arr    = Misc1 <$> 1 ... u ^. misc1 <<< viewLevel
    misc2arr    = Misc2 <$> 1 ... u ^. misc2 <<< viewLevel
    tech1arr    = Tech1 <$> 1 ... u ^. tech1 <<< viewLevel
    tech2arr    = Tech2 <$> 1 ... u ^. tech2 <<< viewLevel
    phil1arr    = Phil1 <$> 1 ... u ^. phil1 <<< viewLevel
    phil2arr    = Phil2 <$> 1 ... u ^. phil2 <<< viewLevel
    poli1arr    = Poli1 <$> 1 ... u ^. poli1 <<< viewLevel
    poli2arr    = Poli2 <$> 1 ... u ^. poli2 <<< viewLevel
    science1arr = Science1 <$> 1 ... u ^. science1 <<< viewLevel
    science2arr = Science2 <$> 1 ... u ^. science2 <<< viewLevel

cpsFromUpgrades :: Upgrades -> ClicksPerSecond
cpsFromUpgrades = view cps <<< makeUpgradedState

burstFromUpgrades :: Upgrades -> Clicks
burstFromUpgrades = view burst <<< makeUpgradedState


make CursorDirection non-optional when openin cursor

module Database.IndexedDB.IDBIndex.Internal where

import Prelude

import Control.Monad.Aff           (Aff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Foreign                (Foreign, unsafeFromForeign)
import Data.Function.Uncurried      as Fn
import Data.Function.Uncurried     (Fn2, Fn3)
import Data.Maybe                  (Maybe)
import Data.Nullable               (Nullable, toMaybe, toNullable)

import Database.IndexedDB.Core     (INDEXED_DB, CursorDirection, Index, Key, KeyCursor, KeyRange, ObjectStore, ValueCursor)

--------------------
-- INTERFACES
--
class IDBIndex index where
  count :: forall eff. index -> Maybe KeyRange -> Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) Int
  get :: forall a eff. index -> KeyRange -> Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) (Maybe a)
  getAllKeys :: forall eff. index -> Maybe KeyRange -> Maybe Int -> Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) (Array Key)
  getKey :: forall eff. index -> KeyRange -> Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) (Maybe Key)
  openCursor :: forall eff. index -> Maybe KeyRange -> CursorDirection -> Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) ValueCursor
  openKeyCursor :: forall eff. index -> Maybe KeyRange -> CursorDirection -> Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) KeyCursor

--------------------
-- ATTRIBUTES
--
keyPath :: Index -> String
keyPath =
  _keyPath

multiEntry :: Index -> Boolean
multiEntry =
  _multiEntry

name :: Index -> String
name =
  _name

objectStore :: Index -> ObjectStore
objectStore =
  _objectStore

unique :: Index -> Boolean
unique =
  _unique

--------------------
-- INSTANCES
--
instance idbIndexIndex :: IDBIndex Index where
  count index range =
    Fn.runFn2 _count index (toNullable range)

  get index range =
    (toMaybe >>> map unsafeFromForeign) <$> Fn.runFn2 _get index range

  getAllKeys index range count =
    Fn.runFn3 _getAllKeys index (toNullable range) (toNullable count)

  getKey index range =
    toMaybe <$> Fn.runFn2 _getKey index range

  openCursor index range dir =
    Fn.runFn3 _openCursor index (toNullable range) (show dir)

  openKeyCursor index range dir =
    Fn.runFn3 _openKeyCursor index (toNullable range) (show dir)

instance idbIndexObjectStore :: IDBIndex ObjectStore where
  count store range =
    Fn.runFn2 _count store (toNullable range)

  get store range =
    (toMaybe >>> map unsafeFromForeign) <$> Fn.runFn2 _get store range

  getAllKeys store range count =
    Fn.runFn3 _getAllKeys store (toNullable range) (toNullable count)

  getKey store range =
    toMaybe <$> Fn.runFn2 _getKey store range

  openCursor store range dir =
    Fn.runFn3 _openCursor store (toNullable range) (show dir)

  openKeyCursor store range dir =
    Fn.runFn3 _openKeyCursor store (toNullable range) (show dir)

--------------------
-- FFI
--
foreign import _keyPath :: Index -> String

foreign import _multiEntry :: Index -> Boolean

foreign import _name :: Index -> String

foreign import _objectStore :: Index -> ObjectStore

foreign import _unique :: Index -> Boolean

foreign import _count :: forall index eff. Fn2 index (Nullable KeyRange) (Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) Int)

foreign import _get :: forall index eff. Fn2 index KeyRange (Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) (Nullable Foreign))

foreign import _getAllKeys :: forall index eff. Fn3 index (Nullable KeyRange) (Nullable Int) (Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) (Array Key))

foreign import _getKey :: forall index eff. Fn2 index KeyRange (Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) (Nullable Key))

foreign import _openCursor :: forall index eff. Fn3 index (Nullable KeyRange) String (Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) ValueCursor)

foreign import _openKeyCursor :: forall index eff. Fn3 index (Nullable KeyRange) String (Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) KeyCursor)

module Database.IndexedDB.IDBIndex.Internal where

import Prelude

import Control.Monad.Aff           (Aff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Data.Foreign                (Foreign, unsafeFromForeign)
import Data.Function.Uncurried      as Fn
import Data.Function.Uncurried     (Fn2, Fn3)
import Data.Maybe                  (Maybe)
import Data.Nullable               (Nullable, toMaybe, toNullable)

import Database.IndexedDB.Core     (INDEXED_DB, CursorDirection, Index, Key, KeyCursor, KeyRange, ObjectStore, ValueCursor)

--------------------
-- INTERFACES
--
class IDBIndex index where
  count :: forall eff. index -> Maybe KeyRange -> Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) Int
  get :: forall a eff. index -> KeyRange -> Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) (Maybe a)
  getAllKeys :: forall eff. index -> Maybe KeyRange -> Maybe Int -> Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) (Array Key)
  getKey :: forall eff. index -> KeyRange -> Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) (Maybe Key)
  openCursor :: forall eff. index -> Maybe KeyRange -> Maybe CursorDirection -> Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) ValueCursor
  openKeyCursor :: forall eff. index -> Maybe KeyRange -> Maybe CursorDirection -> Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) KeyCursor

--------------------
-- ATTRIBUTES
--
keyPath :: Index -> String
keyPath =
  _keyPath

multiEntry :: Index -> Boolean
multiEntry =
  _multiEntry

name :: Index -> String
name =
  _name

objectStore :: Index -> ObjectStore
objectStore =
  _objectStore

unique :: Index -> Boolean
unique =
  _unique

--------------------
-- INSTANCES
--
instance idbIndexIndex :: IDBIndex Index where
  count index range =
    Fn.runFn2 _count index (toNullable range)

  get index range =
    (toMaybe >>> map unsafeFromForeign) <$> Fn.runFn2 _get index range

  getAllKeys index range count =
    Fn.runFn3 _getAllKeys index (toNullable range) (toNullable count)

  getKey index range =
    toMaybe <$> Fn.runFn2 _getKey index range

  openCursor index range dir =
    Fn.runFn3 _openCursor index (toNullable range) (toNullable dir)

  openKeyCursor index range dir =
    Fn.runFn3 _openKeyCursor index (toNullable range) (toNullable dir)

instance idbIndexObjectStore :: IDBIndex ObjectStore where
  count store range =
    Fn.runFn2 _count store (toNullable range)

  get store range =
    (toMaybe >>> map unsafeFromForeign) <$> Fn.runFn2 _get store range

  getAllKeys store range count =
    Fn.runFn3 _getAllKeys store (toNullable range) (toNullable count)

  getKey store range =
    toMaybe <$> Fn.runFn2 _getKey store range

  openCursor store range dir =
    Fn.runFn3 _openCursor store (toNullable range) (toNullable dir)

  openKeyCursor store range dir =
    Fn.runFn3 _openKeyCursor store (toNullable range) (toNullable dir)

--------------------
-- FFI
--
foreign import _keyPath :: Index -> String

foreign import _multiEntry :: Index -> Boolean

foreign import _name :: Index -> String

foreign import _objectStore :: Index -> ObjectStore

foreign import _unique :: Index -> Boolean

foreign import _count :: forall index eff. Fn2 index (Nullable KeyRange) (Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) Int)

foreign import _get :: forall index eff. Fn2 index KeyRange (Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) (Nullable Foreign))

foreign import _getAllKeys :: forall index eff. Fn3 index (Nullable KeyRange) (Nullable Int) (Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) (Array Key))

foreign import _getKey :: forall index eff. Fn2 index KeyRange (Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) (Nullable Key))

foreign import _openCursor :: forall index eff. Fn3 index (Nullable KeyRange) (Nullable CursorDirection) (Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) ValueCursor)

foreign import _openKeyCursor :: forall index eff. Fn3 index (Nullable KeyRange) (Nullable CursorDirection) (Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) KeyCursor)


Fix failing test

Fix failing test

module Main where

import Debug.Trace

import Control.Monad.Eff

class (Monad m) <= MonadWriter w m where
  tell :: w -> m Unit

testFunctor :: forall m. (Monad m) => m Number -> m Number
testFunctor n = (+) 1 <$> n

test :: forall w m. (Monad m, MonadWriter w m) => w -> m Unit
test w = do
  tell w
  tell w
  tell w

data MTrace a = MTrace (Eff (trace :: Trace) a)

runMTrace :: forall a. MTrace a -> Eff (trace :: Trace) a
runMTrace (MTrace a) = a

instance functorMTrace :: Functor MTrace where
  (<$>) = liftM1

instance applyMTrace :: Apply MTrace where
  (<*>) = ap

instance applicativeMTrace :: Applicative MTrace where
  pure = MTrace <<< return

instance bindMTrace :: Bind MTrace where
  (>>=) m f = MTrace (runMTrace m >>= (runMTrace <<< f))

instance monadMTrace :: Monad MTrace

instance writerMTrace :: MonadWriter String MTrace where
  tell s = MTrace (trace s)

main = runMTrace $ test "Done"

module Main where

import Debug.Trace

import Control.Monad.Eff

class (Monad m) <= MonadWriter w m where
  tell :: w -> m {}

testFunctor :: forall m. (Monad m) => m Number -> m Number
testFunctor n = (+) 1 <$> n

test :: forall w m. (Monad m, MonadWriter w m) => w -> m {}
test w = do
  tell w
  tell w
  tell w

data MTrace a = MTrace (Eff (trace :: Trace) a)

runMTrace :: forall a. MTrace a -> Eff (trace :: Trace) a
runMTrace (MTrace a) = a

instance functorMTrace :: Functor MTrace where
  (<$>) = liftM1

instance applyMTrace :: Apply MTrace where
  (<*>) = ap

instance applicativeMTrace :: Applicative MTrace where
  pure = MTrace <<< return

instance bindMTrace :: Bind MTrace where
  (>>=) m f = MTrace (runMTrace m >>= (runMTrace <<< f))

instance monadMTrace :: Monad MTrace

instance writerMTrace :: MonadWriter String MTrace where
  tell s = MTrace (trace s)

main = runMTrace $ test "Done"


case r.parallel

case r.parallel

{-
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.BuildChart.Bar.Eval
  ( eval
  , module SlamData.Workspace.Card.BuildChart.Bar.Model
  ) where

import SlamData.Prelude

import Data.Argonaut (JArray, Json)
import Data.Array as A
import Data.Lens ((^?))
import Data.Map as M
import Data.Set as Set

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import Quasar.Types (FilePath)

import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Workspace.Card.BuildChart.Common.Eval (type (>>))
import SlamData.Workspace.Card.BuildChart.Common.Eval as BCE
import SlamData.Workspace.Card.BuildChart.Bar.Model (Model, BarR)
import SlamData.Workspace.Card.CardType.ChartType (ChartType(Bar))
import SlamData.Workspace.Card.BuildChart.Aggregation as Ag
import SlamData.Workspace.Card.BuildChart.Axis (Axes)
import SlamData.Workspace.Card.BuildChart.Axis as Ax
import SlamData.Workspace.Card.BuildChart.Semantics (getMaybeString, getValues)
import SlamData.Workspace.Card.BuildChart.ColorScheme (colors)
import SlamData.Workspace.Card.BuildChart.Common.Positioning as BCP
import SlamData.Workspace.Card.Eval.CardEvalT as CET
import SlamData.Workspace.Card.Port as Port

eval
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ Model
  → FilePath
  → Axes
  → CET.CardEvalT m Port.Port
eval Nothing _ _ =
  QE.throw "Please select axis to aggregate"
eval (Just conf) resource axes = do
  records ← BCE.records resource
  pure $ Port.ChartInstructions (buildBar conf records axes) Bar

type BarSeries =
  { name ∷ Maybe String
  , items ∷ String >> Number
  }

type BarStacks =
  { stack ∷ Maybe String
  , series ∷ Array BarSeries
  }

buildBarData ∷ BarR → JArray → Array BarStacks
buildBarData r records = series
  where
  -- | maybe stack >> maybe parallel >> category >> values
  dataMap ∷ Maybe String >> Maybe String >> String >> Array Number
  dataMap =
    foldl dataMapFoldFn M.empty records

  dataMapFoldFn
    ∷ Maybe String >> Maybe String >> String >> Array Number
    → Json
    → Maybe String >> Maybe String >> String >> Array Number
  dataMapFoldFn acc js =
    let
      getMaybeStringFromJson = getMaybeString js
      getValuesFromJson = getValues js
    in case getMaybeStringFromJson r.category of
      Nothing → acc
      Just categoryKey →
        let
          mbStack =
            getMaybeStringFromJson =<< r.stack
          mbParallel =
            getMaybeStringFromJson =<< r.parallel
          values =
            getValuesFromJson $ pure r.value

          alterStackFn
            ∷ Maybe (Maybe String >> String >> Array Number)
            → Maybe (Maybe String >> String >> Array Number)
          alterStackFn Nothing =
            Just $ M.singleton mbParallel $ M.singleton categoryKey values
          alterStackFn (Just parallel) =
            Just $ M.alter alterParallelFn mbParallel parallel

          alterParallelFn
            ∷ Maybe (String >> Array Number)
            → Maybe (String >> Array Number)
          alterParallelFn Nothing =
            Just $ M.singleton categoryKey values
          alterParallelFn (Just category) =
            Just $ M.alter alterCategoryFn categoryKey category

          alterCategoryFn
            ∷ Maybe (Array Number)
            → Maybe (Array Number)
          alterCategoryFn Nothing = Just values
          alterCategoryFn (Just arr) = Just $ arr ⊕ values
        in
          M.alter alterStackFn mbStack acc

  series ∷ Array BarStacks
  series =
    foldMap mkBarStack $ M.toList dataMap

  mkBarStack
    ∷ Maybe String × (Maybe String >> String >> Array Number)
    → Array BarStacks
  mkBarStack (stack × sers) =
    [{ stack
     , series: foldMap mkBarSeries $ M.toList sers
     }]

  mkBarSeries
    ∷ Maybe String × (String >> Array Number)
    → Array BarSeries
  mkBarSeries (name × items) =
    [{ name
     , items: map (Ag.runAggregation r.valueAggregation) items
     }]

buildBar ∷ BarR → JArray → Axes → DSL OptionI
buildBar r records axes = do
  E.tooltip E.triggerAxis

  E.colors colors

  E.xAxis do
    E.axisType xAxisConfig.axisType
    traverse_ E.interval xAxisConfig.interval
    E.items $ map ET.strItem xValues
    E.axisLabel do
      E.rotate r.axisLabelAngle
      E.textStyle do
        E.fontFamily "Ubuntu, sans"

  E.yAxis do
    E.axisType ET.Value
    E.axisLabel $ E.textStyle do
      E.fontFamily "Ubuntu, sans"
    E.axisLine $ E.lineStyle $ E.width 1
    E.splitLine $ E.lineStyle $ E.width 1

  E.legend do
    E.textStyle $ E.fontFamily "Ubuntu, sans"
    case xAxisConfig.axisType of
      ET.Category | A.length seriesNames > 40 → E.hidden
      _ → pure unit
    E.items $ map ET.strItem seriesNames
    E.leftLeft
    E.topBottom

  E.grid BCP.cartesian

  E.series series

  where

  barData ∷ Array BarStacks
  barData = buildBarData r records

  xAxisConfig ∷ Ax.EChartsAxisConfiguration
  xAxisConfig = Ax.axisConfiguration $ Ax.axisType r.category axes

  seriesNames ∷ Array String
  seriesNames =
    A.fromFoldable
      $ foldMap (_.series ⋙ foldMap (_.name ⋙ foldMap Set.singleton ))
        barData

  xValues ∷ Array String
  xValues =
    A.sortBy xSortFn
      $ A.fromFoldable
      $ foldMap (_.series
                 ⋙ foldMap (_.items
                            ⋙ M.keys
                            ⋙ Set.fromFoldable)) barData
  xSortFn ∷ String → String → Ordering
  xSortFn = Ax.compareWithAxisType $ Ax.axisType r.category axes

  series ∷ ∀ i. DSL (bar ∷ ETP.I|i)
  series = for_ barData \stacked →
    for_ stacked.series \serie → E.bar do
      E.buildItems $ for_ xValues \key →
        case M.lookup key serie.items of
          Nothing → E.missingItem
          Just v → E.addItem do
            E.name key
            E.buildValues do
              E.addStringValue key
              E.addValue v
      case r.parallel of
        Just _ → for_ stacked.stack E.stack
        Nothing → E.stack "default stack"
      for_ serie.name E.name

{-
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.BuildChart.Bar.Eval
  ( eval
  , module SlamData.Workspace.Card.BuildChart.Bar.Model
  ) where

import SlamData.Prelude

import Data.Argonaut (JArray, Json)
import Data.Array as A
import Data.Lens ((^?))
import Data.Map as M
import Data.Set as Set

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import Quasar.Types (FilePath)

import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Workspace.Card.BuildChart.Common.Eval (type (>>))
import SlamData.Workspace.Card.BuildChart.Common.Eval as BCE
import SlamData.Workspace.Card.BuildChart.Bar.Model (Model, BarR)
import SlamData.Workspace.Card.CardType.ChartType (ChartType(Bar))
import SlamData.Workspace.Card.BuildChart.Aggregation as Ag
import SlamData.Workspace.Card.BuildChart.Axis (Axes)
import SlamData.Workspace.Card.BuildChart.Axis as Ax
import SlamData.Workspace.Card.BuildChart.Semantics (getMaybeString, getValues)
import SlamData.Workspace.Card.BuildChart.ColorScheme (colors)
import SlamData.Workspace.Card.BuildChart.Common.Positioning as BCP
import SlamData.Workspace.Card.Eval.CardEvalT as CET
import SlamData.Workspace.Card.Port as Port

eval
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ Model
  → FilePath
  → Axes
  → CET.CardEvalT m Port.Port
eval Nothing _ _ =
  QE.throw "Please select axis to aggregate"
eval (Just conf) resource axes = do
  records ← BCE.records resource
  pure $ Port.ChartInstructions (buildBar conf records axes) Bar

type BarSeries =
  { name ∷ Maybe String
  , items ∷ String >> Number
  }

type BarStacks =
  { stack ∷ Maybe String
  , series ∷ Array BarSeries
  }

buildBarData ∷ BarR → JArray → Array BarStacks
buildBarData r records = series
  where
  -- | maybe stack >> maybe parallel >> category >> values
  dataMap ∷ Maybe String >> Maybe String >> String >> Array Number
  dataMap =
    foldl dataMapFoldFn M.empty records

  dataMapFoldFn
    ∷ Maybe String >> Maybe String >> String >> Array Number
    → Json
    → Maybe String >> Maybe String >> String >> Array Number
  dataMapFoldFn acc js =
    let
      getMaybeStringFromJson = getMaybeString js
      getValuesFromJson = getValues js
    in case getMaybeStringFromJson r.category of
      Nothing → acc
      Just categoryKey →
        let
          mbStack =
            getMaybeStringFromJson =<< r.stack
          mbParallel =
            getMaybeStringFromJson =<< r.parallel
          values =
            getValuesFromJson $ pure r.value

          alterStackFn
            ∷ Maybe (Maybe String >> String >> Array Number)
            → Maybe (Maybe String >> String >> Array Number)
          alterStackFn Nothing =
            Just $ M.singleton mbParallel $ M.singleton categoryKey values
          alterStackFn (Just parallel) =
            Just $ M.alter alterParallelFn mbParallel parallel

          alterParallelFn
            ∷ Maybe (String >> Array Number)
            → Maybe (String >> Array Number)
          alterParallelFn Nothing =
            Just $ M.singleton categoryKey values
          alterParallelFn (Just category) =
            Just $ M.alter alterCategoryFn categoryKey category

          alterCategoryFn
            ∷ Maybe (Array Number)
            → Maybe (Array Number)
          alterCategoryFn Nothing = Just values
          alterCategoryFn (Just arr) = Just $ arr ⊕ values
        in
          M.alter alterStackFn mbStack acc

  series ∷ Array BarStacks
  series =
    foldMap mkBarStack $ M.toList dataMap

  mkBarStack
    ∷ Maybe String × (Maybe String >> String >> Array Number)
    → Array BarStacks
  mkBarStack (stack × sers) =
    [{ stack
     , series: foldMap mkBarSeries $ M.toList sers
     }]

  mkBarSeries
    ∷ Maybe String × (String >> Array Number)
    → Array BarSeries
  mkBarSeries (name × items) =
    [{ name
     , items: map (Ag.runAggregation r.valueAggregation) items
     }]

buildBar ∷ BarR → JArray → Axes → DSL OptionI
buildBar r records axes = do
  E.tooltip E.triggerAxis

  E.colors colors

  E.xAxis do
    E.axisType xAxisConfig.axisType
    traverse_ E.interval xAxisConfig.interval
    E.items $ map ET.strItem xValues
    E.axisLabel do
      E.rotate r.axisLabelAngle
      E.textStyle do
        E.fontFamily "Ubuntu, sans"

  E.yAxis do
    E.axisType ET.Value
    E.axisLabel $ E.textStyle do
      E.fontFamily "Ubuntu, sans"
    E.axisLine $ E.lineStyle $ E.width 1
    E.splitLine $ E.lineStyle $ E.width 1

  E.legend do
    E.textStyle $ E.fontFamily "Ubuntu, sans"
    case xAxisConfig.axisType of
      ET.Category | A.length seriesNames > 40 → E.hidden
      _ → pure unit
    E.items $ map ET.strItem seriesNames
    E.leftLeft
    E.topBottom

  E.grid BCP.cartesian

  E.series series

  where

  barData ∷ Array BarStacks
  barData = buildBarData r records

  xAxisConfig ∷ Ax.EChartsAxisConfiguration
  xAxisConfig = Ax.axisConfiguration $ Ax.axisType r.category axes

  seriesNames ∷ Array String
  seriesNames =
    A.fromFoldable
      $ foldMap (_.series ⋙ foldMap (_.name ⋙ foldMap Set.singleton ))
        barData

  xValues ∷ Array String
  xValues =
    A.sortBy xSortFn
      $ A.fromFoldable
      $ foldMap (_.series
                 ⋙ foldMap (_.items
                            ⋙ M.keys
                            ⋙ Set.fromFoldable)) barData
  xSortFn ∷ String → String → Ordering
  xSortFn = Ax.compareWithAxisType $ Ax.axisType r.category axes

  series ∷ ∀ i. DSL (bar ∷ ETP.I|i)
  series = for_ barData \stacked →
    for_ stacked.series \serie → E.bar do
      E.buildItems $ for_ xValues \key →
        case M.lookup key serie.items of
          Nothing → E.missingItem
          Just v → E.addItem do
            E.name key
            E.buildValues do
              E.addStringValue key
              E.addValue v
      for_ stacked.stack E.stack
      for_ serie.name E.name


Atrocious mega buttons

Atrocious mega buttons

module Component.Article where

import Prelude
import Halogen

import  Halogen.HTML.Core (className)
import qualified Halogen.HTML.Indexed as H
import qualified Halogen.HTML.Events.Indexed as E
import qualified Halogen.HTML.Properties.Indexed as P

import Data.Functor.Coproduct (Coproduct())

import Text.Markdown.SlamDown
import Text.Markdown.SlamDown.Html
import Text.Markdown.SlamDown.Parser

import Model

type State = Article

data Query a = Toggle a
             | Load {title :: String, contents :: String} a

data ArticleContents = ArticleContents {title :: String, contents :: String}

data MarkdownSlot = MarkdownSlot

instance ordMarkdownSlot :: Ord MarkdownSlot where
  compare _ _ = EQ

instance eqMarkdownSlot :: Eq MarkdownSlot where
  eq _ _ = true

type FState g = InstalledState State SlamDownState Query SlamDownQuery g MarkdownSlot
type FQuery = Coproduct Query (ChildF MarkdownSlot SlamDownQuery)
type ArticleHTML g = ParentHTML SlamDownState Query SlamDownQuery g MarkdownSlot
type ArticleDSL g = ParentDSL State SlamDownState Query SlamDownQuery g MarkdownSlot

article :: forall g. (Functor g) => Component (FState g) FQuery g
article = parentComponent render eval
  where

  render :: State -> ArticleHTML g
  render (Article state) =
    let title = H.button [ E.onClick (E.input_ Toggle)
                         , P.classes $ map className ["pure-u-1-1", "pure-button", "pure-button-primary"]]
                [H.text state.title] in
    H.div [P.class_ (className "pure-g")]
      if state.visible
      then
        [ title
        , H.div [P.class_ (className "pure-u-1-1")] [H.slot MarkdownSlot \_ -> { initialState: makeSlamDownState $ parseMd state.contents
                                                                               , component: slamDownComponent {browserFeatures: defaultBrowserFeatures, formName: "article-markdown-form"}}]
        ]
      else
         [title]

  eval ::  Natural Query (ArticleDSL g)
  eval (Toggle next) = do
    modify (\(Article s)-> Article (s {visible = not s.visible}))
    pure next
  eval (Load ar next) = do
    modify (\(Article s) -> Article  (s {contents = ar.contents, title = ar.title}))
    pure next

module Component.Article where

import Prelude
import Halogen
import qualified Halogen.HTML.Indexed as H
import qualified Halogen.HTML.Events.Indexed as E

import Data.Functor.Coproduct (Coproduct())

import Text.Markdown.SlamDown
import Text.Markdown.SlamDown.Html
import Text.Markdown.SlamDown.Parser

import Model

type State = Article

data Query a = Toggle a
             | Load {title :: String, contents :: String} a

data ArticleContents = ArticleContents {title :: String, contents :: String}

data MarkdownSlot = MarkdownSlot

instance ordMarkdownSlot :: Ord MarkdownSlot where
  compare _ _ = EQ

instance eqMarkdownSlot :: Eq MarkdownSlot where
  eq _ _ = true

type FState g = InstalledState State SlamDownState Query SlamDownQuery g MarkdownSlot
type FQuery = Coproduct Query (ChildF MarkdownSlot SlamDownQuery)
type ArticleHTML g = ParentHTML SlamDownState Query SlamDownQuery g MarkdownSlot
type ArticleDSL g = ParentDSL State SlamDownState Query SlamDownQuery g MarkdownSlot

article :: forall g. (Functor g) => Component (FState g) FQuery g
article = parentComponent render eval
  where

  render :: State -> ArticleHTML g
  render (Article state) =
    let title = H.h2 [E.onClick (E.input_ Toggle)
                     ]
                [H.text state.title] in
    H.div_
      if state.visible
      then
        [ title
        , H.text state.contents
        , H.slot MarkdownSlot \_ -> { initialState: makeSlamDownState $ parseMd state.contents
                                    , component: slamDownComponent {browserFeatures: defaultBrowserFeatures, formName: "article-markdown-form"}}
        ]
      else
         [title]

  eval ::  Natural Query (ArticleDSL g)
  eval (Toggle next) = do
    modify (\(Article s)-> Article (s {visible = not s.visible}))
    pure next
  eval (Load ar next) = do
    modify (\(Article s) -> Article  (s {contents = ar.contents, title = ar.title}))
    pure next


add functions to generate and show samples

module Test.QuickCheck.LCG
  (
    Gen(),
    GenState(),
    GenOut(),
    Size(),
    LCG(),
    repeatable,
    stateful,
    variant,
    sized,
    resize,
    choose,
    chooseInt,
    oneOf,
    frequency,
    listOf,
    listOf1,
    vectorOf,
    elements,
    runGen,
    evalGen,
    perturbGen,
    uniform
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Random
import Debug.Trace
import Data.Maybe
import Data.Tuple
import Data.Foldable
import Data.Traversable
import Data.Monoid.Sum
import qualified Data.Array as A
import qualified Math as M

type LCG = Number
type Size = Number

type GenState = { newSeed :: LCG, size :: Size }

type GenOut a = { state :: GenState, value :: a }

data Gen a = Gen (GenState -> GenOut a)

repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ \s -> { value: \a -> (runGen (f a) s).value, state: s }

stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen (\s -> runGen (f s) s)

variant :: forall a. LCG -> Gen a -> Gen a
variant n g = Gen $ \s -> runGen g s { newSeed = n }

sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ \s -> runGen g s { size = sz }

choose :: Number -> Number -> Gen Number
choose a b = (*) (max - min) >>> (+) min <$> uniform where
  min = M.min a b
  max = M.max a b

chooseInt :: Number -> Number -> Gen Number
chooseInt a b = M.floor <$> choose (M.ceil a) (M.floor b + 0.999999999)

oneOf :: forall a. Gen a -> [Gen a] -> Gen a
oneOf x xs = do
  n <- chooseInt 0 (A.length xs)
  if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

frequency :: forall a. Tuple Number (Gen a) -> [Tuple Number (Gen a)] -> Gen a
frequency x xs = let
    xxs   = x : xs
    total = runSum $ fold (((Sum <<< fst) <$> xxs) :: [Sum])
    pick n d [] = d
    pick n d ((Tuple k x) : xs) = if n <= k then x else pick (n - k) d xs
  in do
    n <- chooseInt 1 total
    pick n (snd x) xxs

listOf :: forall a. Gen a -> Gen [a]
listOf g = sized $ \n ->
  do k <- chooseInt 0 n
     vectorOf k g

listOf1 :: forall a. Gen a -> Gen (Tuple a [a])
listOf1 g = sized $ \n ->
  do k  <- chooseInt 0 n
     x  <- g
     xs <- vectorOf (k - 1) g
     return $ Tuple x xs

vectorOf :: forall a. Number -> Gen a -> Gen [a]
vectorOf k g = sequence $ const g <$> (A.range 1 k)

elements :: forall a. a -> [a] -> Gen a
elements x xs = do
  n <- chooseInt 0 (A.length xs)
  pure if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

runGen :: forall a. Gen a -> GenState -> GenOut a
runGen (Gen f) = f

evalGen :: forall a. Gen a -> GenState -> a
evalGen gen st = (runGen gen st).value

sample :: forall a. Size -> Gen a -> [a]
sample sz g = evalGen (vectorOf sz g) { newSeed: 0, size: sz }

showSample' :: forall a. (Show a) => Size -> Gen a -> Eff (trace :: Trace) Unit
showSample' n g = print $ sample n g

showSample :: forall a. (Show a) => Gen a -> Eff (trace :: Trace) Unit
showSample g = showSample' 10 g

--
-- Magic Numbers
--

lcgM :: Number
lcgM = 1103515245

lcgC :: Number
lcgC = 12345

lcgN :: Number
lcgN = 1 `shl` 30

lcgNext :: Number -> Number
lcgNext n = (lcgM * n + lcgC) % lcgN

lcgStep :: Gen Number
lcgStep = Gen f where
  f s = { value: s.newSeed, state: s { newSeed = lcgNext s.newSeed } }

uniform :: Gen Number
uniform = (\n -> n / (1 `shl` 30)) <$> lcgStep

foreign import float32ToInt32
  "function float32ToInt32(n) {\
  \  var arr = new ArrayBuffer(4);\
  \  var fv = new Float32Array(arr);\
  \  var iv = new Int32Array(arr);\
  \  fv[0] = n;\
  \  return iv[0];\
  \}" :: Number -> Number

perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n (Gen f) = Gen $ \s -> f (s { newSeed = lcgNext (float32ToInt32 n) + s.newSeed })

instance functorGen :: Functor Gen where
  (<$>) f (Gen g) = Gen $ \s -> case g s of
    { value = value, state = state } -> { value: f value, state: state }

instance applyGen :: Apply Gen where
  (<*>) (Gen f) (Gen x) = Gen $ \s ->
    case f s of
      { value = f', state = s' } -> case x s' of
        { value = x', state = s'' } -> { value: f' x', state: s'' }

instance applicativeGen :: Applicative Gen where
  pure a = Gen (\s -> { value: a, state: s })

instance bindGen :: Bind Gen where
  (>>=) (Gen f) g = Gen $ \s -> case f s of
    { value = value, state = state } -> runGen (g value) state

instance monadGen :: Monad Gen

module Test.QuickCheck.LCG
  (
    Gen(),
    GenState(),
    GenOut(),
    Size(),
    LCG(),
    repeatable,
    stateful,
    variant,
    sized,
    resize,
    choose,
    chooseInt,
    oneOf,
    frequency,
    listOf,
    listOf1,
    vectorOf,
    elements,
    runGen,
    evalGen,
    perturbGen,
    uniform
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Random
import Data.Maybe
import Data.Tuple
import Data.Foldable
import Data.Traversable
import Data.Monoid.Sum
import qualified Data.Array as A
import qualified Math as M

type LCG = Number
type Size = Number

type GenState = { newSeed :: LCG, size :: Size }

type GenOut a = { state :: GenState, value :: a }

data Gen a = Gen (GenState -> GenOut a)

repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ \s -> { value: \a -> (runGen (f a) s).value, state: s }

stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen (\s -> runGen (f s) s)

variant :: forall a. LCG -> Gen a -> Gen a
variant n g = Gen $ \s -> runGen g s { newSeed = n }

sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ \s -> runGen g s { size = sz }

choose :: Number -> Number -> Gen Number
choose a b = (*) (max - min) >>> (+) min <$> uniform where
  min = M.min a b
  max = M.max a b

chooseInt :: Number -> Number -> Gen Number
chooseInt a b = M.floor <$> choose (M.ceil a) (M.floor b + 0.999999999)

oneOf :: forall a. Gen a -> [Gen a] -> Gen a
oneOf x xs = do
  n <- chooseInt 0 (A.length xs)
  if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

frequency :: forall a. Tuple Number (Gen a) -> [Tuple Number (Gen a)] -> Gen a
frequency x xs = let
    xxs   = x : xs
    total = runSum $ fold (((Sum <<< fst) <$> xxs) :: [Sum])
    pick n d [] = d
    pick n d ((Tuple k x) : xs) = if n <= k then x else pick (n - k) d xs
  in do
    n <- chooseInt 1 total
    pick n (snd x) xxs

listOf :: forall a. Gen a -> Gen [a]
listOf g = sized $ \n ->
  do k <- chooseInt 0 n
     vectorOf k g

listOf1 :: forall a. Gen a -> Gen (Tuple a [a])
listOf1 g = sized $ \n ->
  do k  <- chooseInt 0 n
     x  <- g
     xs <- vectorOf (k - 1) g
     return $ Tuple x xs

vectorOf :: forall a. Number -> Gen a -> Gen [a]
vectorOf k g = sequence $ const g <$> (A.range 1 k)

elements :: forall a. a -> [a] -> Gen a
elements x xs = do
  n <- chooseInt 0 (A.length xs)
  pure if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

runGen :: forall a. Gen a -> GenState -> GenOut a
runGen (Gen f) = f

evalGen :: forall a. Gen a -> GenState -> a
evalGen gen st = (runGen gen st).value
--
-- Magic Numbers
--

lcgM :: Number
lcgM = 1103515245

lcgC :: Number
lcgC = 12345

lcgN :: Number
lcgN = 1 `shl` 30

lcgNext :: Number -> Number
lcgNext n = (lcgM * n + lcgC) % lcgN

lcgStep :: Gen Number
lcgStep = Gen f where
  f s = { value: s.newSeed, state: s { newSeed = lcgNext s.newSeed } }

uniform :: Gen Number
uniform = (\n -> n / (1 `shl` 30)) <$> lcgStep

foreign import float32ToInt32
  "function float32ToInt32(n) {\
  \  var arr = new ArrayBuffer(4);\
  \  var fv = new Float32Array(arr);\
  \  var iv = new Int32Array(arr);\
  \  fv[0] = n;\
  \  return iv[0];\
  \}" :: Number -> Number

perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n (Gen f) = Gen $ \s -> f (s { newSeed = lcgNext (float32ToInt32 n) + s.newSeed })

instance functorGen :: Functor Gen where
  (<$>) f (Gen g) = Gen $ \s -> case g s of
    { value = value, state = state } -> { value: f value, state: state }

instance applyGen :: Apply Gen where
  (<*>) (Gen f) (Gen x) = Gen $ \s ->
    case f s of
      { value = f', state = s' } -> case x s' of
        { value = x', state = s'' } -> { value: f' x', state: s'' }

instance applicativeGen :: Applicative Gen where
  pure a = Gen (\s -> { value: a, state: s })

instance bindGen :: Bind Gen where
  (>>=) (Gen f) g = Gen $ \s -> case f s of
    { value = value, state = state } -> runGen (g value) state

instance monadGen :: Monad Gen


add issue 1843 cache card issue

add issue 1843 cache card issue

module Test.SlamData.Feature.Test.CacheCard where

import SlamData.Prelude

import Test.Feature.Log (successMsg)
import Test.Feature.Scenario (scenario)
import Test.SlamData.Feature.Expectations as Expect
import Test.SlamData.Feature.Interactions as Interact
import Test.SlamData.Feature.Monad (SlamFeature)

cacheCardScenario ∷ String → Array String → SlamFeature Unit → SlamFeature Unit
cacheCardScenario =
  scenario
    "Caching data source card output"
    (Interact.createWorkspaceInTestFolder "Cache card")
    (Interact.deleteFileInTestFolder "Untitled Workspace.slam"
     ≫ Interact.deleteFile "временный файл"
     ≫ Interact.browseRootFolder
    )

test ∷ SlamFeature Unit
test =
  cacheCardScenario "Cache card output to file" ["https://slamdata.atlassian.net/browse/SD-1843"] do
    Interact.insertQueryCardInLastDeck
    Interact.provideQueryInLastQueryCard
      "SELECT measureOne, measureTwo from `/test-mount/testDb/flatViz`"
    Interact.accessNextCardInLastDeck
    Interact.insertCacheCardInLastDeck
    Interact.provideSaveDestinationInLastCacheCard
      "/test-mount/testDb/временный файл"
    Interact.doSaveInLastCacheCard
    Interact.accessNextCardInLastDeck
    Interact.insertTableCardInLastDeck
    Expect.tableColumnsAre ["measureOne", "measureTwo"]
    Interact.browseTestFolder
    Interact.accessFile "временный файл"
    Interact.exploreFile
    Expect.tableColumnsAre ["measureOne", "measureTwo"]
    successMsg "Successfully saved data source card output to file"

module Test.SlamData.Feature.Test.CacheCard where

import SlamData.Prelude

import Test.Feature.Log (successMsg)
import Test.Feature.Scenario (scenario)
import Test.SlamData.Feature.Expectations as Expect
import Test.SlamData.Feature.Interactions as Interact
import Test.SlamData.Feature.Monad (SlamFeature)

cacheCardScenario ∷ String → Array String → SlamFeature Unit → SlamFeature Unit
cacheCardScenario =
  scenario
    "Caching data source card output"
    (Interact.createWorkspaceInTestFolder "Cache card")
    (Interact.deleteFileInTestFolder "Untitled Workspace.slam"
     ≫ Interact.deleteFile "временный файл"
     ≫ Interact.browseRootFolder
    )

test ∷ SlamFeature Unit
test =
  cacheCardScenario "Cache card output to file" [] do
    Interact.insertQueryCardInLastDeck
    Interact.provideQueryInLastQueryCard
      "SELECT measureOne, measureTwo from `/test-mount/testDb/flatViz`"
    Interact.accessNextCardInLastDeck
    Interact.insertCacheCardInLastDeck
    Interact.provideSaveDestinationInLastCacheCard
      "/test-mount/testDb/временный файл"
    Interact.doSaveInLastCacheCard
    Interact.accessNextCardInLastDeck
    Interact.insertTableCardInLastDeck
    Expect.tableColumnsAre ["measureOne", "measureTwo"]
    Interact.browseTestFolder
    Interact.accessFile "временный файл"
    Interact.exploreFile
    Expect.tableColumnsAre ["measureOne", "measureTwo"]
    successMsg "Successfully saved data source card output to file"


Use updated filename after file rename

Use updated filename after file rename

module IdePurescript.Atom.Imports where

import Prelude
import IdePurescript.Atom.Completion as C
import Atom.Atom (getAtom)
import Atom.CommandRegistry (COMMAND)
import Atom.Editor (TextEditor, EDITOR, setText, getPath, getText, getBuffer)
import Atom.NotificationManager (NOTIFY)
import Atom.TextBuffer (setTextViaDiff)
import Atom.Workspace (WORKSPACE, getActiveTextEditor)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Ref (Ref, REF, readRef, writeRef)
import DOM (DOM)
import Data.Maybe (Maybe(Just, Nothing), maybe)
import IdePurescript.Atom.Editor (getLinePosition)
import IdePurescript.Atom.PromptPanel (addPromptPanel)
import IdePurescript.Atom.SelectView (selectListViewStatic)
import IdePurescript.Atom.Tooltips (getToken)
import IdePurescript.Atom.Util (launchAffAndRaise)
import IdePurescript.Modules (State, ImportResult(AmbiguousImport, UpdatedImports), addModuleImport, addExplicitImport)
import IdePurescript.PscIde (getAvailableModules)
import Node.FS (FS)
import PscIde (NET)
import PscIde.Command (TypeInfo(..))

type AddModuleEff eff = ImportEff (dom :: DOM | eff)
type ImportEff eff = (workspace :: WORKSPACE, ref :: REF,  note :: NOTIFY, net :: NET, editor :: EDITOR, fs :: FS, console :: CONSOLE | eff)

addModuleImportCmd :: forall eff. Int -> Ref State -> Eff (AddModuleEff eff) Unit
addModuleImportCmd port modulesState = launchAffAndRaise do
  modules <- getAvailableModules port
  liftEffI $ selectListViewStatic view (addImport port modulesState) Nothing modules
  where
    view x = "
" <> x <> "
"
    liftEffI :: forall a. Eff (AddModuleEff eff) a -> Aff (AddModuleEff eff) a
    liftEffI = liftEff

addExplicitImportCmd :: forall eff. Int -> Ref State -> Eff (AddModuleEff (command :: COMMAND | eff)) Unit
addExplicitImportCmd port modulesState = launchAffAndRaise do
  atom <- liftEffM getAtom
  editor <- liftEffM $ getActiveTextEditor atom.workspace
  case editor of
    Just ed -> do
      { line, col, pos, range } <- liftEffM $ getLinePosition ed
      promptText <- liftEffM $ maybe "" _.word <$> getToken ed pos
      res <- addPromptPanel "Identifier" promptText
      maybe (pure unit) (addIdentImport port modulesState Nothing) res
    Nothing -> pure unit

addIdentImport :: forall eff. Int -> Ref State -> Maybe String -> String -> Aff (AddModuleEff eff) Unit
addIdentImport port modulesState moduleName ident = do
  atom <- liftEffM $ getAtom
  editor <- liftEffM $ getActiveTextEditor atom.workspace
  maybe (pure unit) (addIdentImport' port modulesState moduleName ident) editor

addIdentImport' :: forall eff. Int -> Ref State -> Maybe String -> String -> TextEditor -> Aff (AddModuleEff eff) Unit
addIdentImport' port modulesState moduleName ident editor = do
  text <- liftEffM $ getText editor
  path <- liftEffM $ getPath editor
  state <- liftEffM $ readRef modulesState
  case path of
    Just path' -> do
      { state: newState, result: output} <- addExplicitImport state port path' text moduleName ident
      liftEffM $ writeRef modulesState newState
      liftEffM $ case output of
        UpdatedImports out -> do
          buf <- getBuffer editor
          void $ setTextViaDiff buf out
        AmbiguousImport opts -> do
          selectListViewStatic view addImp (Just "module'") (runCompletion <$> opts)
        _ -> pure unit
    _ -> pure unit
  where
  runCompletion (TypeInfo obj) = obj
  -- TODO nicer if we can make select view aff-ish
  addImp { identifier, "module'": m } = launchAffAndRaise $ addIdentImport port modulesState (Just m) identifier
  view {identifier, "module'": m} = "
" <> m <> "." <> identifier <> "
"

addSuggestionImport :: forall r eff. Int -> Ref State -> { editor :: TextEditor, suggestion :: C.AtomSuggestion | r } -> Aff (AddModuleEff eff) Unit
addSuggestionImport port modulesState { editor, suggestion: { addImport: Just { mod, identifier, qualifier: Nothing } } } =
  addIdentImport' port modulesState (Just mod) identifier editor
addSuggestionImport _ _ _ = pure unit

addImport :: forall eff. Int -> Ref State -> String -> Eff (ImportEff eff) Unit
addImport port modulesState moduleName = do
  atom <- getAtom
  maybeEditor <- getActiveTextEditor atom.workspace
  state <- readRef modulesState
  case maybeEditor of
    Nothing -> pure unit
    Just editor -> do
      text <- getText editor
      path <- getPath editor
      case path of
        Just path' ->
          launchAffAndRaise $ do
            output <- addModuleImport state port path' text moduleName
            liftEff $ maybe (pure unit) (void <<< setText editor <<< _.result) output
        Nothing -> pure unit

liftEffM :: forall a eff. Eff (AddModuleEff eff) a -> Aff (AddModuleEff eff) a
liftEffM = liftEff

module IdePurescript.Atom.Imports where

import Prelude
import IdePurescript.Atom.Completion as C
import Atom.Atom (getAtom)
import Atom.CommandRegistry (COMMAND)
import Atom.Editor (TextEditor, EDITOR, setText, getPath, getText, getBuffer)
import Atom.NotificationManager (NOTIFY)
import Atom.TextBuffer (setTextViaDiff)
import Atom.Workspace (WORKSPACE, getActiveTextEditor)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Ref (Ref, REF, readRef, writeRef)
import DOM (DOM)
import Data.Maybe (Maybe(Just, Nothing), maybe)
import IdePurescript.Atom.Editor (getLinePosition)
import IdePurescript.Atom.PromptPanel (addPromptPanel)
import IdePurescript.Atom.SelectView (selectListViewStatic)
import IdePurescript.Atom.Tooltips (getToken)
import IdePurescript.Atom.Util (launchAffAndRaise)
import IdePurescript.Modules (State, ImportResult(AmbiguousImport, UpdatedImports), addModuleImport, addExplicitImport)
import IdePurescript.PscIde (getAvailableModules)
import Node.FS (FS)
import PscIde (NET)
import PscIde.Command (TypeInfo(..))

type AddModuleEff eff = ImportEff (dom :: DOM | eff)
type ImportEff eff = (workspace :: WORKSPACE, ref :: REF,  note :: NOTIFY, net :: NET, editor :: EDITOR, fs :: FS, console :: CONSOLE | eff)

addModuleImportCmd :: forall eff. Int -> Ref State -> Eff (AddModuleEff eff) Unit
addModuleImportCmd port modulesState = launchAffAndRaise do
  modules <- getAvailableModules port
  liftEffI $ selectListViewStatic view (addImport port modulesState) Nothing modules
  where
    view x = "
" <> x <> "
"
    liftEffI :: forall a. Eff (AddModuleEff eff) a -> Aff (AddModuleEff eff) a
    liftEffI = liftEff

addExplicitImportCmd :: forall eff. Int -> Ref State -> Eff (AddModuleEff (command :: COMMAND | eff)) Unit
addExplicitImportCmd port modulesState = launchAffAndRaise do
  atom <- liftEffM getAtom
  editor <- liftEffM $ getActiveTextEditor atom.workspace
  case editor of
    Just ed -> do
      { line, col, pos, range } <- liftEffM $ getLinePosition ed
      promptText <- liftEffM $ maybe "" _.word <$> getToken ed pos
      res <- addPromptPanel "Identifier" promptText
      maybe (pure unit) (addIdentImport port modulesState Nothing) res
    Nothing -> pure unit

addIdentImport :: forall eff. Int -> Ref State -> Maybe String -> String -> Aff (AddModuleEff eff) Unit
addIdentImport port modulesState moduleName ident = do
  atom <- liftEffM $ getAtom
  editor <- liftEffM $ getActiveTextEditor atom.workspace
  maybe (pure unit) (addIdentImport' port modulesState moduleName ident) editor

addIdentImport' :: forall eff. Int -> Ref State -> Maybe String -> String -> TextEditor -> Aff (AddModuleEff eff) Unit
addIdentImport' port modulesState moduleName ident editor = do
  text <- liftEffM $ getText editor
  path <- liftEffM $ getPath editor
  state <- liftEffM $ readRef modulesState
  case path of
    Just path' -> do
      { state: newState, result: output} <- addExplicitImport state port path' text moduleName ident
      liftEffM $ writeRef modulesState newState
      liftEffM $ case output of
        UpdatedImports out -> do
          buf <- getBuffer editor
          void $ setTextViaDiff buf out
        AmbiguousImport opts -> do
          selectListViewStatic view addImp (Just "identifier") (runCompletion <$> opts)
        _ -> pure unit
    _ -> pure unit
  where
  runCompletion (TypeInfo obj) = obj
  -- TODO nicer if we can make select view aff-ish
  addImp { identifier, "module'": m } = launchAffAndRaise $ addIdentImport port modulesState (Just m) identifier
  view {identifier, "module'": m} = "
" <> m <> "." <> identifier <> "
"

addSuggestionImport :: forall r eff. Int -> Ref State -> { editor :: TextEditor, suggestion :: C.AtomSuggestion | r } -> Aff (AddModuleEff eff) Unit
addSuggestionImport port modulesState { editor, suggestion: { addImport: Just { mod, identifier, qualifier: Nothing } } } =
  addIdentImport' port modulesState (Just mod) identifier editor
addSuggestionImport _ _ _ = pure unit

addImport :: forall eff. Int -> Ref State -> String -> Eff (ImportEff eff) Unit
addImport port modulesState moduleName = do
  atom <- getAtom
  maybeEditor <- getActiveTextEditor atom.workspace
  state <- readRef modulesState
  case maybeEditor of
    Nothing -> pure unit
    Just editor -> do
      text <- getText editor
      path <- getPath editor
      case path of
        Just path' ->
          launchAffAndRaise $ do
            output <- addModuleImport state port path' text moduleName
            liftEff $ maybe (pure unit) (void <<< setText editor <<< _.result) output
        Nothing -> pure unit

liftEffM :: forall a eff. Eff (AddModuleEff eff) a -> Aff (AddModuleEff eff) a
liftEffM = liftEff


Account for duplicate handler definitions (#7)

module Halogen.VDom.DOM.Prop
  ( Prop(..)
  , ElemRef(..)
  , PropValue
  , propFromString
  , propFromBoolean
  , propFromInt
  , propFromNumber
  , buildProp
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Eff.Ref as Ref
import Data.Maybe (Maybe(..), maybe)
import Data.StrMap as StrMap
import Data.Nullable (toNullable)
import Data.Function.Uncurried as Fn
import Data.Tuple (Tuple(..), fst, snd)
import DOM (DOM)
import DOM.Event.EventTarget (eventListener) as DOM
import DOM.Event.Types (EventType(..), Event) as DOM
import DOM.Node.Types (Element) as DOM
import Halogen.VDom as V
import Halogen.VDom.Types (Namespace(..))
import Halogen.VDom.Util as Util
import Unsafe.Coerce (unsafeCoerce)

data Prop a
  = Attribute (Maybe Namespace) String String
  | Property String PropValue
  | Handler DOM.EventType (DOM.Event → Maybe a)
  | Ref (ElemRef DOM.Element → Maybe a)

instance functorProp ∷ Functor Prop where
  map f (Handler ty g) = Handler ty (map f <$> g)
  map f (Ref g) = Ref (map f <$> g)
  map f p = unsafeCoerce p

data ElemRef a
  = Created a
  | Removed a

instance functorElemRef ∷ Functor ElemRef where
  map f (Created a) = Created (f a)
  map f (Removed a) = Removed (f a)

foreign import data PropValue ∷ *

propFromString ∷ String → PropValue
propFromString = unsafeCoerce

propFromBoolean ∷ Boolean → PropValue
propFromBoolean = unsafeCoerce

propFromInt ∷ Int → PropValue
propFromInt = unsafeCoerce

propFromNumber ∷ Number → PropValue
propFromNumber = unsafeCoerce

buildProp
  ∷ ∀ eff a
  . (a → Eff (ref ∷ REF, dom ∷ DOM | eff) Unit)
  → DOM.Element
  → V.VDomMachine (ref ∷ REF, dom ∷ DOM | eff) (Array (Prop a)) Unit
buildProp emit el = render
  where
  render ps1 = do
    events ← Util.newMutMap
    ps1' ← Fn.runFn3 Util.strMapWithIxE ps1 propToStrKey (applyProp events)
    pure
      (V.Step unit
        (Fn.runFn2 patch (Util.unsafeFreeze events) ps1')
        (done ps1'))

  patch = Fn.mkFn2 \prevEvents ps1 → \ps2 → do
    events ← Util.newMutMap
    let
      onThese = Fn.runFn2 diffProp prevEvents events
      onThis = removeProp prevEvents
      onThat = applyProp events
    ps2' ← Fn.runFn6 Util.diffWithKeyAndIxE ps1 ps2 propToStrKey onThese onThis onThat
    pure
      (V.Step unit
        (Fn.runFn2 patch (Util.unsafeFreeze events) ps2')
        (done ps2'))

  done ps = do
    case StrMap.lookup "ref" ps of
      Just (Ref f) → do
        mbEmit (f (Removed el))
      _ → do
        Util.effUnit

  mbEmit =
    maybe Util.effUnit emit

  applyProp events = Fn.mkFn3 \_ _ v →
    case v of
      Attribute ns attr val → do
        Fn.runFn4 Util.setAttribute (toNullable ns) attr val el
        pure v
      Property prop val → do
        Fn.runFn3 setProperty prop val el
        pure v
      Handler (DOM.EventType ty) f → do
        case Fn.runFn2 Util.unsafeGetAny ty events of
          handler | Fn.runFn2 Util.unsafeHasAny ty events → do
            Ref.writeRef (snd handler) f
            pure v
          _ → do
            ref ← Ref.newRef f
            let
              listener = DOM.eventListener \ev → do
                f' ← Ref.readRef ref
                mbEmit (f' ev)
            Fn.runFn3 Util.pokeMutMap ty (Tuple listener ref) events
            Fn.runFn3 Util.addEventListener ty listener el
            pure v
      Ref f → do
        mbEmit (f (Created el))
        pure v

  diffProp = Fn.mkFn2 \prevEvents events → Fn.mkFn4 \_ _ v1 v2 →
    case v1, v2 of
      Attribute _ _ val1, Attribute ns2 attr2 val2 →
        case val1 /= val2 of
          true → do
            Fn.runFn4 Util.setAttribute (toNullable ns2) attr2 val2 el
            pure v2
          _ →
            Util.effPure v2
      Property _ val1, Property prop2 val2 →
        case Fn.runFn2 Util.refEq val1 val2, prop2 of
          true, _ →
            Util.effPure v2
          _, "value" → do
            let elVal = Fn.runFn2 unsafeGetProperty "value" el
            case not (Fn.runFn2 Util.refEq elVal val2) of
              true → do
                Fn.runFn3 setProperty prop2 val2 el
                pure v2
              _ →
                Util.effPure v2
          _, _ → do
            Fn.runFn3 setProperty prop2 val2 el
            pure v2
      Handler _ _, Handler (DOM.EventType ty) f → do
        let
          handler = Fn.runFn2 Util.unsafeLookup ty prevEvents
        Ref.writeRef (snd handler) f
        Fn.runFn3 Util.pokeMutMap ty handler events
        pure v2
      _, _ →
        Util.effPure v2

  removeProp prevEvents = Fn.mkFn2 \_ v →
    case v of
      Attribute ns attr _ →
        Fn.runFn3 Util.removeAttribute (toNullable ns) attr el
      Property prop _ →
        Fn.runFn2 removeProperty prop el
      Handler (DOM.EventType ty) _ → do
        let
          handler = Fn.runFn2 Util.unsafeLookup ty prevEvents
        Fn.runFn3 Util.removeEventListener ty (fst handler) el
      Ref _ →
        Util.effUnit

propToStrKey ∷ ∀ i. Prop i → String
propToStrKey = case _ of
  Attribute (Just (Namespace ns)) attr _ → "attr/" <> ns <> ":" <> attr
  Attribute _ attr _ → "attr/:" <> attr
  Property prop _ → "prop/" <> prop
  Handler (DOM.EventType ty) _ → "handler/" <> ty
  Ref _ → "ref"

setProperty ∷ ∀ eff. Fn.Fn3 String PropValue DOM.Element (Eff (dom ∷ DOM | eff) Unit)
setProperty = Util.unsafeSetAny

unsafeGetProperty ∷ Fn.Fn2 String DOM.Element PropValue
unsafeGetProperty = Util.unsafeGetAny

removeProperty ∷ ∀ eff. Fn.Fn2 String DOM.Element (Eff (dom ∷ DOM | eff) Unit)
removeProperty = Util.unsafeDeleteAny

module Halogen.VDom.DOM.Prop
  ( Prop(..)
  , ElemRef(..)
  , PropValue
  , propFromString
  , propFromBoolean
  , propFromInt
  , propFromNumber
  , buildProp
  ) where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Eff.Ref as Ref
import Data.Maybe (Maybe(..), maybe)
import Data.StrMap as StrMap
import Data.Nullable (toNullable)
import Data.Function.Uncurried as Fn
import Data.Tuple (Tuple(..), fst, snd)
import DOM (DOM)
import DOM.Event.EventTarget (eventListener) as DOM
import DOM.Event.Types (EventType(..), Event) as DOM
import DOM.Node.Types (Element) as DOM
import Halogen.VDom as V
import Halogen.VDom.Types (Namespace(..))
import Halogen.VDom.Util as Util
import Unsafe.Coerce (unsafeCoerce)

data Prop a
  = Attribute (Maybe Namespace) String String
  | Property String PropValue
  | Handler DOM.EventType (DOM.Event → Maybe a)
  | Ref (ElemRef DOM.Element → Maybe a)

instance functorProp ∷ Functor Prop where
  map f (Handler ty g) = Handler ty (map f <$> g)
  map f (Ref g) = Ref (map f <$> g)
  map f p = unsafeCoerce p

data ElemRef a
  = Created a
  | Removed a

instance functorElemRef ∷ Functor ElemRef where
  map f (Created a) = Created (f a)
  map f (Removed a) = Removed (f a)

foreign import data PropValue ∷ *

propFromString ∷ String → PropValue
propFromString = unsafeCoerce

propFromBoolean ∷ Boolean → PropValue
propFromBoolean = unsafeCoerce

propFromInt ∷ Int → PropValue
propFromInt = unsafeCoerce

propFromNumber ∷ Number → PropValue
propFromNumber = unsafeCoerce

buildProp
  ∷ ∀ eff a
  . (a → Eff (ref ∷ REF, dom ∷ DOM | eff) Unit)
  → DOM.Element
  → V.VDomMachine (ref ∷ REF, dom ∷ DOM | eff) (Array (Prop a)) Unit
buildProp emit el = render
  where
  render ps1 = do
    events ← Util.newMutMap
    ps1' ← Fn.runFn3 Util.strMapWithIxE ps1 propToStrKey (applyProp events)
    pure
      (V.Step unit
        (Fn.runFn2 patch (Util.unsafeFreeze events) ps1')
        (done ps1'))

  patch = Fn.mkFn2 \prevEvents ps1 → \ps2 → do
    events ← Util.newMutMap
    let
      onThese = Fn.runFn2 diffProp prevEvents events
      onThis = removeProp prevEvents
      onThat = applyProp events
    ps2' ← Fn.runFn6 Util.diffWithKeyAndIxE ps1 ps2 propToStrKey onThese onThis onThat
    pure
      (V.Step unit
        (Fn.runFn2 patch (Util.unsafeFreeze events) ps2')
        (done ps2'))

  done ps = do
    case StrMap.lookup "ref" ps of
      Just (Ref f) → do
        mbEmit (f (Removed el))
      _ → do
        Util.effUnit

  mbEmit =
    maybe Util.effUnit emit

  applyProp events = Fn.mkFn3 \_ _ v →
    case v of
      Attribute ns attr val → do
        Fn.runFn4 Util.setAttribute (toNullable ns) attr val el
        pure v
      Property prop val → do
        Fn.runFn3 setProperty prop val el
        pure v
      Handler (DOM.EventType ty) f → do
        ref ← Ref.newRef f
        let
          listener = DOM.eventListener \ev → do
            f' ← Ref.readRef ref
            mbEmit (f' ev)
        Fn.runFn3 Util.pokeMutMap ty (Tuple listener ref) events
        Fn.runFn3 Util.addEventListener ty listener el
        pure v
      Ref f → do
        mbEmit (f (Created el))
        pure v

  diffProp = Fn.mkFn2 \prevEvents events → Fn.mkFn4 \_ _ v1 v2 →
    case v1, v2 of
      Attribute _ _ val1, Attribute ns2 attr2 val2 →
        case val1 /= val2 of
          true → do
            Fn.runFn4 Util.setAttribute (toNullable ns2) attr2 val2 el
            pure v2
          _ →
            Util.effPure v2
      Property _ val1, Property prop2 val2 →
        case Fn.runFn2 Util.refEq val1 val2, prop2 of
          true, _ →
            Util.effPure v2
          _, "value" → do
            let elVal = Fn.runFn2 unsafeGetProperty "value" el
            case not (Fn.runFn2 Util.refEq elVal val2) of
              true → do
                Fn.runFn3 setProperty prop2 val2 el
                pure v2
              _ →
                pure v2
          _, _ → do
            Fn.runFn3 setProperty prop2 val2 el
            pure v2
      Handler _ _, Handler (DOM.EventType ty) f → do
        let
          handler = Fn.runFn2 Util.unsafeLookup ty prevEvents
        Ref.writeRef (snd handler) f
        Fn.runFn3 Util.pokeMutMap ty handler events
        pure v2
      _, _ →
        Util.effPure v2

  removeProp prevEvents = Fn.mkFn2 \_ v →
    case v of
      Attribute ns attr _ →
        Fn.runFn3 Util.removeAttribute (toNullable ns) attr el
      Property prop _ →
        Fn.runFn2 removeProperty prop el
      Handler (DOM.EventType ty) _ → do
        let
          handler = Fn.runFn2 Util.unsafeLookup ty prevEvents
        Fn.runFn3 Util.removeEventListener ty (fst handler) el
      Ref _ →
        Util.effUnit

propToStrKey ∷ ∀ i. Prop i → String
propToStrKey = case _ of
  Attribute (Just (Namespace ns)) attr _ → "attr/" <> ns <> ":" <> attr
  Attribute _ attr _ → "attr/:" <> attr
  Property prop _ → "prop/" <> prop
  Handler (DOM.EventType ty) _ → "handler/" <> ty
  Ref _ → "ref"

setProperty ∷ ∀ eff. Fn.Fn3 String PropValue DOM.Element (Eff (dom ∷ DOM | eff) Unit)
setProperty = Util.unsafeSetAny

unsafeGetProperty ∷ Fn.Fn2 String DOM.Element PropValue
unsafeGetProperty = Util.unsafeGetAny

removeProperty ∷ ∀ eff. Fn.Fn2 String DOM.Element (Eff (dom ∷ DOM | eff) Unit)
removeProperty = Util.unsafeDeleteAny


Remove restrictions on adding ProperNames etc

module IdePurescript.Modules (
    Module
  , initialModulesState
  , State
  , getMainModule
  , getModulesForFile
  , getUnqualActiveModules
  , getAllActiveModules
  , getQualModule
  , findImportInsertPos
  , addModuleImport
  , addExplicitImport
  , ImportResult(..)
  ) where

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Data.Array ((:), findLastIndex, filter, singleton, concatMap)
import Data.Either (either, Either(..))
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.String (split)
import Data.String.Regex as R
import Data.Foldable (elem)
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.FS.Aff as FS
import Node.Path (sep)
import Prelude
import PscIde as P
import PscIde.Command as C

data Module = Implicit String | Explicit String (Array String) | Qualified String String

derive instance moduleEq :: Eq Module

getModuleName :: Module -> String
getModuleName (Qualified _ m) = m
getModuleName (Implicit m) = m
getModuleName (Explicit m _) = m

type State =
  { main :: Maybe String
  , modules :: Array Module
  , identifiers :: Array String
  }

type Path = String

getMainModule :: String -> Maybe String
getMainModule text =
  case R.match regex text of
    Just [_, Just m] -> Just m
    _ -> Nothing
  where
  regex = R.regex """module\s+([\w.]+)""" $ R.noFlags { multiline = true }

getModulesForFile :: forall eff. Path -> String -> Aff (net :: P.NET | eff) State
getModulesForFile file fullText = do
  imports <- P.listImports file
  let modules = either (const []) (\(C.ImportList l) -> map mod l) imports
      main = getMainModule fullText
      identifiers = concatMap idents modules
  pure { main, modules, identifiers }
  where
  mod (C.Import { moduleName, qualifier: Nothing, importType: C.Explicit identifiers }) =
    Explicit moduleName identifiers
  mod (C.Import { moduleName, qualifier: Nothing }) = Implicit moduleName
  mod (C.Import { moduleName, qualifier: Just qual }) = Qualified qual moduleName

  idents (Explicit _ x) = x
  idents _ = []

getUnqualActiveModules :: State -> Maybe String -> Array String
getUnqualActiveModules {modules, main} ident =
  map getModuleName $ maybe [] (singleton <<< Implicit) main ++ filter include modules
  where
  include (Qualified _ _) = false
  include (Explicit _ idents) = maybe false (_ `elem` idents) ident
  include (Implicit _) = true

getAllActiveModules  :: State -> Array String
getAllActiveModules {modules, main} =
  map getModuleName $ maybe [] (singleton <<< Implicit) main ++ modules

getQualModule :: String -> State -> Array String
getQualModule qualifier {modules} =
  map getModuleName $ filter (qual qualifier) modules
  where
  qual q (Qualified q' _) = q == q'
  qual _ _ = false

initialModulesState :: State
initialModulesState =  { main: Nothing, modules: [], identifiers: [] }

findImportInsertPos :: String -> Int
findImportInsertPos text =
  let regex = R.regex """^(module|import) [A-Z][^(]*($|\([^()]*\))""" R.noFlags
      lines = split "\n" text
      res = fromMaybe 0 $ findLastIndex (R.test regex) lines
  in res+1

foreign import tmpDir :: forall eff. Eff (fs :: FS | eff) String

data ImportResult = UpdatedImports String | AmbiguousImport (Array C.Completion) | FailedImport

withTempFile :: forall eff. String -> String -> (String -> Aff (net :: P.NET, fs :: FS | eff) (Either String C.ImportResult))
  -> Aff (net :: P.NET, fs :: FS | eff) ImportResult
withTempFile fileName text action = do
  dir <- liftEff tmpDir
  let name = R.replace (R.regex "[\\/\\\\]" (R.noFlags { global = true })) "-" fileName
      tmpFile = dir ++ sep ++ "ide-purescript." ++ name ++ ".purs"
  FS.writeTextFile UTF8 tmpFile text
  res <- action tmpFile
  answer <- case res of
    Right (C.SuccessFile _) -> UpdatedImports <$> FS.readTextFile UTF8 tmpFile
    Right (C.MultipleResults a) -> pure $ AmbiguousImport a
    _ -> pure FailedImport
  FS.unlink tmpFile
  pure answer

addModuleImport :: forall eff. State -> String -> String -> String
  -> Aff (net :: P.NET, fs :: FS | eff) (Maybe { state :: State, result :: String })
addModuleImport state fileName text moduleName =
  case shouldAdd of
    false -> pure Nothing
    true -> do
      res <- withTempFile fileName text addImport
      pure $ case res of
        UpdatedImports result -> Just { state, result }
        _ -> Nothing
  where
  addImport tmpFile = P.implicitImport tmpFile (Just tmpFile) [] moduleName
  shouldAdd =
    state.main /= Just moduleName && Implicit moduleName `elem` state.modules

addExplicitImport :: forall eff. State -> String -> String -> (Maybe String) -> String
  -> Aff (net :: P.NET, fs :: FS | eff) { state :: State, result :: ImportResult }
addExplicitImport state fileName text moduleName identifier =
  case shouldAdd of
    false -> pure { state, result: FailedImport }
    true -> do
      result <- withTempFile fileName text addImport
      let state' = case result of
            UpdatedImports _ -> state { identifiers = identifier : state.identifiers }
            _ -> state
      pure { result, state: state' }
  where
    addImport tmpFile = P.explicitImport tmpFile (Just tmpFile) filters identifier
    filters = case moduleName of
                Nothing -> []
                Just mn -> [C.ModuleFilter [mn]]
    isThisModule = case moduleName of
      Just _ -> moduleName == state.main
      _ -> false

    shouldAdd = not isThisModule
      && not (identifier `elem` state.identifiers)
      && maybe true (\mn -> not $ Implicit mn `elem` state.modules) moduleName

module IdePurescript.Modules (
    Module
  , initialModulesState
  , State
  , getMainModule
  , getModulesForFile
  , getUnqualActiveModules
  , getAllActiveModules
  , getQualModule
  , findImportInsertPos
  , addModuleImport
  , addExplicitImport
  , ImportResult(..)
  ) where

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Data.Array ((:), findLastIndex, filter, singleton, concatMap)
import Data.Either (either, Either(..))
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.String (split)
import Data.String.Regex as R
import Data.Foldable (elem)
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.FS.Aff as FS
import Node.Path (sep)
import Prelude
import PscIde as P
import PscIde.Command as C

data Module = Implicit String | Explicit String (Array String) | Qualified String String

derive instance moduleEq :: Eq Module

getModuleName :: Module -> String
getModuleName (Qualified _ m) = m
getModuleName (Implicit m) = m
getModuleName (Explicit m _) = m

type State =
  { main :: Maybe String
  , modules :: Array Module
  , identifiers :: Array String
  }

type Path = String

getMainModule :: String -> Maybe String
getMainModule text =
  case R.match regex text of
    Just [_, Just m] -> Just m
    _ -> Nothing
  where
  regex = R.regex """module\s+([\w.]+)""" $ R.noFlags { multiline = true }

getModulesForFile :: forall eff. Path -> String -> Aff (net :: P.NET | eff) State
getModulesForFile file fullText = do
  imports <- P.listImports file
  let modules = either (const []) (\(C.ImportList l) -> map mod l) imports
      main = getMainModule fullText
      identifiers = concatMap idents modules
  pure { main, modules, identifiers }
  where
  mod (C.Import { moduleName, qualifier: Nothing, importType: C.Explicit identifiers }) =
    Explicit moduleName identifiers
  mod (C.Import { moduleName, qualifier: Nothing }) = Implicit moduleName
  mod (C.Import { moduleName, qualifier: Just qual }) = Qualified qual moduleName

  idents (Explicit _ x) = x
  idents _ = []

getUnqualActiveModules :: State -> Maybe String -> Array String
getUnqualActiveModules {modules, main} ident =
  map getModuleName $ maybe [] (singleton <<< Implicit) main ++ filter include modules
  where
  include (Qualified _ _) = false
  include (Explicit _ idents) = maybe false (_ `elem` idents) ident
  include (Implicit _) = true

getAllActiveModules  :: State -> Array String
getAllActiveModules {modules, main} =
  map getModuleName $ maybe [] (singleton <<< Implicit) main ++ modules

getQualModule :: String -> State -> Array String
getQualModule qualifier {modules} =
  map getModuleName $ filter (qual qualifier) modules
  where
  qual q (Qualified q' _) = q == q'
  qual _ _ = false

initialModulesState :: State
initialModulesState =  { main: Nothing, modules: [], identifiers: [] }

findImportInsertPos :: String -> Int
findImportInsertPos text =
  let regex = R.regex """^(module|import) [A-Z][^(]*($|\([^()]*\))""" R.noFlags
      lines = split "\n" text
      res = fromMaybe 0 $ findLastIndex (R.test regex) lines
  in res+1

foreign import tmpDir :: forall eff. Eff (fs :: FS | eff) String

data ImportResult = UpdatedImports String | AmbiguousImport (Array C.Completion) | FailedImport

withTempFile :: forall eff. String -> String -> (String -> Aff (net :: P.NET, fs :: FS | eff) (Either String C.ImportResult))
  -> Aff (net :: P.NET, fs :: FS | eff) ImportResult
withTempFile fileName text action = do
  dir <- liftEff tmpDir
  let name = R.replace (R.regex "[\\/\\\\]" (R.noFlags { global = true })) "-" fileName
      tmpFile = dir ++ sep ++ "ide-purescript." ++ name ++ ".purs"
  FS.writeTextFile UTF8 tmpFile text
  res <- action tmpFile
  answer <- case res of
    Right (C.SuccessFile _) -> UpdatedImports <$> FS.readTextFile UTF8 tmpFile
    Right (C.MultipleResults a) -> pure $ AmbiguousImport a
    _ -> pure FailedImport
  FS.unlink tmpFile
  pure answer

addModuleImport :: forall eff. State -> String -> String -> String
  -> Aff (net :: P.NET, fs :: FS | eff) (Maybe { state :: State, result :: String })
addModuleImport state fileName text moduleName =
  case shouldAdd of
    false -> pure Nothing
    true -> do
      res <- withTempFile fileName text addImport
      pure $ case res of
        UpdatedImports result -> Just { state, result }
        _ -> Nothing
  where
  addImport tmpFile = P.implicitImport tmpFile (Just tmpFile) [] moduleName
  shouldAdd =
    state.main /= Just moduleName && Implicit moduleName `elem` state.modules

addExplicitImport :: forall eff. State -> String -> String -> (Maybe String) -> String
  -> Aff (net :: P.NET, fs :: FS | eff) { state :: State, result :: ImportResult }
addExplicitImport state fileName text moduleName identifier =
  case shouldAdd of
    false -> pure { state, result: FailedImport }
    true -> do
      result <- withTempFile fileName text addImport
      let state' = case result of
            UpdatedImports _ -> state { identifiers = identifier : state.identifiers }
            _ -> state
      pure { result, state: state' }
  where
    addImport tmpFile = P.explicitImport tmpFile (Just tmpFile) filters identifier
    filters = case moduleName of
                Nothing -> []
                Just mn -> [C.ModuleFilter [mn]]
    isThisModule = case moduleName of
      Just _ -> moduleName == state.main
      _ -> false

    shouldAdd = not isThisModule
      && not (identifier `elem` state.identifiers)
      && isIdent identifier
      && maybe true (\mn -> not $ Implicit mn `elem` state.modules) moduleName
    isIdent = R.test (R.regex """^[a-z_]\S*$""" R.noFlags)