[CSE-193] Add `ja` translations

[CSE-193] Add `ja` translations

module Explorer.I18n.JP where

import Explorer.I18n.Types (Translation)

translation :: Translation
translation =
    { common:
        { cBack: "戻る"
        , cApi: "API"
        , cADA: "ADA"
        , cBCshort: "BC"
        , cBCong: "Bitcoin"
        , cTransaction: "トランザクション"
        , cTransactions: "トランザクション"
        , cTransactionFeed: "トランザクションフィード"
        , cAddress: "アドレス"
        , cAddresses: "アドレス"
        , cVersion: "バージョン"
        , cCalculator: "計算機"
        , cNetwork: "ネットワーク"
        , cSummary: "概要"
        , cBlock: "スロット"
        , cGenesis: "ジェネシス・ブロック"
        , cHash: "ハッシュ値"
        , cHashes: "ハッシュ値"
        , cEpoch: "エポック"
        , cEpochs: "エポック"
        , cSlot: "スロット"
        , cSlots: "スロット"
        , cAge: "経過時間"
        , cTotalSent: "総送信額"
        , cBlockLead: "スロットリーダー"
        , cSize: "サイズ (bytes)"
        , cExpand: "開く"
        , cCollapse: "閉じる"
        , cNoData: "データなし"
        , cTitle: "Cardano Blockchain Explorer"
        , cCopyright: "Cardano Blockchain Explorer @2017"
        , cUnknown: "不明"
        , cTotalOutput: "合計アウトプット"
        , cOf: "of"
        , cNotAvailable: "データがありません"
        , cLoading: "ロード中..."
        , cBack2Dashboard: "ダッシュボードに戻る"
        , cYes: "はい"
        , cNo: "いいえ"
        , cDays: "日"
        , cHours: "時間"
        , cMinutes: "分"
        , cSeconds: "秒"
        , cDateFormat: "YYYY/MM/DD HH:mm:ss"
        , cDecimalSeparator: "."
        , cGroupSeparator: ","
        }
    , navigation:
        { navHome: "ホーム"
        , navBlockchain: "ブロックチェーン"
        , navMarket: "マーケット"
        , navCharts: "チャート"
        , navTools: "ツール"
        }
    , hero:
        {  hrSubtitle: "カルダノネットワーク上のアドレス、トランザクション、エポック、スロットを検索"
        , hrSearch: "スロット、エポック、トランザクションを検索"
        , hrTime: "タイム"
        }
    , dashboard:
        { dbTitle: "ダッシュボード"
        , dbLastBlocks: "最近のスロット"
        , dbLastBlocksDescription: "{0}に{1}のトランザクションが生成されました"
        , dbPriceAverage: "平均価格"
        , dbPriceForOne: "1{1}の価格: {0}"
        , dbPriceSince: "昨日からの価格: {0}"
        , dbTotalSupply: "総供給額"
        , dbTotalAmountOf: "システム内総額: {0}"
        , dbTotalAmountOfTransactions: "開設以来システム内で検出された総トランザクション数"
        , dbExploreBlocks: "スロットを検索する"
        , dbExploreTransactions: "トランザクションを検索する"
        , dbBlockchainOffer: "ブロックチェーンエクスプローラーから提供されるもの"
        , dbBlockSearch: "スロット検索"
        , dbBlockSearchDescription: "スロットはトランザクションを格納しているボックスです。"
        , dbAddressSearch: "アドレス検索"
        , dbAddressSearchDescription: "アドレスを検索します"
        , dbTransactionSearch: "トランザクション検索"
        , dbTransactionSearchDescription: "トランザクションはAからBへコインを送金することです。"
        , dbApiDescription: "我々の安全なAPIは、さまざまな言語とSDKで利用可能です。"
        , dbGetAddress: "アドレス取得"
        , dbResponse: "レスポンス"
        , dbCurl: "Curl"
        , dbNode: "Node"
        , dbJQuery: "jQuery"
        , dbGetApiKey: "APIキー取得"
        , dbMoreExamples: "その他の例を見る"
        , dbAboutBlockchain: "ブロックチェーンについて"
        , dbAboutBlockchainDescription: "ブロックチェーンAPIはより容易に暗号通貨のアプリケーション及び機能を実装することができます。我々は開発者が高速、スケーラブル、かつ安全なサービスを構築できるようなプラットフォームを提供することに注力しています。

このAPIはベータ版では無料で無制限です。APIはまだ初期段階であり、今後より多くのエンドポイント、機能の導入を予定しています。開発チームはユーザーが求めているAPIを構築したいので、リクエスト、改善点などがあればご連絡お願いします。"
        }
    , address:
        { addScan: "QRコードをスキャンしてアドレスをクリップボードにコピーする"
        , addQrCode: "QRコード"
        , addFinalBalance: "最終残高"
        , addNotFound: "アドレスは存在しません"
        }
    , tx:
        { txTime: "入金時刻"
        , txIncluded: "含まれている"
        , txRelayed: "中継IP"
        , txEmpty: "トランザクションなし"
        , txFees: "トランザクション料"
        , txNotFound: "トランザクションは見つかりません"
        }
    , block:
        { blFees: "手数料"
        , blEstVolume: "推定容量"
        , blPrevBlock: "前のスロット"
        , blNextBlock: "次のスロット"
        , blRoot: "ハッシュ根"
        , blEpochSlotNotFound: "エラーが発生しま した。エポック/スロットが見つかりませんでした"
        , blSlotNotFound: "スロットは存在していません。"
        , blSlotEmpty: "空のスロット"
        }
    , genesisBlock:
        { gblNotFound: "ジェネシス・ブロックは見つかりませんでした"
        , gblNumberRedeemedAddresses: "還元済みアドレス"
        , gblNumberNotRedeemedAddresses: "還元可能なアドレス数"
        , gblNumberAddressesToRedeem: "還元アドレス数"
        , gblRedeemedAmountTotal: "還元済み"
        , gblNonRedeemedAmountTotal: "未還元数"
        , gblFilterAll: "全て"
        , gblFilterRedeemed: "還元済み"
        , gblFilterNonRedeemed: "未還元"
        , gblAddressesNotFound: "そのアドレスは存在しません"
        , gblAddressesError: "アドレス読み込み中にエラーが発生しました."
        , gblAddressRedeemAmount: "還元される額"
        , gblAddressIsRedeemed: "還元済み"
        }
    , footer:
        { fooIohkSupportP: "IOHK supported project"
        , fooGithub: "Github"
        , fooEmail: "Email"
        , fooTwitter: "Twitter"
        , fooDaedalusPlatform: "ダイダロスプラットフォーム"
        , fooWhyCardano: "なぜカルダノなのか"
        , fooCardanoRoadmap: "カルダノロードマップ"
        , fooCardanoSource: "カルダノSLソース"
        , fooCardanoFoundation: "カルダノ財団"
        , fooCardanoFoundationYoutube: "カルダノ財団 Youtube"
        , fooCardanoFoundationTwitter: "カルダノ財団 Twitter"
        , fooCardanoHub: "カルダノハブ"
        , fooCardanoLaunch: "カルダノローンチ"
        , fooCardanoSlack: "カルダノ財団 Slack"
        , fooCardanoReddit: "カルダノ財団 Reddit"
        , fooCardanoCommunity: "カルダノコミュニティー"
        , fooCardanoDocumentation: "カルダノドキュメンテーション"
        , fooCardanoTestnet: "カルダノテストネット"
        , fooCardanoOpenSource: "カルダノはオープンソースプロジェクトです"
        , fooIOHK: "IOHK"
        , fooIOHKBlog: "IOHKブログ"
        , fooIOHKYoutube: "IOHK YouTube"
        , fooDisclaimerPt1: "カルダノは、ソフトウェアプラットフォームのみであり、ブロックチェーン資産、デジタル通貨、暗号通貨またはそれに関連する各資金の精査や実質的なレビューは一切行いません。あなたは自身の投資評価、ブロックチェーン資産を交換するかどうかの決定、ブロックチェーン資産をカルダノと交換の如何に関して、完全かつ唯一の責任があります。多くの場合、あなたの調査に基づいて交換するブロックチェーン資産は価値が上がらず、下がる可能性があります。同様に、調査を基に交換するブロックチェーン資産は、交換後に価値が上がる可能性もあります。"
        , fooDisclaimerPt2: "過去の業績は必ずしも将来の結果を 暗 示す るものではありません。ブロックチェーン資産への投資には、投資の一部または全てが失われるリスクが伴います。換金するブロックチェーン資産の価値は、市場リスクおよびその他の投資リスクの対象となります。"
        , fooProject: "プロジェクト"
        , fooProtocol: "プロトコル"
        , fooFoundation: "財団"
        , fooLearnMore: "詳しく知る"
        }
    , notfound:
        { nfTitle: "404"
        , nfDescription: "ページが見つかりません"
        }
    }

module Explorer.I18n.JP where

import Explorer.I18n.Types (Translation)

translation :: Translation
translation =
    { common:
        { cBack: "戻る"
        , cApi: "API"
        , cADA: "ADA"
        , cBCshort: "BC"
        , cBCong: "Bitcoin"
        , cTransaction: "トランザクション"
        , cTransactions: "トランザクション"
        , cTransactionFeed: "トランザクションフィード"
        , cAddress: "アドレス"
        , cAddresses: "アドレス"
        , cVersion: "バージョン"
        , cCalculator: "計算機"
        , cNetwork: "ネットワーク"
        , cSummary: "概要"
        , cBlock: "スロット"
        , cGenesis: "ジェネシス・ブロック"
        , cHash: "ハッシュ値"
        , cHashes: "ハッシュ値"
        , cEpoch: "エポック"
        , cEpochs: "エポック"
        , cSlot: "スロット"
        , cSlots: "スロット"
        , cAge: "経過時間"
        , cTotalSent: "総送信額"
        , cBlockLead: "スロットリーダー"
        , cSize: "サイズ (bytes)"
        , cExpand: "開く"
        , cCollapse: "閉じる"
        , cNoData: "データなし"
        , cTitle: "Cardano Blockchain Explorer"
        , cCopyright: "Cardano Blockchain Explorer @2017"
        , cUnknown: "不明"
        , cTotalOutput: "合計アウトプット"
        , cOf: "of"
        , cNotAvailable: "データがありません"
        , cLoading: "ロード中..."
        , cBack2Dashboard: "ダッシュボードに戻る"
        , cYes: "はい"
        , cNo: "いいえ"
        , cDays: "日"
        , cHours: "時間"
        , cMinutes: "分"
        , cSeconds: "秒"
        , cDateFormat: "YYYY/MM/DD HH:mm:ss"
        , cDecimalSeparator: "."
        , cGroupSeparator: ","
        }
    , navigation:
        { navHome: "ホーム"
        , navBlockchain: "ブロックチェーン"
        , navMarket: "マーケット"
        , navCharts: "チャート"
        , navTools: "ツール"
        }
    , hero:
        {  hrSubtitle: "カルダノネットワーク上のアドレス、トランザクション、エポック、スロットを検索"
        , hrSearch: "スロット、エポック、トランザクションを検索"
        , hrTime: "タイム"
        }
    , dashboard:
        { dbTitle: "ダッシュボード"
        , dbLastBlocks: "最近のスロット"
        , dbLastBlocksDescription: "{0}に{1}のトランザクションが生成されました"
        , dbPriceAverage: "平均価格"
        , dbPriceForOne: "1{1}の価格: {0}"
        , dbPriceSince: "昨日からの価格: {0}"
        , dbTotalSupply: "総供給額"
        , dbTotalAmountOf: "システム内総額: {0}"
        , dbTotalAmountOfTransactions: "開設以来システム内で検出された総トランザクション数"
        , dbExploreBlocks: "スロットを検索する"
        , dbExploreTransactions: "トランザクションを検索する"
        , dbBlockchainOffer: "ブロックチェーンエクスプローラーから提供されるもの"
        , dbBlockSearch: "スロット検索"
        , dbBlockSearchDescription: "スロットはトランザクションを格納しているボックスです。"
        , dbAddressSearch: "アドレス検索"
        , dbAddressSearchDescription: "アドレスを検索します"
        , dbTransactionSearch: "トランザクション検索"
        , dbTransactionSearchDescription: "トランザクションはAからBへコインを送金することです。"
        , dbApiDescription: "我々の安全なAPIは、さまざまな言語とSDKで利用可能です。"
        , dbGetAddress: "アドレス取得"
        , dbResponse: "レスポンス"
        , dbCurl: "Curl"
        , dbNode: "Node"
        , dbJQuery: "jQuery"
        , dbGetApiKey: "APIキー取得"
        , dbMoreExamples: "その他の例を見る"
        , dbAboutBlockchain: "ブロックチェーンについて"
        , dbAboutBlockchainDescription: "ブロックチェーンAPIはより容易に暗号通貨のアプリケーション及び機能を実装することができます。我々は開発者が高速、スケーラブル、かつ安全なサービスを構築できるようなプラットフォームを提供することに注力しています。

このAPIはベータ版では無料で無制限です。APIはまだ初期段階であり、今後より多くのエンドポイント、機能の導入を予定しています。開発チームはユーザーが求めているAPIを構築したいので、リクエスト、改善点などがあればご連絡お願いします。"
        }
    , address:
        { addScan: "QRコードをスキャンしてアドレスをクリップボードにコピーする"
        , addQrCode: "QRコード"
        , addFinalBalance: "最終残高"
        , addNotFound: "アドレスは存在しません"
        }
    , tx:
        { txTime: "入金時刻"
        , txIncluded: "含まれている"
        , txRelayed: "中継IP"
        , txEmpty: "トランザクションなし"
        , txFees: "トランザクション料"
        , txNotFound: "トランザクションは見つかりません"
        }
    , block:
        { blFees: "手数料"
        , blEstVolume: "推定容量"
        , blPrevBlock: "前のスロット"
        , blNextBlock: "次のスロット"
        , blRoot: "ハッシュ根"
        , blEpochSlotNotFound: "エラーが発生しま した。エポック/スロットが見つかりませんでした"
        , blSlotNotFound: "スロットは存在していません。"
        , blSlotEmpty: "空のスロット"
        }
    , genesisBlock:
        { gblNotFound: "ジェネシス・ブロックは見つかりませんでした"
        , gblNumberRedeemedAddresses: "還元済みアドレス"
        , gblNumberNotRedeemedAddresses: "JA - Addresses left to redeem"
        , gblNumberAddressesToRedeem: "JA - Redeem addresses"
        , gblRedeemedAmountTotal: "JA - Redeemed amount"
        , gblNonRedeemedAmountTotal: "JA - Amount left to redeem"
        , gblFilterAll: "JA - All"
        , gblFilterRedeemed: "JA - Redeemed"
        , gblFilterNonRedeemed: "JA - Not redeemed"
        , gblAddressesNotFound: "そのアドレスは存在しません"
        , gblAddressesError: "アドレス読み込み中にエラーが発生しました."
        , gblAddressRedeemAmount: "還元される額"
        , gblAddressIsRedeemed: "還元済み"
        }
    , footer:
        { fooIohkSupportP: "IOHK supported project"
        , fooGithub: "Github"
        , fooEmail: "Email"
        , fooTwitter: "Twitter"
        , fooDaedalusPlatform: "ダイダロスプラットフォーム"
        , fooWhyCardano: "なぜカルダノなのか"
        , fooCardanoRoadmap: "カルダノロードマップ"
        , fooCardanoSource: "カルダノSLソース"
        , fooCardanoFoundation: "カルダノ財団"
        , fooCardanoFoundationYoutube: "カルダノ財団 Youtube"
        , fooCardanoFoundationTwitter: "カルダノ財団 Twitter"
        , fooCardanoHub: "カルダノハブ"
        , fooCardanoLaunch: "カルダノローンチ"
        , fooCardanoSlack: "カルダノ財団 Slack"
        , fooCardanoReddit: "カルダノ財団 Reddit"
        , fooCardanoCommunity: "カルダノコミュニティー"
        , fooCardanoDocumentation: "カルダノドキュメンテーション"
        , fooCardanoTestnet: "カルダノテストネット"
        , fooCardanoOpenSource: "カルダノはオープンソースプロジェクトです"
        , fooIOHK: "IOHK"
        , fooIOHKBlog: "IOHKブログ"
        , fooIOHKYoutube: "IOHK YouTube"
        , fooDisclaimerPt1: "カルダノは、ソフトウェアプラットフォームのみであり、ブロックチェーン資産、デジタル通貨、暗号通貨またはそれに関連する各資金の精査や実質的なレビューは一切行いません。あなたは自身の投資評価、ブロックチェーン資産を交換するかどうかの決定、ブロックチェーン資産をカルダノと交換の如何に関して、完全かつ唯一の責任があります。多くの場合、あなたの調査に基づいて交換するブロックチェーン資産は価値が上がらず、下がる可能性があります。同様に、調査を基に交換するブロックチェーン資産は、交換後に価値が上がる可能性もあります。"
        , fooDisclaimerPt2: "過去の業績は必ずしも将来の結果を 暗 示す るものではありません。ブロックチェーン資産への投資には、投資の一部または全てが失われるリスクが伴います。換金するブロックチェーン資産の価値は、市場リスクおよびその他の投資リスクの対象となります。"
        , fooProject: "プロジェクト"
        , fooProtocol: "プロトコル"
        , fooFoundation: "財団"
        , fooLearnMore: "詳しく知る"
        }
    , notfound:
        { nfTitle: "404"
        , nfDescription: "ページが見つかりません"
        }
    }


Adding a `filterM` implementation (copied from GHC)

Maybe this will prove useful at some point...?

module Main (main) where

import Control.Monad.Eff(Eff(..))
import Control.Monad.JQuery(append, css, JQuery(..), ready, select)

import Data.Foldable(for_)

import AppState(AppState(..))
import Cards(Card(..), cards)
import DOM(DOM(..))
import Element(genCardCheckbox)
import JQueryUI(accordion, attrStr, button, buttonset, change, children, click, each, flipChecked, refreshButton, siblings, spinner, tabs, val)

main = ready $ do
  initJQUI
  AppState { cardHolder = cardHolder } <- initState
  cleanupCSS
  populateCardSetCustomizer cardHolder

initJQUI :: forall eff. Eff (dom :: DOM | eff) JQuery
initJQUI = do
  select ".collapsible-accordion" >>= (accordion { heightStyle: "fill" })
  select ".ui-spinner-button"     >>= click spinAButton
  foreach ".ui-button"    mkButton
  foreach ".ui-tabs"      mkTabs
  foreach ".ui-spinner"   spinIt
  foreach ".checkboxes"   mkButtonSet
  foreach ".check-set"    mkButtonSet
  foreach ".radio-set"    mkButtonSet
  foreach ".check-button" mkButton
  foreach ".check-label"  checkIt
    where
      foreach x f = select x >>= each f
      checkIt     = click innerClick
      mkButton    = button
      mkButtonSet = buttonset
      mkTabs      = tabs
      spinAButton this = do
                           sibs <- siblings "input" this
                           change sibs
      spinIt this = do
                      spinner this
                      val "1" this

cleanupCSS :: forall eff. Eff (dom :: DOM | eff) JQuery
cleanupCSS = do
  mainBox <- byID "main-box"
  css { overflow: "auto" } mainBox

initState :: forall eff. Eff (dom :: DOM | eff) AppState
initState = do
  adderButtonElem    <- byID "adder-button"
  adderTableElem     <- byID "adder-table"
  cardHolderElem     <- byID "card-holder"
  cardNumSpinnerElem <- byID "card-num-spinner"
  nameInputElem      <- byID "name-input"
  pickButtonElem     <- byID "pick-btn"
  return $ AppState { adderButton:    adderButtonElem
                    , adderTable:     adderTableElem
                    , cardHolder:     cardHolderElem
                    , cardNumSpinner: cardNumSpinnerElem
                    , nameInput:      nameInputElem
                    , pickButton:     pickButtonElem
                    , playerNums:     []
                    }

populateCardSetCustomizer :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery
populateCardSetCustomizer cardHolder = do
  for_ cards $ appendCard cardHolder
  foreach ".dynamic-check-button" button
  foreach ".dynamic-check-label"  innerClick
    where
      foreach x f = children x cardHolder >>= f
      appendCard elem (Card { name = name, isEnabled = isEnabled }) =
        genCardCheckbox name isEnabled >>= flip append elem

innerClick :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery
innerClick this = do
  forAttr <- attrStr "for" this
  btn     <- byID forAttr
  flipChecked btn
  refreshButton btn
  change btn

filterM :: forall a m. (Monad m) => (a -> m Boolean) -> [a] -> m [a]
filterM _ []     = return []
filterM p (x:xs) = do
   pred <- p x
   ys   <- filterM p xs
   return $ if pred then x:ys else ys

byID :: forall eff. String -> Eff (dom :: DOM | eff) JQuery
byID id = select $ "#" ++ id

(|>) a f = f a

module Main (main) where

import Control.Monad.Eff(Eff(..))
import Control.Monad.JQuery(append, css, JQuery(..), ready, select)

import Data.Foldable(for_)

import AppState(AppState(..))
import Cards(Card(..), cards)
import DOM(DOM(..))
import Element(genCardCheckbox)
import JQueryUI(accordion, attrStr, button, buttonset, change, children, click, each, flipChecked, refreshButton, siblings, spinner, tabs, val)

main = ready $ do
  initJQUI
  AppState { cardHolder = cardHolder } <- initState
  cleanupCSS
  populateCardSetCustomizer cardHolder

initJQUI :: forall eff. Eff (dom :: DOM | eff) JQuery
initJQUI = do
  select ".collapsible-accordion" >>= (accordion { heightStyle: "fill" })
  select ".ui-spinner-button"     >>= click spinAButton
  foreach ".ui-button"    mkButton
  foreach ".ui-tabs"      mkTabs
  foreach ".ui-spinner"   spinIt
  foreach ".checkboxes"   mkButtonSet
  foreach ".check-set"    mkButtonSet
  foreach ".radio-set"    mkButtonSet
  foreach ".check-button" mkButton
  foreach ".check-label"  checkIt
    where
      foreach x f = select x >>= each f
      checkIt     = click innerClick
      mkButton    = button
      mkButtonSet = buttonset
      mkTabs      = tabs
      spinAButton this = do
                           sibs <- siblings "input" this
                           change sibs
      spinIt this = do
                      spinner this
                      val "1" this

cleanupCSS :: forall eff. Eff (dom :: DOM | eff) JQuery
cleanupCSS = do
  mainBox <- byID "main-box"
  css { overflow: "auto" } mainBox

initState :: forall eff. Eff (dom :: DOM | eff) AppState
initState = do
  adderButtonElem    <- byID "adder-button"
  adderTableElem     <- byID "adder-table"
  cardHolderElem     <- byID "card-holder"
  cardNumSpinnerElem <- byID "card-num-spinner"
  nameInputElem      <- byID "name-input"
  pickButtonElem     <- byID "pick-btn"
  return $ AppState { adderButton:    adderButtonElem
                    , adderTable:     adderTableElem
                    , cardHolder:     cardHolderElem
                    , cardNumSpinner: cardNumSpinnerElem
                    , nameInput:      nameInputElem
                    , pickButton:     pickButtonElem
                    , playerNums:     []
                    }

populateCardSetCustomizer :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery
populateCardSetCustomizer cardHolder = do
  for_ cards $ appendCard cardHolder
  foreach ".dynamic-check-button" button
  foreach ".dynamic-check-label"  innerClick
    where
      foreach x f = children x cardHolder >>= f
      appendCard elem (Card { name = name, isEnabled = isEnabled }) =
        genCardCheckbox name isEnabled >>= flip append elem

innerClick :: forall eff. JQuery -> Eff (dom :: DOM | eff) JQuery
innerClick this = do
  forAttr <- attrStr "for" this
  btn     <- byID forAttr
  flipChecked btn
  refreshButton btn
  change btn

byID :: forall eff. String -> Eff (dom :: DOM | eff) JQuery
byID id = select $ "#" ++ id

(|>) a f = f a


Fix incorrect field pruning logic (fix #420)

The logic as it was would consider *every* field which did not have a
default value as needing to be pruned, since it was comparing against
the result of initSlamDownState, which just creates a dictionary
containing the fields with default values. Instead, it should have been
comparing against the result of slamDownFields.

Thanks to @garyb for muddling through the diagnostic process with me.

module Input.Notebook
  ( CellResultContent(..)
  , Input(..)
  , updateState
  , cellContent
  ) where

import Prelude
import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Bind (join)
import Data.Array (filter, modifyAt, (!!), elemIndex, (\\))
import Data.Date (Date(), toEpochMilliseconds)
import Data.Either (Either(..), isRight, either)
import Data.Foldable (intercalate, foldl, elem)
import Data.Function (on)

import Data.Maybe (Maybe(..), fromMaybe, maybe, isJust)
import Data.String (indexOf)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)
import Model.Notebook
import Model.Resource (Resource())
import Model.Notebook.Cell
import Model.Notebook.Cell.FileInput (_showFiles)
import Model.Notebook.Domain (_cells, addCell, insertCell, _dependencies, Notebook(), trash, ancestors)
import Model.Notebook.Port (Port(..), VarMapValue(), _PortResource, _VarMap)
import Optic.Core
import Optic.Fold ((^?))
import Optic.Setter (mapped)
import Text.Markdown.SlamDown (SlamDown(..), Block(..), Expr(..), Inline(..), FormField(..), TextBoxType(..), everything)
import Text.Markdown.SlamDown.Html (FormFieldValue(..), SlamDownEvent(..), SlamDownState(..), applySlamDownEvent, initSlamDownState)
import Text.Markdown.SlamDown.Parser (parseMd)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.String.Regex as Rx
import qualified Data.StrMap as SM
import qualified ECharts.Options as EC
import qualified Model.Notebook.Cell.JTableContent as JTC
import qualified Model.Notebook.Cell.Markdown as Ma
import qualified Text.Parsing.StringParser as SP
import qualified Text.Parsing.StringParser.Combinators as SP
import qualified Text.Parsing.StringParser.String as SP
import Model.Path (FilePath(), AnyPath())

data CellResultContent
  = AceContent String
  | JTableContent JTC.JTableContent
  | MarkdownContent SlamDown

data Input
  = WithState (State -> State)
  | Dropdown Int
  | CloseDropdowns
  | AddCell CellContent
  | TrashCell CellId

  | RequestCellContent Cell
  | ReceiveCellContent Cell
  | ViewCellContent Cell
  | RefreshCell Cell

  | StartRunCell CellId Date
  | StopCell CellId
  | CellResult CellId Date (Either (NEL.NonEmpty FailureMessage) CellResultContent)

  | UpdateCell CellId (Cell -> Cell)
  | CellSlamDownEvent CellId SlamDownEvent
  | InsertCell Cell CellContent
  | SetEChartsOption String EC.Option
  | ResizeECharts String

  | UpdatedOutput CellId Port
  | ForceSave

updateState :: State -> Input -> State

updateState state (WithState f) =
  f state

updateState state (UpdateCell cellId fn) =
  state # _notebook.._cells..mapped %~ onCell cellId fn

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # _dropdowns %~
  ((fromMaybe (state ^. _dropdowns)) <<<
   (modifyAt i _{visible = visSet}) <<<
   (_{visible = false} <$>))

updateState state CloseDropdowns =
  state # (_dropdowns %~ (_{visible = false} <$>))
       .. (_notebook .. _cells .. mapped %~ _content .. _FileInput .. _showFiles .~ false)

updateState state (AddCell content) =
  state # _notebook %~ (fst <<< addCell content)

updateState state (InsertCell parent content) =
  state # _notebook %~ (fst <<< insertCell parent content)

updateState state (TrashCell cellId) =
  state # _notebook.._cells %~ filter (not <<< depends (state ^._notebook) cellId)
        # _notebook.._cells %~ filter (not <<< isCell cellId)
        # _notebook.._dependencies %~ trash cellId

updateState state (CellResult cellId date content) =
  let finished d = RunFinished $ on (-) toEpochMilliseconds date d

      fromState (RunningSince d) = cellContent content <<< setRunState (finished d)
      fromState a = setRunState a -- In bad state or cancelled. Leave content.

      f cell = fromState (cell ^. _runState) cell # (_hasRun .~ true)

  in state # _notebook.._cells..mapped %~ onCell cellId f

updateState state (ReceiveCellContent cell) =
  state # _notebook.._cells..mapped %~ onCell (cell ^. _cellId) (const $ setSlamDownStatus cell)

updateState state (StartRunCell cellId date) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState (RunningSince date) <<< (_expandedStatus .~ false))

updateState state (StopCell cellId) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState RunInitial)

updateState state (CellSlamDownEvent cellId event) =
  state # _notebook.._cells..mapped %~ onCell cellId (slamDownOutput <<< runSlamDownEvent event)
        # _notebook.._cells %~ syncParents
        # _requesting <>~ [cellId]

updateState state (UpdatedOutput cid newInput) =
  state # _notebook.._cells..mapped %~ changed
  where
  changed cell = if not $ elem (cell ^. _cellId) depIds
                 then cell
                 else cell # _input .~ newInput
  depIds =
    fst <$>
    L.filter (\x -> snd x == cid) (M.toList (state ^. _notebook .. _dependencies))

updateState state (RefreshCell cell) =
  let requesting = state ^. _requesting
      cid = cell ^. _cellId
  in if elem cid requesting
     then state
     else state # _refreshing <>~ [cell ^. _cellId]

updateState state i = state

_SlamDownState :: LensP SlamDownState (SM.StrMap FormFieldValue)
_SlamDownState = lens (\(SlamDownState m) -> m) (const SlamDownState)

-- TODO: We need a much better solution to this.
syncParents :: Array Cell -> Array Cell
syncParents cells = updateCell <$> cells
  where updateCell cell = fromMaybe cell $ fromParent cell
        fromParent cell = do
          pid <- cell ^. _parent
          parent <- M.lookup pid m
          return (cell # _input .~ (parent ^. _output))
        m = M.fromList <<< L.toList $ pair <$> cells
        pair cell = Tuple (cell ^. _cellId) cell

slamDownOutput :: Cell -> Cell
slamDownOutput cell =
  cell # _output .. _VarMap  %~ modifyVarMap
  where
    modifyVarMap m = foldl (\m (Tuple key val) -> SM.insert key val m) m tplLst
    tplLst = maybe L.Nil SM.toList ((fromFormValue <$>) <$> state)
    fromFormValue (SingleValue PlainText s) = quoteString s
    fromFormValue (SingleValue Numeric s) = quoteStringNumeric s
    fromFormValue (SingleValue Date s) = "DATE '" ++ s ++ "'"
    fromFormValue (SingleValue Time s) = "TIME '" ++ s ++ "'"
    fromFormValue (SingleValue DateTime s) = "TIMESTAMP '" ++ processTimestamp s ++ "'"
    fromFormValue (MultipleValues s) = "[" <> intercalate ", " (quoteString <$> S.toList s) <> "]" -- TODO: is this anything like we want for multi-values?
    state :: Maybe (SM.StrMap FormFieldValue)
    state = cell ^? _content.._Markdown..Ma._state.._SlamDownState
    processTimestamp s = s ++ ":00Z"
    quoteString s = "'" ++ Rx.replace rxQuot "''" s ++ "'"
    quoteStringNumeric s | isSQLNum s = s
                         | otherwise = quoteString s
    rxQuot = Rx.regex "'" Rx.noFlags { global = true }
    rxT = Rx.regex "T" Rx.noFlags
    isSQLNum s = isRight $ flip SP.runParser s $ do
      SP.many1 SP.anyDigit
      SP.optional $ SP.string "." *> SP.many SP.anyDigit
      SP.optional $ (SP.string "e" <|> SP.string "E")
                 *> (SP.string "-" <|> SP.string "+")
                 *> SP.many SP.anyDigit
      SP.eof

slamDownFields :: SlamDown -> L.List (Tuple String FormField)
slamDownFields = everything (const L.Nil) go
  where
  go (FormField s _ ff) = L.singleton (Tuple s ff)
  go _ = L.Nil

setSlamDownStatus :: Cell -> Cell
setSlamDownStatus cell =
  let input' = cell ^? _content.._Markdown..Ma._input
      message = ("Exported fields: " <>) <<< intercalate ", " <<< (fst <$>)
      initial md =
        let fields = slamDownFields md
            updateState (SlamDownState s) = case initSlamDownState md of
              SlamDownState s' ->
                let prunedSM = foldl (flip SM.delete) s $ keysToPrune s $ SM.fromList fields
                    mergedSM = prunedSM `SM.union` s'
                in SlamDownState mergedSM
        in slamDownOutput (cell # _message .~ message fields
                                # _content .. _Markdown .. Ma._state %~ updateState)
  in maybe cell (initial <<< parseMd) input'

  where
    -- | Returns the keys that are either not present in the new state, or have had their types changed.
    keysToPrune :: SM.StrMap FormFieldValue -> SM.StrMap FormField -> Array _
    keysToPrune oldState newState =
      SM.foldMap
        (\key oldVal ->
            case Tuple oldVal (SM.lookup key newState) of
               Tuple (SingleValue tbt1 _) (Just (TextBox tbt2 _)) -> if tbt1 == tbt2 then [] else [key]
               Tuple _ Nothing -> [key]
               _ -> [])
        oldState

runSlamDownEvent :: SlamDownEvent -> Cell -> Cell
runSlamDownEvent event cell =
  cell # _content.._Markdown..Ma._state %~ flip applySlamDownEvent event

cellContent :: Either (NEL.NonEmpty FailureMessage) CellResultContent -> Cell -> Cell
cellContent = either (setFailures <<< NEL.toArray) success
  where
  success :: CellResultContent -> Cell -> Cell
  success (AceContent content) =
    setFailures [ ]
    <<< (_content.._AceContent .~ content)
  success (JTableContent content) =
    setFailures [ ]
    <<< (_content.._JTableContent .~ content)
  success (MarkdownContent content) =
    setFailures [ ]
    <<< (_content.._Markdown..Ma._evaluated ?~ content)

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

setFailures :: Array FailureMessage -> Cell -> Cell
setFailures fs (Cell o) = Cell $ o { failures = fs }

setRunState :: RunState -> Cell -> Cell
setRunState = modifyRunState <<< const

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'

depends :: Notebook -> CellId -> Cell -> Boolean
depends notebook cellId cell =
  isJust $ elemIndex cellId (ancestors (cell ^._cellId) (notebook ^._dependencies))

module Input.Notebook
  ( CellResultContent(..)
  , Input(..)
  , updateState
  , cellContent
  ) where

import Prelude
import Control.Alt ((<|>))
import Control.Apply ((*>))
import Control.Bind (join)
import Data.Array (filter, modifyAt, (!!), elemIndex, (\\))
import Data.Date (Date(), toEpochMilliseconds)
import Data.Either (Either(..), isRight, either)
import Data.Foldable (intercalate, foldl, elem)
import Data.Function (on)

import Data.Maybe (Maybe(..), fromMaybe, maybe, isJust)
import Data.String (indexOf)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst, snd)
import Model.Notebook
import Model.Resource (Resource())
import Model.Notebook.Cell
import Model.Notebook.Cell.FileInput (_showFiles)
import Model.Notebook.Domain (_cells, addCell, insertCell, _dependencies, Notebook(), trash, ancestors)
import Model.Notebook.Port (Port(..), VarMapValue(), _PortResource, _VarMap)
import Optic.Core
import Optic.Fold ((^?))
import Optic.Setter (mapped)
import Text.Markdown.SlamDown (SlamDown(..), Block(..), Expr(..), Inline(..), FormField(..), TextBoxType(..), everything)
import Text.Markdown.SlamDown.Html (FormFieldValue(..), SlamDownEvent(..), SlamDownState(..), applySlamDownEvent, initSlamDownState)
import Text.Markdown.SlamDown.Parser (parseMd)

import qualified Data.Array.NonEmpty as NEL
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.String.Regex as Rx
import qualified Data.StrMap as SM
import qualified ECharts.Options as EC
import qualified Model.Notebook.Cell.JTableContent as JTC
import qualified Model.Notebook.Cell.Markdown as Ma
import qualified Text.Parsing.StringParser as SP
import qualified Text.Parsing.StringParser.Combinators as SP
import qualified Text.Parsing.StringParser.String as SP
import Model.Path (FilePath(), AnyPath())

data CellResultContent
  = AceContent String
  | JTableContent JTC.JTableContent
  | MarkdownContent SlamDown

data Input
  = WithState (State -> State)
  | Dropdown Int
  | CloseDropdowns
  | AddCell CellContent
  | TrashCell CellId

  | RequestCellContent Cell
  | ReceiveCellContent Cell
  | ViewCellContent Cell
  | RefreshCell Cell

  | StartRunCell CellId Date
  | StopCell CellId
  | CellResult CellId Date (Either (NEL.NonEmpty FailureMessage) CellResultContent)

  | UpdateCell CellId (Cell -> Cell)
  | CellSlamDownEvent CellId SlamDownEvent
  | InsertCell Cell CellContent
  | SetEChartsOption String EC.Option
  | ResizeECharts String

  | UpdatedOutput CellId Port
  | ForceSave

updateState :: State -> Input -> State

updateState state (WithState f) =
  f state

updateState state (UpdateCell cellId fn) =
  state # _notebook.._cells..mapped %~ onCell cellId fn

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # _dropdowns %~
  ((fromMaybe (state ^. _dropdowns)) <<<
   (modifyAt i _{visible = visSet}) <<<
   (_{visible = false} <$>))

updateState state CloseDropdowns =
  state # (_dropdowns %~ (_{visible = false} <$>))
       .. (_notebook .. _cells .. mapped %~ _content .. _FileInput .. _showFiles .~ false)

updateState state (AddCell content) =
  state # _notebook %~ (fst <<< addCell content)

updateState state (InsertCell parent content) =
  state # _notebook %~ (fst <<< insertCell parent content)

updateState state (TrashCell cellId) =
  state # _notebook.._cells %~ filter (not <<< depends (state ^._notebook) cellId)
        # _notebook.._cells %~ filter (not <<< isCell cellId)
        # _notebook.._dependencies %~ trash cellId

updateState state (CellResult cellId date content) =
  let finished d = RunFinished $ on (-) toEpochMilliseconds date d

      fromState (RunningSince d) = cellContent content <<< setRunState (finished d)
      fromState a = setRunState a -- In bad state or cancelled. Leave content.

      f cell = fromState (cell ^. _runState) cell # (_hasRun .~ true)

  in state # _notebook.._cells..mapped %~ onCell cellId f

updateState state (ReceiveCellContent cell) =
  state # _notebook.._cells..mapped %~ onCell (cell ^. _cellId) (const $ setSlamDownStatus cell)

updateState state (StartRunCell cellId date) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState (RunningSince date) <<< (_expandedStatus .~ false))

updateState state (StopCell cellId) =
  state # _notebook.._cells..mapped %~ onCell cellId (setRunState RunInitial)

updateState state (CellSlamDownEvent cellId event) =
  state # _notebook.._cells..mapped %~ onCell cellId (slamDownOutput <<< runSlamDownEvent event)
        # _notebook.._cells %~ syncParents
        # _requesting <>~ [cellId]

updateState state (UpdatedOutput cid newInput) =
  state # _notebook.._cells..mapped %~ changed
  where
  changed cell = if not $ elem (cell ^. _cellId) depIds
                 then cell
                 else cell # _input .~ newInput
  depIds =
    fst <$>
    L.filter (\x -> snd x == cid) (M.toList (state ^. _notebook .. _dependencies))

updateState state (RefreshCell cell) =
  let requesting = state ^. _requesting
      cid = cell ^. _cellId
  in if elem cid requesting
     then state
     else state # _refreshing <>~ [cell ^. _cellId]

updateState state i = state

_SlamDownState :: LensP SlamDownState (SM.StrMap FormFieldValue)
_SlamDownState = lens (\(SlamDownState m) -> m) (const SlamDownState)

-- TODO: We need a much better solution to this.
syncParents :: Array Cell -> Array Cell
syncParents cells = updateCell <$> cells
  where updateCell cell = fromMaybe cell $ fromParent cell
        fromParent cell = do
          pid <- cell ^. _parent
          parent <- M.lookup pid m
          return (cell # _input .~ (parent ^. _output))
        m = M.fromList <<< L.toList $ pair <$> cells
        pair cell = Tuple (cell ^. _cellId) cell

slamDownOutput :: Cell -> Cell
slamDownOutput cell =
  cell # _output .. _VarMap  %~ modifyVarMap
  where
    modifyVarMap m = foldl (\m (Tuple key val) -> SM.insert key val m) m tplLst
    tplLst = maybe L.Nil SM.toList ((fromFormValue <$>) <$> state)
    fromFormValue (SingleValue PlainText s) = quoteString s
    fromFormValue (SingleValue Numeric s) = quoteStringNumeric s
    fromFormValue (SingleValue Date s) = "DATE '" ++ s ++ "'"
    fromFormValue (SingleValue Time s) = "TIME '" ++ s ++ "'"
    fromFormValue (SingleValue DateTime s) = "TIMESTAMP '" ++ processTimestamp s ++ "'"
    fromFormValue (MultipleValues s) = "[" <> intercalate ", " (quoteString <$> S.toList s) <> "]" -- TODO: is this anything like we want for multi-values?
    state :: Maybe (SM.StrMap FormFieldValue)
    state = cell ^? _content.._Markdown..Ma._state.._SlamDownState
    processTimestamp s = s ++ ":00Z"
    quoteString s = "'" ++ Rx.replace rxQuot "''" s ++ "'"
    quoteStringNumeric s | isSQLNum s = s
                         | otherwise = quoteString s
    rxQuot = Rx.regex "'" Rx.noFlags { global = true }
    rxT = Rx.regex "T" Rx.noFlags
    isSQLNum s = isRight $ flip SP.runParser s $ do
      SP.many1 SP.anyDigit
      SP.optional $ SP.string "." *> SP.many SP.anyDigit
      SP.optional $ (SP.string "e" <|> SP.string "E")
                 *> (SP.string "-" <|> SP.string "+")
                 *> SP.many SP.anyDigit
      SP.eof

slamDownFields :: SlamDown -> Array (Tuple String FormField)
slamDownFields = everything (const []) go
  where
  go (FormField s _ ff) = [Tuple s ff]
  go _ = []

setSlamDownStatus :: Cell -> Cell
setSlamDownStatus cell =
  let input' = cell ^? _content.._Markdown..Ma._input
      message = ("Exported fields: " <>) <<< intercalate ", " <<< (fst <$>)
      initial md =
        let fields = slamDownFields md
            updateState (SlamDownState s) = case initSlamDownState md of
              SlamDownState s' ->
                let prunedSM = foldl (flip SM.delete) s $ keysToPrune s s'
                    mergedSM = prunedSM `SM.union` s'
                in SlamDownState mergedSM
        in slamDownOutput (cell # _message .~ message fields
                                # _content .. _Markdown .. Ma._state %~ updateState)
  in maybe cell (initial <<< parseMd) input'

  where
    formFieldValueType :: FormFieldValue -> Maybe TextBoxType
    formFieldValueType (SingleValue ty _) = Just ty
    formFieldValueType _ = Nothing

    formFieldValueTypeChanged :: FormFieldValue -> FormFieldValue -> Boolean
    formFieldValueTypeChanged old new = formFieldValueType old /= formFieldValueType new

    -- | Returns the keys that are either not present in the new state, or have had their types changed.
    keysToPrune :: SM.StrMap _ -> SM.StrMap _ -> Array _
    keysToPrune oldState newState =
      SM.foldMap
        (\key oldVal ->
          case SM.lookup key newState of
            Nothing -> [key]
            Just newVal ->
              if formFieldValueTypeChanged oldVal newVal then
                [key]
              else
                []
        )
        oldState

runSlamDownEvent :: SlamDownEvent -> Cell -> Cell
runSlamDownEvent event cell =
  cell # _content.._Markdown..Ma._state %~ flip applySlamDownEvent event

cellContent :: Either (NEL.NonEmpty FailureMessage) CellResultContent -> Cell -> Cell
cellContent = either (setFailures <<< NEL.toArray) success
  where
  success :: CellResultContent -> Cell -> Cell
  success (AceContent content) =
    setFailures [ ]
    <<< (_content.._AceContent .~ content)
  success (JTableContent content) =
    setFailures [ ]
    <<< (_content.._JTableContent .~ content)
  success (MarkdownContent content) =
    setFailures [ ]
    <<< (_content.._Markdown..Ma._evaluated ?~ content)

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

setFailures :: Array FailureMessage -> Cell -> Cell
setFailures fs (Cell o) = Cell $ o { failures = fs }

setRunState :: RunState -> Cell -> Cell
setRunState = modifyRunState <<< const

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'

depends :: Notebook -> CellId -> Cell -> Boolean
depends notebook cellId cell =
  isJust $ elemIndex cellId (ancestors (cell ^._cellId) (notebook ^._dependencies))


Add Show, Eq instances, restore primTypes list

module Language.PureScript.Environment where

import Data.Maybe
import Data.Tuple

import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.Types
import Language.PureScript.Show
import Language.PureScript.Values

import qualified Language.PureScript.Constants as C
import qualified Data.Map as M

-- |
-- The @Environment@ defines all values and types which are currently in scope:
--
data Environment = Environment {
  -- |
  -- Value names currently in scope
  --
    names :: M.Map (Tuple ModuleName Ident) (Tuple Type NameKind)
  -- |
  -- Type names currently in scope
  --
  , types :: M.Map (Qualified ProperName) (Tuple Kind TypeKind)
  -- |
  -- Data constructors currently in scope, along with their associated data type constructors
  --
  , dataConstructors :: M.Map (Qualified ProperName) (Tuple ProperName Type)
  -- |
  -- Type synonyms currently in scope
  --
  , typeSynonyms :: M.Map (Qualified ProperName) (Tuple [String] Type)
  -- |
  -- Available type class dictionaries
  --
  , typeClassDictionaries :: [TypeClassDictionaryInScope]
  -- |
  -- Type classes
  --
  , typeClasses :: M.Map (Qualified ProperName) (Tuple [String] [Tuple Ident Type])
  }

instance showEnv :: Show Environment where
  show = defaultShow

-- |
-- The initial environment with no values and only the default javascript types defined
--
initEnvironment :: Environment
initEnvironment = Environment { names: M.empty
                              , types: primTypes
                              , dataConstructors: M.empty
                              , typeSynonyms: M.empty
                              , typeClassDictionaries: []
                              , typeClasses: M.empty
                              }

-- |
-- The type of a foreign import
--
data ForeignImportType
  -- |
  -- A regular foreign import
  --
  = ForeignImport
  -- |
  -- A foreign import which contains inline Javascript as a string literal
  --
  | InlineJavascript
  -- |
  -- A type class dictionary member accessor import, generated during desugaring of type class declarations
  --
  | TypeClassAccessorImport

instance showForeignImport :: Show ForeignImportType where
  show = defaultShow

instance eqForeignImport :: Eq ForeignImportType where
  (==) ForeignImport           ForeignImport           = true
  (==) InlineJavascript        InlineJavascript        = true
  (==) TypeClassAccessorImport TypeClassAccessorImport = true
  (==) _ _ = false
  (/=) x y = not (x == y)

-- |
-- The kind of a name
--
data NameKind
  -- |
  -- A value introduced as a binding in a module
  --
  = Value
  -- |
  -- A foreign import
  --
  | Extern ForeignImportType
  -- |
  -- A local name introduced using a lambda abstraction, variable introduction or binder
  --
  | LocalVariable
  -- |
  -- A data constructor
  --
  | DataConstructor
  -- |
  -- A type class dictionary, generated during desugaring of type class declarations
  --
  | TypeInstanceDictionaryValue
  -- |
  -- A type instance member, generated during desugaring of type class declarations
  --
  | TypeInstanceMember

instance showNameKind :: Show NameKind where
  show = defaultShow

instance eqNameKind :: Eq NameKind where
  (==) Value                       Value                       = true
  (==) (Extern t1)                 (Extern t2)                 = t1 == t2
  (==) LocalVariable               LocalVariable               = true
  (==) DataConstructor             DataConstructor             = true
  (==) TypeInstanceDictionaryValue TypeInstanceDictionaryValue = true
  (==) TypeInstanceMember          TypeInstanceMember          = true
  (==) _ _ = false
  (/=) x y = not (x == y)

-- |
-- The kinds of a type
--
data TypeKind
  -- |
  -- Data type
  --
  = DataType [String] [Tuple ProperName [Type]]
  -- |
  -- Type synonym
  --
  | TypeSynonym
  -- |
  -- Foreign data
  --
  | ExternData
  -- |
  -- A local type variable
  --
  | LocalTypeVariable

instance showTypeKind :: Show TypeKind where
  show = defaultShow

instance eqTypeKind :: Eq TypeKind where
  (==) (DataType args1 tys1) (DataType args2 tys2) = args1 == args2 && tys1 == tys2
  (==) TypeSynonym           TypeSynonym           = true
  (==) ExternData            ExternData            = true
  (==) LocalTypeVariable     LocalTypeVariable     = true
  (==) _ _ = false
  (/=) x y = not (x == y)

-- |
-- Construct a ProperName in the Prim module
--
primName :: String -> Qualified ProperName
primName = Qualified (Just $ ModuleName [ProperName C.prim]) <<< ProperName

-- |
-- Construct a type in the Prim module
--
primTy :: String -> Type
primTy = TypeConstructor <<< primName

-- |
-- Type constructor for functions
--
tyFunction :: Type
tyFunction = primTy "Function"

-- |
-- Type constructor for strings
--
tyString :: Type
tyString = primTy "String"

-- |
-- Type constructor for numbers
--
tyNumber :: Type
tyNumber = primTy "Number"

-- |
-- Type constructor for booleans
--
tyBoolean :: Type
tyBoolean = primTy "Boolean"

-- |
-- Type constructor for arrays
--
tyArray :: Type
tyArray = primTy "Array"

-- |
-- Smart constructor for function types
--
function :: Type -> Type -> Type
function t1 = TypeApp (TypeApp tyFunction t1)

-- |
-- The primitive types in the external javascript environment with their associated kinds.
--
primTypes :: M.Map (Qualified ProperName) (Tuple Kind TypeKind)
primTypes = M.fromList [ Tuple (primName "Function") (Tuple (FunKind Star (FunKind Star Star)) ExternData)
                       , Tuple (primName "Array")    (Tuple (FunKind Star Star) ExternData)
                       , Tuple (primName "String")   (Tuple Star ExternData)
                       , Tuple (primName "Number")   (Tuple Star ExternData)
                       , Tuple (primName "Boolean")  (Tuple Star ExternData) ]

module Language.PureScript.Environment where

import Prelude
import Data.Maybe
import Data.Tuple
import Language.PureScript.Names
import Language.PureScript.Types
import Language.PureScript.Kinds
import Language.PureScript.Values
import qualified Language.PureScript.Constants as C
import qualified Data.Map as M

-- |
-- The @Environment@ defines all values and types which are currently in scope:
--
data Environment = Environment {
  -- |
  -- Value names currently in scope
  --
    names :: M.Map (Tuple ModuleName Ident) (Tuple Type NameKind)
  -- |
  -- Type names currently in scope
  --
  , types :: M.Map (Qualified ProperName) (Tuple Kind TypeKind)
  -- |
  -- Data constructors currently in scope, along with their associated data type constructors
  --
  , dataConstructors :: M.Map (Qualified ProperName) (Tuple ProperName Type)
  -- |
  -- Type synonyms currently in scope
  --
  , typeSynonyms :: M.Map (Qualified ProperName) (Tuple [String] Type)
  -- |
  -- Available type class dictionaries
  --
  , typeClassDictionaries :: [TypeClassDictionaryInScope]
  -- |
  -- Type classes
  --
  , typeClasses :: M.Map (Qualified ProperName) (Tuple [String] [Tuple Ident Type])
  }

  -- TODO: deriving (Show)

-- |
-- The initial environment with no values and only the default javascript types defined
--
initEnvironment :: Environment
initEnvironment = Environment { names: M.empty
                              , types: primTypes
                              , dataConstructors: M.empty
                              , typeSynonyms: M.empty
                              , typeClassDictionaries: []
                              , typeClasses: M.empty
                              }

-- |
-- The type of a foreign import
--
data ForeignImportType
  -- |
  -- A regular foreign import
  --
  = ForeignImport
  -- |
  -- A foreign import which contains inline Javascript as a string literal
  --
  | InlineJavascript
  -- |
  -- A type class dictionary member accessor import, generated during desugaring of type class declarations
  --
  | TypeClassAccessorImport

  -- TODO: deriving (Show, Eq, Data, Typeable)

-- |
-- The kind of a name
--
data NameKind
  -- |
  -- A value introduced as a binding in a module
  --
  = Value
  -- |
  -- A foreign import
  --
  | Extern ForeignImportType
  -- |
  -- A local name introduced using a lambda abstraction, variable introduction or binder
  --
  | LocalVariable
  -- |
  -- A data constructor
  --
  | DataConstructor
  -- |
  -- A type class dictionary, generated during desugaring of type class declarations
  --
  | TypeInstanceDictionaryValue
  -- |
  -- A type instance member, generated during desugaring of type class declarations
  --
  | TypeInstanceMember

  -- TODO: deriving (Show, Eq, Data, Typeable)

-- |
-- The kinds of a type
--
data TypeKind
  -- |
  -- Data type
  --
  = DataType [String] [Tuple ProperName [Type]]
  -- |
  -- Type synonym
  --
  | TypeSynonym
  -- |
  -- Foreign data
  --
  | ExternData
  -- |
  -- A local type variable
  --
  | LocalTypeVariable

  -- TODO: deriving (Show, Eq, Data, Typeable)

-- |
-- Construct a ProperName in the Prim module
--
primName :: String -> Qualified ProperName
primName = Qualified (Just $ ModuleName [ProperName C.prim]) <<< ProperName

-- |
-- Construct a type in the Prim module
--
primTy :: String -> Type
primTy = TypeConstructor <<< primName

-- |
-- Type constructor for functions
--
tyFunction :: Type
tyFunction = primTy "Function"

-- |
-- Type constructor for strings
--
tyString :: Type
tyString = primTy "String"

-- |
-- Type constructor for numbers
--
tyNumber :: Type
tyNumber = primTy "Number"

-- |
-- Type constructor for booleans
--
tyBoolean :: Type
tyBoolean = primTy "Boolean"

-- |
-- Type constructor for arrays
--
tyArray :: Type
tyArray = primTy "Array"

-- |
-- Smart constructor for function types
--
function :: Type -> Type -> Type
function t1 = TypeApp (TypeApp tyFunction t1)

-- |
-- The primitive types in the external javascript environment with their associated kinds.
--
primTypes :: M.Map (Qualified ProperName) (Tuple Kind TypeKind)
primTypes = M.empty
{- TODO: ord instances
            M.fromList [ Tuple (primName "Function") (Tuple (FunKind Star (FunKind Star Star)) ExternData)
                       , Tuple (primName "Array")    (Tuple (FunKind Star Star) ExternData)
                       , Tuple (primName "String")   (Tuple Star ExternData)
                       , Tuple (primName "Number")   (Tuple Star ExternData)
                       , Tuple (primName "Boolean")  (Tuple Star ExternData) ]
-}


microopt (:

microopt (:

module Physics.Electricity where

import Math
import Math.Vec3
import Data.Array (map)

type Charge = { value :: Number, position :: Vec3 }

-- vacuum permittivity
vacuum_e0 = 8.854187817e-12

vacuum_k = let x = 4 * pi * vacuum_e0 in 1 / x

charge :: Number -> Vec3 -> Charge
charge val pos = { value: val, position: pos }

electric_field :: Charge -> Vec3 -> Vec3
electric_field charge point =
  d .* (charge.value / dl')
  where
    d   = point - charge.position
    dl  = length_sq d
    dl' = dl * sqrt dl

electric_field_k :: Charge -> Vec3 -> Vec3
electric_field_k c p = electric_field c p .* vacuum_k

electric_field_many :: [Charge] -> Vec3 -> Vec3
electric_field_many cs p = v3_sum $ map ((flip electric_field) p) cs

electric_field_k_many :: [Charge] -> Vec3 -> Vec3
electric_field_k_many cs p = electric_field_many cs p .* vacuum_k

module Physics.Electricity where

import Math
import Math.Vec3
import Data.Array (map)

type Charge = { value :: Number, position :: Vec3 }

-- vacuum permittivity
vacuum_e0 = 8.854187817e-12

vacuum_k = let x = 4 * pi * vacuum_e0 in 1 / x

charge :: Number -> Vec3 -> Charge
charge val pos = { value: val, position: pos }

electric_field :: Charge -> Vec3 -> Vec3
electric_field charge point =
  norm d .* (charge.value / length_sq d)
  where
    d = point - charge.position

electric_field_k :: Charge -> Vec3 -> Vec3
electric_field_k c p = electric_field c p .* vacuum_k

electric_field_many :: [Charge] -> Vec3 -> Vec3
electric_field_many cs p = v3_sum $ map ((flip electric_field) p) cs

electric_field_k_many :: [Charge] -> Vec3 -> Vec3
electric_field_k_many cs p = electric_field_many cs p .* vacuum_k