fixes line secondValue

fixes line secondValue

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

import SlamData.Prelude

import Control.Monad.State (class MonadState)
import Control.Monad.Throw (class MonadThrow)

import Data.Argonaut (JArray, Json)
import Data.Array as A
import Data.Foldable as F
import Data.Int as Int
import Data.Lens ((^?), _Just)
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 SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Workspace.Card.CardType.ChartType (ChartType(Line))
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis (Axes)
import SlamData.Workspace.Card.Setups.Axis as Ax
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors)
import SlamData.Workspace.Card.Setups.Chart.Common.Positioning as BCP
import SlamData.Workspace.Card.Setups.Chart.Line.Model (Model, ModelR)
import SlamData.Workspace.Card.Setups.Common.Eval (type (>>))
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics (getMaybeString, getValues)
import SlamData.Workspace.Card.Setups.Transform as T
import SlamData.Workspace.Card.Setups.Transform.Aggregation as Ag

eval
  ∷ ∀ m
  . ( MonadState CEM.CardState m
    , MonadThrow CEM.CardError m
    , QuasarDSL m
    )
  ⇒ Model
  → Port.Resource
  → m Port.Port
eval m = BCE.buildChartEval Line buildLine m \axes → m

type LineSerie =
  { name ∷ Maybe String
  , leftItems ∷ String >> {value ∷ Number, symbolSize ∷ Int}
  , rightItems ∷ String >> {value ∷ Number, symbolSize ∷ Int}
  }

buildLineData ∷ ModelR → JArray → Array LineSerie
buildLineData r records = series
  where
  -- | maybe series >> dimension >> left values × right values × symbol sizes
  dataMap ∷ Maybe String >> String >> (Array Number × Array Number × Array Number)
  dataMap =
    foldl dataMapFoldFn M.empty records

  dataMapFoldFn
    ∷ Maybe String >> String >> (Array Number × Array Number × Array Number)
    → Json
    → Maybe String >> String >> (Array Number × Array Number × Array Number)
  dataMapFoldFn acc js =
    let
      getMaybeStringFromJson = getMaybeString js
      getValuesFromJson = getValues js
    in case getMaybeStringFromJson =<< r.dimension ^? D._value ∘ D._projection of
      Nothing → acc
      Just dimKey →
        let
          mbSeries =
            getMaybeStringFromJson =<< r.series ^? _Just ∘ D._value ∘ D._projection
          leftValues =
            getValuesFromJson $ r.value ^? D._value ∘ D._projection
          rightValues =
            getValuesFromJson $ r.secondValue ^? _Just ∘ D._value ∘ D._projection
          sizes
            | r.optionalMarkers = [ ]
            | otherwise = getValuesFromJson $ r.size ^? _Just ∘ D._value ∘ D._projection

          alterSeriesFn
            ∷ Maybe (String >> (Array Number × Array Number × Array Number))
            → Maybe (String >> (Array Number × Array Number × Array Number))
          alterSeriesFn Nothing =
            Just $ M.singleton dimKey $ leftValues × rightValues × sizes
          alterSeriesFn (Just dims) =
            Just $ M.alter alterDimFn dimKey dims

          alterDimFn
            ∷ Maybe (Array Number × Array Number × Array Number)
            → Maybe (Array Number × Array Number × Array Number)
          alterDimFn Nothing =
            Just $ leftValues × rightValues × sizes
          alterDimFn (Just (ls × rs × ss)) =
            Just $ (ls ⊕ leftValues) × (rs ⊕ rightValues) × (ss ⊕ sizes)
        in
          M.alter alterSeriesFn mbSeries acc

  series ∷ Array LineSerie
  series =
    foldMap mkLineSerie $ M.toList dataMap

  mkLineSerie
    ∷ Maybe String × (String >> (Array Number × Array Number × Array Number))
    → Array LineSerie
  mkLineSerie (name × items) =
    [{ name
     , leftItems: adjustSymbolSizes $ map mkLeftItem items
     , rightItems: adjustSymbolSizes $ map mkRightItem items
     } ]

  mkLeftItem
    ∷ Array Number × Array Number × Array Number
    → {value ∷ Number, symbolSize ∷ Int}
  mkLeftItem (ls × _ × ss) =
    let
      value =
        flip Ag.runAggregation ls
        $ fromMaybe Ag.Sum
        $ r.value ^? D._value ∘ D._transform ∘ _Just ∘ T._Aggregation
      symbolSize
        | r.optionalMarkers = Int.floor r.minSize
        | otherwise =
          Int.floor
          $ flip Ag.runAggregation ss
          $ fromMaybe Ag.Sum
          $ r.size ^? _Just ∘ D._value ∘ D._transform ∘ _Just ∘ T._Aggregation

    in {value, symbolSize}

  mkRightItem
    ∷ Array Number × Array Number × Array Number
    → {value ∷ Number, symbolSize ∷ Int}
  mkRightItem (_ × rs × ss) =
    case r.secondValue ^? _Just ∘ D._value ∘ D._transform ∘ _Just ∘ T._Aggregation  of
      Nothing → {symbolSize: zero, value: zero}
      Just valAgg →
        let
          value = Ag.runAggregation valAgg rs
          symbolSize
            | r.optionalMarkers = Int.floor r.minSize
            | otherwise =
              Int.floor
              $ flip Ag.runAggregation ss
              $ fromMaybe Ag.Sum
              $ r.size ^? _Just ∘ D._value ∘ D._transform ∘ _Just ∘ T._Aggregation
        in {value, symbolSize}

  adjustSymbolSizes
    ∷ ∀ f
    . (Functor f, Foldable f)
    ⇒ f {value ∷ Number, symbolSize ∷ Int}
    → f {value ∷ Number, symbolSize ∷ Int}
  adjustSymbolSizes items
    | r.optionalMarkers = items
    | otherwise =
      let
        minValue ∷ Number
        minValue =
          Int.toNumber
            $ fromMaybe bottom
            $ map _.symbolSize
            $ F.minimumBy (\a b → compare a.symbolSize b.symbolSize) items

        maxValue ∷ Number
        maxValue =
          Int.toNumber
            $ fromMaybe top
            $ map _.symbolSize
            $ F.maximumBy (\a b → compare a.symbolSize b.symbolSize) items

        distance ∷ Number
        distance =
          maxValue - minValue

        sizeDistance ∷ Number
        sizeDistance =
          r.maxSize - r.minSize

        relativeSize ∷ Int → Int
        relativeSize val
          | distance ≡ 0.0 = val
          | otherwise =
            Int.floor
            $ r.maxSize
            - sizeDistance / distance * (maxValue - Int.toNumber val)
      in
        map (\x → x{symbolSize = relativeSize x.symbolSize}) items

buildLine ∷ Axes → ModelR → JArray → DSL OptionI
buildLine axes r records = do
  E.tooltip case r.size of
    Just _ → E.triggerItem
    Nothing → E.triggerAxis
  E.colors colors
  E.grid BCP.cartesian
  E.series series

  E.xAxis do
    E.axisType xAxisConfig.axisType
    case xAxisConfig.axisType of
      ET.Category →
        E.items $ map ET.strItem xValues
      _ → pure unit
    E.axisLabel do
      E.rotate r.axisLabelAngle
      traverse_ E.interval xAxisConfig.interval
      E.textStyle do
        E.fontFamily "Ubuntu, sans"

  E.yAxes do
    E.addYAxis yAxis
    when needTwoAxes $ E.addYAxis yAxis

  E.legend do
    E.items $ map ET.strItem seriesNames
    E.textStyle $ E.fontFamily "Ubuntu, sans"

  where
  lineData ∷ Array LineSerie
  lineData = buildLineData r records

  xAxisType ∷ Ax.AxisType
  xAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType
    <$> (r.dimension ^? D._value ∘ D._projection)
    <*> (pure axes)

  xAxisConfig ∷ Ax.EChartsAxisConfiguration
  xAxisConfig = Ax.axisConfiguration xAxisType

  xSortFn ∷ String → String → Ordering
  xSortFn = Ax.compareWithAxisType xAxisType

  xValues ∷ Array String
  xValues =
    A.sortBy xSortFn
      $ A.fromFoldable
      $ foldMap (\x → Set.fromFoldable $ M.keys x.leftItems ⊕ M.keys x.rightItems)
        lineData

  seriesNames ∷ Array String
  seriesNames = case r.series of
    Just _ → A.fromFoldable $ foldMap (_.name ⋙ foldMap Set.singleton) lineData
    Nothing →
      map show
      $ A.catMaybes
      [ r.value ^? D._value ∘ D._projection
      , r.secondValue ^? _Just ∘ D._value ∘ D._projection
      ]

  needTwoAxes ∷ Boolean
  needTwoAxes = isJust r.secondValue

  series ∷ ∀ i. DSL (line ∷ ETP.I|i)
  series = for_ lineData \lineSerie → do
    E.line do
      E.buildItems $ for_ xValues \key →
        case M.lookup key lineSerie.leftItems of
          Nothing → E.missingItem
          Just {value, symbolSize} → E.addItem do
            E.name key
            E.buildValues do
              E.addStringValue key
              E.addValue value
            E.symbolSize symbolSize
      E.yAxisIndex 0
      case r.series of
        Just _ →
          for_ lineSerie.name E.name
        Nothing →
          traverse_ (E.name ∘ show) $ r.value ^? D._value ∘ D._projection

    when needTwoAxes $ E.line do
      E.buildItems $ for_ xValues \key →
        case M.lookup key lineSerie.rightItems of
          Nothing → E.missingItem
          Just {value, symbolSize} → E.addItem do
            E.name key
            E.buildValues do
              E.addStringValue key
              E.addValue value
            E.symbolSize symbolSize
      E.yAxisIndex 1
      case r.series of
        Just _ →
          for_ lineSerie.name E.name
        Nothing →
          traverse_ (E.name ∘ show) $ r.secondValue ^? _Just ∘ D._value ∘ D._projection

  yAxis ∷ DSL ETP.YAxisI
  yAxis = do
    E.axisType ET.Value
    E.axisLabel $ E.textStyle do
      E.fontFamily "Ubuntu, sans"

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

import SlamData.Prelude

import Control.Monad.State (class MonadState)
import Control.Monad.Throw (class MonadThrow)

import Data.Argonaut (JArray, Json)
import Data.Array as A
import Data.Foldable as F
import Data.Int as Int
import Data.Lens ((^?), _Just)
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 SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Workspace.Card.CardType.ChartType (ChartType(Line))
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis (Axes)
import SlamData.Workspace.Card.Setups.Axis as Ax
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors)
import SlamData.Workspace.Card.Setups.Chart.Common.Positioning as BCP
import SlamData.Workspace.Card.Setups.Chart.Line.Model (Model, ModelR)
import SlamData.Workspace.Card.Setups.Common.Eval (type (>>))
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics (getMaybeString, getValues)
import SlamData.Workspace.Card.Setups.Transform as T
import SlamData.Workspace.Card.Setups.Transform.Aggregation as Ag

eval
  ∷ ∀ m
  . ( MonadState CEM.CardState m
    , MonadThrow CEM.CardError m
    , QuasarDSL m
    )
  ⇒ Model
  → Port.Resource
  → m Port.Port
eval m = BCE.buildChartEval Line buildLine m \axes → m

type LineSerie =
  { name ∷ Maybe String
  , leftItems ∷ String >> {value ∷ Number, symbolSize ∷ Int}
  , rightItems ∷ String >> {value ∷ Number, symbolSize ∷ Int}
  }

buildLineData ∷ ModelR → JArray → Array LineSerie
buildLineData r records = series
  where
  -- | maybe series >> dimension >> left values × right values × symbol sizes
  dataMap ∷ Maybe String >> String >> (Array Number × Array Number × Array Number)
  dataMap =
    foldl dataMapFoldFn M.empty records

  dataMapFoldFn
    ∷ Maybe String >> String >> (Array Number × Array Number × Array Number)
    → Json
    → Maybe String >> String >> (Array Number × Array Number × Array Number)
  dataMapFoldFn acc js =
    let
      getMaybeStringFromJson = getMaybeString js
      getValuesFromJson = getValues js
    in case getMaybeStringFromJson =<< r.dimension ^? D._value ∘ D._projection of
      Nothing → acc
      Just dimKey →
        let
          mbSeries =
            getMaybeStringFromJson =<< r.series ^? _Just ∘ D._value ∘ D._projection
          leftValues =
            getValuesFromJson $ r.value ^? D._value ∘ D._projection
          rightValues =
            getValuesFromJson $ r.secondValue ^? _Just ∘ D._value ∘ D._projection
          sizes
            | r.optionalMarkers = [ ]
            | otherwise = getValuesFromJson $ r.size ^? _Just ∘ D._value ∘ D._projection

          alterSeriesFn
            ∷ Maybe (String >> (Array Number × Array Number × Array Number))
            → Maybe (String >> (Array Number × Array Number × Array Number))
          alterSeriesFn Nothing =
            Just $ M.singleton dimKey $ leftValues × rightValues × sizes
          alterSeriesFn (Just dims) =
            Just $ M.alter alterDimFn dimKey dims

          alterDimFn
            ∷ Maybe (Array Number × Array Number × Array Number)
            → Maybe (Array Number × Array Number × Array Number)
          alterDimFn Nothing =
            Just $ leftValues × rightValues × sizes
          alterDimFn (Just (ls × rs × ss)) =
            Just $ (ls ⊕ leftValues) × (rs ⊕ rightValues) × (ss ⊕ sizes)
        in
          M.alter alterSeriesFn mbSeries acc

  series ∷ Array LineSerie
  series =
    foldMap mkLineSerie $ M.toList dataMap

  mkLineSerie
    ∷ Maybe String × (String >> (Array Number × Array Number × Array Number))
    → Array LineSerie
  mkLineSerie (name × items) =
    [{ name
     , leftItems: adjustSymbolSizes $ map mkLeftItem items
     , rightItems: adjustSymbolSizes $ map mkRightItem items
     } ]

  mkLeftItem
    ∷ Array Number × Array Number × Array Number
    → {value ∷ Number, symbolSize ∷ Int}
  mkLeftItem (ls × _ × ss) =
    let
      value =
        flip Ag.runAggregation ls
        $ fromMaybe Ag.Sum
        $ r.value ^? D._value ∘ D._transform ∘ _Just ∘ T._Aggregation
      symbolSize
        | r.optionalMarkers = Int.floor r.minSize
        | otherwise =
          Int.floor
          $ flip Ag.runAggregation ss
          $ fromMaybe Ag.Sum
          $ r.size ^? _Just ∘ D._value ∘ D._transform ∘ _Just ∘ T._Aggregation

    in {value, symbolSize}

  mkRightItem
    ∷ Array Number × Array Number × Array Number
    → {value ∷ Number, symbolSize ∷ Int}
  mkRightItem (_ × rs × ss) =
    case r.secondValue ^? _Just ∘ D._value ∘ D._transform ∘ _Just ∘ T._Aggregation  of
      Nothing → {symbolSize: zero, value: zero}
      Just valAgg →
        let
          value = Ag.runAggregation valAgg ss
          symbolSize
            | r.optionalMarkers = Int.floor r.minSize
            | otherwise =
              Int.floor
              $ flip Ag.runAggregation ss
              $ fromMaybe Ag.Sum
              $ r.size ^? _Just ∘ D._value ∘ D._transform ∘ _Just ∘ T._Aggregation
        in {value, symbolSize}

  adjustSymbolSizes
    ∷ ∀ f
    . (Functor f, Foldable f)
    ⇒ f {value ∷ Number, symbolSize ∷ Int}
    → f {value ∷ Number, symbolSize ∷ Int}
  adjustSymbolSizes items
    | r.optionalMarkers = items
    | otherwise =
      let
        minValue ∷ Number
        minValue =
          Int.toNumber
            $ fromMaybe bottom
            $ map _.symbolSize
            $ F.minimumBy (\a b → compare a.symbolSize b.symbolSize) items

        maxValue ∷ Number
        maxValue =
          Int.toNumber
            $ fromMaybe top
            $ map _.symbolSize
            $ F.maximumBy (\a b → compare a.symbolSize b.symbolSize) items

        distance ∷ Number
        distance =
          maxValue - minValue

        sizeDistance ∷ Number
        sizeDistance =
          r.maxSize - r.minSize

        relativeSize ∷ Int → Int
        relativeSize val
          | distance ≡ 0.0 = val
          | otherwise =
            Int.floor
            $ r.maxSize
            - sizeDistance / distance * (maxValue - Int.toNumber val)
      in
        map (\x → x{symbolSize = relativeSize x.symbolSize}) items

buildLine ∷ Axes → ModelR → JArray → DSL OptionI
buildLine axes r records = do
  E.tooltip case r.size of
    Just _ → E.triggerItem
    Nothing → E.triggerAxis
  E.colors colors
  E.grid BCP.cartesian
  E.series series

  E.xAxis do
    E.axisType xAxisConfig.axisType
    case xAxisConfig.axisType of
      ET.Category →
        E.items $ map ET.strItem xValues
      _ → pure unit
    E.axisLabel do
      E.rotate r.axisLabelAngle
      traverse_ E.interval xAxisConfig.interval
      E.textStyle do
        E.fontFamily "Ubuntu, sans"

  E.yAxes do
    E.addYAxis yAxis
    when needTwoAxes $ E.addYAxis yAxis

  E.legend do
    E.items $ map ET.strItem seriesNames
    E.textStyle $ E.fontFamily "Ubuntu, sans"

  where
  lineData ∷ Array LineSerie
  lineData = buildLineData r records

  xAxisType ∷ Ax.AxisType
  xAxisType =
    fromMaybe Ax.Category
    $ Ax.axisType
    <$> (r.dimension ^? D._value ∘ D._projection)
    <*> (pure axes)

  xAxisConfig ∷ Ax.EChartsAxisConfiguration
  xAxisConfig = Ax.axisConfiguration xAxisType

  xSortFn ∷ String → String → Ordering
  xSortFn = Ax.compareWithAxisType xAxisType

  xValues ∷ Array String
  xValues =
    A.sortBy xSortFn
      $ A.fromFoldable
      $ foldMap (\x → Set.fromFoldable $ M.keys x.leftItems ⊕ M.keys x.rightItems)
        lineData

  seriesNames ∷ Array String
  seriesNames = case r.series of
    Just _ → A.fromFoldable $ foldMap (_.name ⋙ foldMap Set.singleton) lineData
    Nothing →
      map show
      $ A.catMaybes
      [ r.value ^? D._value ∘ D._projection
      , r.secondValue ^? _Just ∘ D._value ∘ D._projection
      ]

  needTwoAxes ∷ Boolean
  needTwoAxes = isJust r.secondValue

  series ∷ ∀ i. DSL (line ∷ ETP.I|i)
  series = for_ lineData \lineSerie → do
    E.line do
      E.buildItems $ for_ xValues \key →
        case M.lookup key lineSerie.leftItems of
          Nothing → E.missingItem
          Just {value, symbolSize} → E.addItem do
            E.name key
            E.buildValues do
              E.addStringValue key
              E.addValue value
            E.symbolSize symbolSize
      E.yAxisIndex 0
      case r.series of
        Just _ →
          for_ lineSerie.name E.name
        Nothing →
          traverse_ (E.name ∘ show) $ r.value ^? D._value ∘ D._projection

    when needTwoAxes $ E.line do
      E.buildItems $ for_ xValues \key →
        case M.lookup key lineSerie.rightItems of
          Nothing → E.missingItem
          Just {value, symbolSize} → E.addItem do
            E.name key
            E.buildValues do
              E.addStringValue key
              E.addValue value
            E.symbolSize symbolSize
      E.yAxisIndex 1
      case r.series of
        Just _ →
          for_ lineSerie.name E.name
        Nothing →
          traverse_ (E.name ∘ show) $ r.secondValue ^? _Just ∘ D._value ∘ D._projection

  yAxis ∷ DSL ETP.YAxisI
  yAxis = do
    E.axisType ET.Value
    E.axisLabel $ E.textStyle do
      E.fontFamily "Ubuntu, sans"


abstract the tab headers

abstract the tab headers

module Views.Input where

import qualified Thermite.Events as T
import qualified Thermite.Html as H
import qualified Thermite.Html.Attributes as A
import qualified Thermite.Html.Elements as E
import qualified Thermite.Types as T

import Helpers.Html
import Models.Action
import Models.Input

handleKeyPress :: T.KeyboardEvent -> Action
handleKeyPress e =
	case getKeyCode e of
		13 ->
			let value = getValue e
			in
				case value of
					"" -> DoNothing
					otherwise -> SendMessage $ value
		27 -> SetEditText ""
		_  -> DoNothing

handleChangeEvent :: T.FormEvent -> Models.Action.Action
handleChangeEvent e = SetEditText (getValue e)

inputField ctx st =
	case st.selectedInputType of
		TextInput ->
			E.textarea
				[ A.className "text-input-field"
				, A.placeholder "enter a message"
				, T.onKeyUp ctx handleKeyPress
				, T.onChange ctx handleChangeEvent
				, A.value st.editText
				]
				[ ]
		CodeInput ->
			H.text "CodeInput"
		FormulaInput ->
			H.text "FormulaInput"
		FileInput ->
			H.text "FileInput"

inputTypeSelectTabHead :: T.Context Models.State.State Unit Models.Action.Action -> InputType -> String ->  Thermite.Types.Html Models.Action.Action
inputTypeSelectTabHead ctx inputType text =
	E.span [ T.onClick ctx (const $ SelectInputType inputType) ] [ H.text text ]

inputTypeSelector :: T.Context Models.State.State Unit Models.Action.Action -> InputType -> Thermite.Types.Html Models.Action.Action
inputTypeSelector ctx textInput =
	E.div [ ]
		[ inputTypeSelectTabHead ctx TextInput "Text"
		, inputTypeSelectTabHead ctx CodeInput "Code"
		, inputTypeSelectTabHead ctx FormulaInput "Formula"
		, inputTypeSelectTabHead ctx FileInput "File"
		]

messageInput ctx st =
	E.div [ A.className "input-field-container" ]
		[ inputTypeSelector ctx st.selectedInputType
		, inputField ctx st
		]

module Views.Input where

import qualified Thermite.Events as T
import qualified Thermite.Html as H
import qualified Thermite.Html.Attributes as A
import qualified Thermite.Html.Elements as E
import qualified Thermite.Types as T

import Helpers.Html
import Models.Action
import Models.Input

handleKeyPress :: T.KeyboardEvent -> Action
handleKeyPress e =
	case getKeyCode e of
		13 ->
			let value = getValue e
			in
				case value of
					"" -> DoNothing
					otherwise -> SendMessage $ value
		27 -> SetEditText ""
		_  -> DoNothing

handleChangeEvent :: T.FormEvent -> Models.Action.Action
handleChangeEvent e = SetEditText (getValue e)

inputField ctx st =
	case st.selectedInputType of
		TextInput ->
			E.textarea
				[ A.className "text-input-field"
				, A.placeholder "enter a message"
				, T.onKeyUp ctx handleKeyPress
				, T.onChange ctx handleChangeEvent
				, A.value st.editText
				]
				[ ]
		CodeInput ->
			H.text "CodeInput"
		FormulaInput ->
			H.text "FormulaInput"
		FileInput ->
			H.text "FileInput"

inputTypeSelector :: T.Context Models.State.State Unit Models.Action.Action -> InputType -> Thermite.Types.Html Models.Action.Action
inputTypeSelector ctx textInput =
	E.div [ ]
		[ E.span [ T.onClick ctx (const $ SelectInputType TextInput) ] [ H.text "Text" ]
		, E.span [ T.onClick ctx (const $ SelectInputType CodeInput) ] [ H.text "Code" ]
		, E.span [ T.onClick ctx (const $ SelectInputType FormulaInput) ] [ H.text "Formula" ]
		, E.span [ T.onClick ctx (const $ SelectInputType FileInput) ] [ H.text "File" ]
		]

messageInput ctx st =
	E.div [ A.className "input-field-container" ]
		[ inputTypeSelector ctx st.selectedInputType
		, inputField ctx st
		]


Be more specific in message handling in vars component

{-
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.Variables.Component (variablesComponent) where

import SlamData.Prelude

import Data.Array as A
import Data.List as L

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE

import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.FormBuilder.Component as FB
import SlamData.Workspace.LevelOfDetails as LOD

type State = Unit
data Query a = HandleMessage FB.Message a

type DSL = CC.InnerCardParentDSL State Query FB.Query
type HTML = CC.InnerCardParentHTML Query FB.Query

variablesComponent ∷ CC.CardOptions → CC.CardComponent
variablesComponent =
  CC.makeCardComponent CT.Variables $ H.parentComponent
    { render: render
    , eval: evalCard ⨁ evalComponent
    , initialState: const unit
    , receiver: const Nothing
    }

render ∷ State → HTML
render _ =
  HH.slot
    unit
    FB.formBuilderComponent
    unit
    (HE.input $ map right ∘ HandleMessage)

evalCard ∷ CC.CardEvalQuery ~> DSL
evalCard = case _ of
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k →
    H.query unit (H.request FB.GetItems) <#>
      maybe [] A.fromFoldable
        ⋙ { items: _ }
        ⋙ Card.Variables
        ⋙ k
  CC.Load card next → do
    case card of
      Card.Variables { items } →
        void ∘ H.query unit $ H.action (FB.SetItems (L.fromFoldable items))
      _ → pure unit
    pure next
  CC.ReceiveInput _ _ next →
    pure next
  CC.ReceiveOutput _ _ next →
    pure next
  CC.ReceiveState _ next →
    pure next
  CC.ReceiveDimensions _ reply →
    pure $ reply LOD.High

evalComponent ∷ Query ~> DSL
evalComponent = case _ of
  HandleMessage FB.ItemUpdated next → do
    H.raise $ CC.ModelUpdated CC.EvalModelUpdate
    pure next

{-
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.Variables.Component (variablesComponent) where

import SlamData.Prelude

import Data.Array as A
import Data.List as L

import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE

import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.FormBuilder.Component as FB
import SlamData.Workspace.LevelOfDetails as LOD

type State = Unit
data Query a = HandleMessage FB.Message a

type DSL = CC.InnerCardParentDSL State Query FB.Query
type HTML = CC.InnerCardParentHTML Query FB.Query

variablesComponent ∷ CC.CardOptions → CC.CardComponent
variablesComponent =
  CC.makeCardComponent CT.Variables $ H.parentComponent
    { render: render
    , eval: evalCard ⨁ evalComponent
    , initialState: const unit
    , receiver: const Nothing
    }

render ∷ State → HTML
render _ =
  HH.slot
    unit
    FB.formBuilderComponent
    unit
    (HE.input $ map right ∘ HandleMessage)

evalCard ∷ CC.CardEvalQuery ~> DSL
evalCard = case _ of
  CC.Activate next →
    pure next
  CC.Deactivate next →
    pure next
  CC.Save k →
    H.query unit (H.request FB.GetItems) <#>
      maybe [] A.fromFoldable
        ⋙ { items: _ }
        ⋙ Card.Variables
        ⋙ k
  CC.Load card next → do
    case card of
      Card.Variables { items } →
        void ∘ H.query unit $ H.action (FB.SetItems (L.fromFoldable items))
      _ → pure unit
    pure next
  CC.ReceiveInput _ _ next →
    pure next
  CC.ReceiveOutput _ _ next →
    pure next
  CC.ReceiveState _ next →
    pure next
  CC.ReceiveDimensions _ reply →
    pure $ reply LOD.High

evalComponent ∷ Query ~> DSL
evalComponent = case _ of
  HandleMessage msg next → do
    H.raise $ CC.ModelUpdated CC.EvalModelUpdate
    pure next


Simplify set of tokens

Simplify set of tokens

module Language.Docopt.Parser.Lexer where

import Debug.Trace
import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import Control.Plus (empty)
import Control.Monad.State (State(), evalState, get)
import Control.Monad.Trans
import Data.Foldable (foldl)
import Data.String as Str
import Text.Parsing.Parser as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Token as P
import Text.Parsing.Parser.Pos as P
import Text.Parsing.Parser.String as P
import Data.List as L
import Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray, fromChar, trim)
import Data.List (List(..), (:), fromList, many)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe, fromMaybe, isNothing)
import Data.String.Ext ((^=))
import Language.Docopt.Parser.Base
import Language.Docopt.Parser.State
import Data.Tuple
import Data.Int
import Data.Int as I
import Global (isNaN, readFloat)

data Mode = Usage | Descriptions

isDescMode :: Mode -> Boolean
isDescMode Descriptions = true
isDescMode _ = false

isUsageMode :: Mode -> Boolean
isUsageMode Usage = true
isUsageMode _ = false

lex :: Mode -> String -> Either P.ParseError (List PositionedToken)
lex m = flip P.runParser (parseTokens m)

lexDescs :: String -> Either P.ParseError (List PositionedToken)
lexDescs = lex Descriptions

lexUsage :: String -> Either P.ParseError (List PositionedToken)
lexUsage = lex Usage

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | Dash
  | VBar
  | Colon
  | Comma
  | TripleDot
  | Reference String
  | LOpt String (Maybe { name :: String, optional :: Boolean })
  | SOpt Char (Array Char) (Maybe { name :: String, optional :: Boolean })
  | Tag String (Maybe String)
  | Name String
  | ShoutName String
  | AngleName String
  | Word String
  | Garbage Char
  | DoubleDash

prettyPrintToken :: Token -> String
prettyPrintToken LParen            = show '('
prettyPrintToken RParen            = show ')'
prettyPrintToken LSquare           = show '['
prettyPrintToken RSquare           = show ']'
prettyPrintToken Dash              = show '-'
prettyPrintToken VBar              = show '|'
prettyPrintToken Colon             = show ':'
prettyPrintToken Comma             = show ','
prettyPrintToken TripleDot         = "..."
prettyPrintToken DoubleDash        = "--"
prettyPrintToken (Reference r)     = "Reference " ++ show r
prettyPrintToken (Garbage   c)     = "Garbage "   ++ show c
prettyPrintToken (Tag k v)         = "Tag "       ++ k ++ " "  ++ (show v)
prettyPrintToken (Name      n)     = "Name "      ++ show n
prettyPrintToken (ShoutName n)     = "ShoutName " ++ show n
prettyPrintToken (AngleName n)     = "AngleName " ++ show n
prettyPrintToken (Word w)          = "Word "      ++ show w
prettyPrintToken (LOpt n arg)
  = "--" ++ n
         ++ (fromMaybe "" do
              a <- arg
              return $ if a.optional then "[" else ""
                ++ a.name
                ++ if a.optional then "]" else ""
            )
prettyPrintToken (SOpt n s arg)
  = "-" ++ (fromCharArray (A.cons n s))
        ++ (fromMaybe "" do
              a <- arg
              return $ if a.optional then "[" else ""
                ++ a.name
                ++ if a.optional then "]" else ""
            )

data PositionedToken = PositionedToken
  { sourcePos :: P.Position
  , token     :: Token
  }

instance showToken :: Show Token where
  show = show <<< prettyPrintToken

instance eqToken :: Eq Token where
  eq LParen            LParen             = true
  eq RParen            RParen             = true
  eq LSquare           LSquare            = true
  eq RSquare           RSquare            = true
  eq VBar              VBar               = true
  eq Colon             Colon              = true
  eq Comma             Comma              = true
  eq Dash              Dash               = true
  eq DoubleDash        DoubleDash         = true
  eq TripleDot         TripleDot          = true
  eq (Reference r)     (Reference r')     = r == r'
  eq (LOpt n arg)      (LOpt n' arg')
    = (n == n')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              return $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (SOpt n s arg)    (SOpt n' s' arg')
    = (n == n') && (s' == s')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              return $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (AngleName n)     (AngleName n')     = n == n'
  eq (ShoutName n)     (ShoutName n')     = n == n'
  eq (Word w)          (Word w')          = w == w'
  eq (Name n)          (Name n')          = n == n'
  eq (Garbage c)       (Garbage c')       = c == c'
  eq _ _                                  = false

instance showPositionedToken :: Show PositionedToken where
  show (PositionedToken { sourcePos=pos, token=tok }) =
    (show tok) ++ " at " ++ (show pos)

parseTokens :: Mode -> P.Parser String (L.List PositionedToken)
parseTokens m = do
  P.skipSpaces
  L.many $ parsePositionedToken m
  <* P.eof

parsePositionedToken :: Mode -> P.Parser String PositionedToken
parsePositionedToken m = P.try $ do
  pos <- getPosition
  tok <- parseToken m
  return $ PositionedToken { sourcePos: pos, token: tok }

parseToken :: Mode -> P.Parser String Token
parseToken m = P.choice (P.try <$> A.concat [
    [ P.char   '('   *> pure LParen
    , P.char   ')'   *> pure RParen
    ]
  , if isDescMode m then [ tag ] else []
  , [ reference
    , P.char   '['   *> pure LSquare
    , P.char   ']'   *> pure RSquare
    , P.char   '|'   *> pure VBar
    , P.char   ':'   *> pure Colon
    , P.char   ','   *> pure Comma
    , longOption
    , shortOption
    , AngleName <$> angleName
    , P.string "--"  *> pure DoubleDash
    , P.char   '-'   *> pure Dash
    , P.string "..." *> pure TripleDot
    , ShoutName <$> (shoutName <* P.notFollowedBy alpha)
    , Name      <$> (name      <* P.notFollowedBy alpha)
    , Word      <$> (word      <* space)
    , Garbage   <$> P.anyChar
    ]
  ])
  <* P.skipSpaces

 where

  whitespace :: P.Parser String Unit
  whitespace = do
    P.satisfy \c -> c == '\n' || c == '\r' || c == ' ' || c == '\t'
    pure unit

  reference :: P.Parser String Token
  reference = Reference <$> do
    P.between (P.char '[') (P.char ']') go

    where
      go = do
        many space
        x <- fromCharArray <<< fromList <$> do
          flip P.manyTill (P.lookAhead $ P.try end) do
            P.noneOf [']']
        end
        many space
        return x

      end = do
        many space
        P.optional $ P.string "-"
        string' "options"
        P.optional $ P.string "..."

  tag :: P.Parser String Token
  tag = P.between (P.char '[')
                  (P.char ']')
                  (withValue <|> withoutValue)

    where
      withValue = do
        many whitespace
        k <- fromCharArray <$> do A.many (P.noneOf [':'])
        P.char ':'
        many whitespace
        v <- trim <<< fromCharArray <$> do A.some $ P.noneOf [']']
        many whitespace
        return (Tag k (Just v))
      withoutValue = do
        k <- trim <<< fromCharArray <$> do A.some $ P.noneOf [']']
        return (Tag k Nothing)

  name :: P.Parser String String
  name = word

  shoutName :: P.Parser String String
  shoutName = do
    n <- fromCharArray <$> do
      A.cons
        <$> upperAlpha
        <*> (A.many $ regex "[A-Z_-]")
    P.notFollowedBy lowerAlpha
    return n

  word :: P.Parser String String
  word = do
    n  <- alphaNum
    ns <- do
      A.many $ P.try $ do
        P.choice $ P.try <$> [
          identLetter
        , P.char '.' <* (P.notFollowedBy $ P.string "..")
        , P.oneOf [ '-', '_' ]
      ]
    return $ fromCharArray (n A.: ns)

  angleName :: P.Parser String String
  angleName = do
    P.char '<'
    n <- fromCharArray <$> do
      A.some $ P.choice [
        identLetter
      , P.try $ P.noneOf [ '>' ]
      ]
    P.char '>'
    return n

  shortOption :: P.Parser String Token
  shortOption = do
    P.char '-'
    x  <- alphaNum
    xs <- A.many alphaNum

    arg <- P.choice $ P.try <$> [

      -- Case 1: OPTION = ARG
      Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        return { name:     n
               , optional: false
               }

      -- Case 2: Option[ = ARG ]
    , Just <$> do
        P.char '[' <* many space
        -- XXX: Drop the spaces?
        P.optional (many space *> P.char '=' <* many space)
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 3: Option[ARG]
    , Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '[' <* many space
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 4: Option<ARG>
    , Just <$> do
        n <- angleName
        return { name:     n
               , optional: false
               }

    , return Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.lookAhead $ P.choice [
      P.eof
    , P.try $ void $ P.whiteSpace
    , P.try $ void $ P.char ','
    , P.try $ void $ P.char '|'
    , P.try $ void $ P.char '['
    , P.try $ void $ P.char '('
    , P.try $ void $ P.string "..."
    ]

    return $ SOpt x xs arg

  longOption :: P.Parser String Token
  longOption = do
    P.string "--"

    name' <- fromCharArray <$> do
      A.cons
        <$> alphaNum
        <*> (A.many $ P.choice [
              alphaNum
            , P.oneOf [ '-' ] <* P.lookAhead alphaNum
            ])

    arg <- P.choice $ P.try <$> [

      -- Case 1: OPTION = ARG
      Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        return { name:     n
               , optional: false
               }

      -- Case 2: Option[ = ARG ]
    , Just <$> do
        P.char '[' <* many space
        -- XXX: Drop the spaces?
        P.optional (many space *> P.char '=' <* many space)
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 2: Option[ = ARG ]
    , Just <$> do
        P.char '[' <* many space
        -- XXX: Drop the spaces?
        P.optional (many space *> P.char '=' <* many space)
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 3: Option[ARG]
    , Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '[' <* many space
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

    , return Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.lookAhead $ P.choice [
      P.eof
    , P.try $ void $ P.whiteSpace
    , P.try $ void $ P.char ','
    , P.try $ void $ P.char '|'
    , P.try $ void $ P.char '['
    , P.try $ void $ P.char '('
    , P.try $ void $ P.string "..."
    ]

    return $ LOpt name' arg

  identStart :: P.Parser String Char
  identStart = alpha

  identLetter :: P.Parser String Char
  identLetter = alphaNum <|> P.oneOf ['_', '-']

  flag :: P.Parser String Char
  flag = lowerAlphaNum

-- | Parser that  parses a stream of tokens
type TokenParser a = P.ParserT (List PositionedToken) (State ParserState) a

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> TokenParser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      case test tok of
        Just a ->
          let nextpos =
              case xs of
                Cons (PositionedToken { sourcePos: npos }) _ -> npos
                Nil -> ppos
          in
            { consumed: true
            , input: xs
            , result: Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "expected token, met EOF"

-- | Match the token at the head of the stream
match :: forall a. Token -> TokenParser Unit
match tok = token (\tok' -> if (tok' == tok) then Just unit else Nothing)
            P.<?> prettyPrintToken tok

anyToken = token $ Just

eof :: TokenParser Unit
eof = P.notFollowedBy anyToken

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

dash :: TokenParser Unit
dash = match Dash

doubleDash :: TokenParser Unit
doubleDash = match DoubleDash

vbar :: TokenParser Unit
vbar = match VBar

comma :: TokenParser Unit
comma = match Comma

colon :: TokenParser Unit
colon = match Colon

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

garbage :: TokenParser Unit
garbage = token go P.<?> "garbage"
  where
    go (Garbage _) = Just unit
    go _           = Nothing

lopt :: TokenParser { name :: String
                    , arg  :: Maybe { name :: String
                                    , optional :: Boolean
                                    } }
lopt = token go P.<?> "long-option"
  where
    go (LOpt n a) = Just { name: n, arg: a }
    go _          = Nothing

sopt :: TokenParser { flag  :: Char
                    , stack :: Array Char
                    , arg   :: Maybe { name :: String
                                     , optional :: Boolean
                                     } }
sopt = token go P.<?> "short-option"
  where
    go (SOpt n s a) = Just { flag: n , stack: s , arg: a }
    go _ = Nothing

name :: TokenParser String
name = token go P.<?> "name"
  where
    go (Name n) = Just n
    go _        = Nothing

tag :: String -> TokenParser String
tag s = token go P.<?> ("tag: " ++ s)
  where
    go (Tag k (Just v)) | k ^= s = Just v
    go _                         = Nothing

reference :: TokenParser String
reference = token go P.<?> "reference"
  where
    go (Reference r) = Just r
    go _             = Nothing

word :: TokenParser String
word = token go P.<?> "word"
  where
    go (Word n) = Just n
    go _        = Nothing

angleName :: TokenParser String
angleName = token go P.<?> "<name>"
  where
    go (AngleName n) = Just n
    go _             = Nothing

shoutName :: TokenParser String
shoutName = token go P.<?> "NAME"
  where
    go (ShoutName n) = Just n
    go _             = Nothing

-- | Return the next token's position w/o consuming anything
nextTokPos :: TokenParser P.Position
nextTokPos = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      { consumed: false
      , input: toks
      , result: Right ppos
      , position: pos }
    _ -> P.parseFailed toks pos "expected token, met EOF"

runTokenParser :: forall a.
                  (List PositionedToken)
                -> TokenParser a
                -> Either P.ParseError a
runTokenParser s =
  flip evalState
  ({ indentation: 0, line: 0 })
  <<< P.runParserT
  (P.PState { input: s, position: P.initialPos })

module Language.Docopt.Parser.Lexer where

import Debug.Trace
import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import Control.Plus (empty)
import Control.Monad.State (State(), evalState, get)
import Control.Monad.Trans
import Data.Foldable (foldl)
import Data.String as Str
import Text.Parsing.Parser as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Token as P
import Text.Parsing.Parser.Pos as P
import Text.Parsing.Parser.String as P
import Data.List as L
import Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray, fromChar, trim)
import Data.List (List(..), (:), fromList, many)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe, fromMaybe, isNothing)
import Data.String.Ext ((^=))
import Language.Docopt.Parser.Base
import Language.Docopt.Parser.State
import Data.Tuple
import Data.Int
import Data.Int as I
import Global (isNaN, readFloat)

data Mode = Usage | Descriptions

isDescMode :: Mode -> Boolean
isDescMode Descriptions = true
isDescMode _ = false

isUsageMode :: Mode -> Boolean
isUsageMode Usage = true
isUsageMode _ = false

lex :: Mode -> String -> Either P.ParseError (List PositionedToken)
lex m = flip P.runParser (parseTokens m)

lexDescs :: String -> Either P.ParseError (List PositionedToken)
lexDescs = lex Descriptions

lexUsage :: String -> Either P.ParseError (List PositionedToken)
lexUsage = lex Usage

data NumberLiteral = FloatLiteral Number | IntLiteral Int

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | LAngle
  | RAngle
  | Dash
  | VBar
  | Colon
  | Comma
  | Equal
  | TripleDot
  | Reference String
  | LOpt String (Maybe { name :: String, optional :: Boolean })
  | SOpt Char (Array Char) (Maybe { name :: String, optional :: Boolean })
  | Tag String (Maybe String)
  | Name String
  | ShoutName String
  | AngleName String
  | Word String
  | StringLiteral String
  | NumberLiteral NumberLiteral
  | Garbage Char
  | DoubleDash

prettyPrintToken :: Token -> String
prettyPrintToken LParen            = show '('
prettyPrintToken RParen            = show ')'
prettyPrintToken LSquare           = show '['
prettyPrintToken RSquare           = show ']'
prettyPrintToken LAngle            = show '<'
prettyPrintToken RAngle            = show '>'
prettyPrintToken Dash              = show '-'
prettyPrintToken VBar              = show '|'
prettyPrintToken Colon             = show ':'
prettyPrintToken Comma             = show ','
prettyPrintToken Equal             = show '='
prettyPrintToken TripleDot         = "..."
prettyPrintToken DoubleDash        = "--"
prettyPrintToken (Reference r)     = "Reference " ++ show r
prettyPrintToken (Garbage   c)     = "Garbage "   ++ show c
prettyPrintToken (Tag k v)         = "Tag "       ++ k ++ " "  ++ (show v)
prettyPrintToken (Name      n)     = "Name "      ++ show n
prettyPrintToken (ShoutName n)     = "ShoutName " ++ show n
prettyPrintToken (AngleName n)     = "AngleName " ++ show n
prettyPrintToken (StringLiteral s) = "String "    ++ show s
prettyPrintToken (NumberLiteral n) = "Number "    ++ show n
prettyPrintToken (Word w)          = "Word "      ++ show w
prettyPrintToken (LOpt n arg)
  = "--" ++ n
         ++ (fromMaybe "" do
              a <- arg
              return $ if a.optional then "[" else ""
                ++ a.name
                ++ if a.optional then "]" else ""
            )
prettyPrintToken (SOpt n s arg)
  = "-" ++ (fromCharArray (A.cons n s))
        ++ (fromMaybe "" do
              a <- arg
              return $ if a.optional then "[" else ""
                ++ a.name
                ++ if a.optional then "]" else ""
            )

data PositionedToken = PositionedToken
  { sourcePos :: P.Position
  , token     :: Token
  }

instance eqNumberLiteral :: Eq NumberLiteral where
  eq (FloatLiteral n) (FloatLiteral n') = eq n n'
  eq (IntLiteral n)   (IntLiteral n')   = eq n n'

instance showNumberLiteral :: Show NumberLiteral where
  show (FloatLiteral n) = show n
  show (IntLiteral n)   = show n

instance showToken :: Show Token where
  show = show <<< prettyPrintToken

instance eqToken :: Eq Token where
  eq LParen            LParen             = true
  eq RParen            RParen             = true
  eq LSquare           LSquare            = true
  eq RSquare           RSquare            = true
  eq LAngle            LAngle             = true
  eq RAngle            RAngle             = true
  eq VBar              VBar               = true
  eq Colon             Colon              = true
  eq Comma             Comma              = true
  eq Dash              Dash               = true
  eq Equal             Equal              = true
  eq DoubleDash        DoubleDash         = true
  eq TripleDot         TripleDot          = true
  eq (Reference r)     (Reference r')     = r == r'
  eq (LOpt n arg)      (LOpt n' arg')
    = (n == n')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              return $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (SOpt n s arg)    (SOpt n' s' arg')
    = (n == n') && (s' == s')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              return $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (StringLiteral s) (StringLiteral s') = s == s'
  eq (AngleName n)     (AngleName n')     = n == n'
  eq (ShoutName n)     (ShoutName n')     = n == n'
  eq (Word w)          (Word w')          = w == w'
  eq (Name n)          (Name n')          = n == n'
  eq (Garbage c)       (Garbage c')       = c == c'
  eq (NumberLiteral n) (NumberLiteral n') = n == n'
  eq _ _                                  = false

instance showPositionedToken :: Show PositionedToken where
  show (PositionedToken { sourcePos=pos, token=tok }) =
    (show tok) ++ " at " ++ (show pos)

parseTokens :: Mode -> P.Parser String (L.List PositionedToken)
parseTokens m = do
  P.skipSpaces
  L.many $ parsePositionedToken m
  <* P.eof

parsePositionedToken :: Mode -> P.Parser String PositionedToken
parsePositionedToken m = P.try $ do
  pos <- getPosition
  tok <- parseToken m
  return $ PositionedToken { sourcePos: pos, token: tok }

parseToken :: Mode -> P.Parser String Token
parseToken m = P.choice (P.try <$> A.concat [
    [ P.char   '('   *> pure LParen
    , P.char   ')'   *> pure RParen
    ]
  , if isDescMode m then [ tag ] else []
  , [ reference
    , P.char   '['   *> pure LSquare
    , P.char   ']'   *> pure RSquare
    , P.char   '|'   *> pure VBar
    , P.char   ':'   *> pure Colon
    , P.char   ','   *> pure Comma
    , longOption
    , shortOption
    , AngleName <$> angleName
    , P.char   '<'   *> pure LAngle
    , P.char   '>'   *> pure RAngle
    , P.string "--"  *> pure DoubleDash
    , P.char   '-'   *> pure Dash
    , P.char   '='   *> pure Equal
    , P.string "..." *> pure TripleDot
    , numberLiteral
    , stringLiteral
    , ShoutName <$> (shoutName <* P.notFollowedBy alpha)
    , Name      <$> (name      <* P.notFollowedBy alpha)
    , Word      <$> (word      <* space)
    , Garbage   <$> P.anyChar
    ]
  ])
  <* P.skipSpaces

 where

  whitespace :: P.Parser String Unit
  whitespace = do
    P.satisfy \c -> c == '\n' || c == '\r' || c == ' ' || c == '\t'
    pure unit

  reference :: P.Parser String Token
  reference = Reference <$> do
    P.between (P.char '[') (P.char ']') go

    where
      go = do
        many space
        x <- fromCharArray <<< fromList <$> do
          flip P.manyTill (P.lookAhead $ P.try end) do
            P.noneOf [']']
        end
        many space
        return x

      end = do
        many space
        P.optional $ P.string "-"
        string' "options"
        P.optional $ P.string "..."

  tag :: P.Parser String Token
  tag = P.between (P.char '[')
                  (P.char ']')
                  (withValue <|> withoutValue)

    where
      withValue = do
        many whitespace
        k <- fromCharArray <$> do A.many (P.noneOf [':'])
        P.char ':'
        many whitespace
        v <- trim <<< fromCharArray <$> do A.some $ P.noneOf [']']
        many whitespace
        return (Tag k (Just v))
      withoutValue = do
        k <- trim <<< fromCharArray <$> do A.some $ P.noneOf [']']
        return (Tag k Nothing)

  stringLiteral :: P.Parser String Token
  stringLiteral = StringLiteral <$> do
    P.choice [
      P.between (P.char '\'') (P.char '\'') (p '\'')
    , P.between (P.char '"')  (P.char '"')  (p '"')
    ]
    where
      p :: Char -> P.Parser String String
      p c = fromCharArray <$> do
        A.many $ P.noneOf [c]

  numberLiteral :: P.Parser String Token
  numberLiteral = NumberLiteral <$> do
    P.choice [
      P.try $ FloatLiteral <$> floatLiteral
    , P.try $ IntLiteral   <$> intLiteral
    ]
    where
      floatLiteral = do
        x <- fromCharArray <$> (A.some digit)
        P.char '.'
        xs <- fromCharArray <$> (A.some digit)

        -- there is no "safe" version yet, afaik
        let n = readFloat $ x ++ "." ++ xs
        if isNaN n
           then P.fail "Could not parse float"
           else pure n

      intLiteral = do
        x <- fromCharArray <$> (A.some digit)
        case (I.fromString x) of
          Just n  -> return n
          Nothing -> P.fail "Could not parse integer"

  name :: P.Parser String String
  name = word

  shoutName :: P.Parser String String
  shoutName = do
    n <- fromCharArray <$> do
      A.cons
        <$> upperAlpha
        <*> (A.many $ regex "[A-Z_-]")
    P.notFollowedBy lowerAlpha
    return n

  word :: P.Parser String String
  word = do
    n  <- alphaNum
    ns <- do
      A.many $ P.try $ do
        P.choice $ P.try <$> [
          identLetter
        , P.char '.' <* (P.notFollowedBy $ P.string "..")
        , P.oneOf [ '-', '_' ]
      ]
    return $ fromCharArray (n A.: ns)

  angleName :: P.Parser String String
  angleName = do
    P.char '<'
    n <- fromCharArray <$> do
      A.some $ P.choice [
        identLetter
      , P.try $ P.noneOf [ '>' ]
      ]
    P.char '>'
    return n

  shortOption :: P.Parser String Token
  shortOption = do
    P.char '-'
    x  <- alphaNum
    xs <- A.many alphaNum

    arg <- P.choice $ P.try <$> [

      -- Case 1: OPTION = ARG
      Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        return { name:     n
               , optional: false
               }

      -- Case 2: Option[ = ARG ]
    , Just <$> do
        P.char '[' <* many space
        -- XXX: Drop the spaces?
        P.optional (many space *> P.char '=' <* many space)
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 3: Option[ARG]
    , Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '[' <* many space
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 4: Option<ARG>
    , Just <$> do
        n <- angleName
        return { name:     n
               , optional: false
               }

    , return Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.lookAhead $ P.choice [
      P.eof
    , P.try $ void $ P.whiteSpace
    , P.try $ void $ P.char ','
    , P.try $ void $ P.char '|'
    , P.try $ void $ P.char '['
    , P.try $ void $ P.char '('
    , P.try $ void $ P.string "..."
    ]

    return $ SOpt x xs arg

  longOption :: P.Parser String Token
  longOption = do
    P.string "--"

    name' <- fromCharArray <$> do
      A.cons
        <$> alphaNum
        <*> (A.many $ P.choice [
              alphaNum
            , P.oneOf [ '-' ] <* P.lookAhead alphaNum
            ])

    arg <- P.choice $ P.try <$> [

      -- Case 1: OPTION = ARG
      Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        return { name:     n
               , optional: false
               }

      -- Case 2: Option[ = ARG ]
    , Just <$> do
        P.char '[' <* many space
        -- XXX: Drop the spaces?
        P.optional (many space *> P.char '=' <* many space)
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 2: Option[ = ARG ]
    , Just <$> do
        P.char '[' <* many space
        -- XXX: Drop the spaces?
        P.optional (many space *> P.char '=' <* many space)
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 3: Option[ARG]
    , Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '[' <* many space
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

    , return Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.lookAhead $ P.choice [
      P.eof
    , P.try $ void $ P.whiteSpace
    , P.try $ void $ P.char ','
    , P.try $ void $ P.char '|'
    , P.try $ void $ P.char '['
    , P.try $ void $ P.char '('
    , P.try $ void $ P.string "..."
    ]

    return $ LOpt name' arg

  identStart :: P.Parser String Char
  identStart = alpha

  identLetter :: P.Parser String Char
  identLetter = alphaNum <|> P.oneOf ['_', '-']

  flag :: P.Parser String Char
  flag = lowerAlphaNum

-- | Parser that  parses a stream of tokens
type TokenParser a = P.ParserT (List PositionedToken) (State ParserState) a

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> TokenParser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      case test tok of
        Just a ->
          let nextpos =
              case xs of
                Cons (PositionedToken { sourcePos: npos }) _ -> npos
                Nil -> ppos
          in
            { consumed: true
            , input: xs
            , result: Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "expected token, met EOF"

-- | Match the token at the head of the stream
match :: forall a. Token -> TokenParser Unit
match tok = token (\tok' -> if (tok' == tok) then Just unit else Nothing)
            P.<?> prettyPrintToken tok

anyToken = token $ Just

eof :: TokenParser Unit
eof = P.notFollowedBy anyToken

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

langle :: TokenParser Unit
langle = match LAngle

rangle :: TokenParser Unit
rangle = match RAngle

dash :: TokenParser Unit
dash = match Dash

doubleDash :: TokenParser Unit
doubleDash = match DoubleDash

vbar :: TokenParser Unit
vbar = match VBar

comma :: TokenParser Unit
comma = match Comma

colon :: TokenParser Unit
colon = match Colon

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

equal :: TokenParser Unit
equal = match Equal

garbage :: TokenParser Unit
garbage = token go P.<?> "garbage"
  where
    go (Garbage _) = Just unit
    go _           = Nothing

lopt :: TokenParser { name :: String
                    , arg  :: Maybe { name :: String
                                    , optional :: Boolean
                                    } }
lopt = token go P.<?> "long-option"
  where
    go (LOpt n a) = Just { name: n, arg: a }
    go _          = Nothing

sopt :: TokenParser { flag  :: Char
                    , stack :: Array Char
                    , arg   :: Maybe { name :: String
                                     , optional :: Boolean
                                     } }
sopt = token go P.<?> "short-option"
  where
    go (SOpt n s a) = Just { flag: n , stack: s , arg: a }
    go _ = Nothing

name :: TokenParser String
name = token go P.<?> "name"
  where
    go (Name n) = Just n
    go _        = Nothing

tag :: String -> TokenParser String
tag s = token go P.<?> ("tag: " ++ s)
  where
    go (Tag k (Just v)) | k ^= s = Just v
    go _                         = Nothing

reference :: TokenParser String
reference = token go P.<?> "reference"
  where
    go (Reference r) = Just r
    go _             = Nothing

word :: TokenParser String
word = token go P.<?> "word"
  where
    go (Word n) = Just n
    go _        = Nothing

angleName :: TokenParser String
angleName = token go P.<?> "<name>"
  where
    go (AngleName n) = Just n
    go _             = Nothing

shoutName :: TokenParser String
shoutName = token go P.<?> "NAME"
  where
    go (ShoutName n) = Just n
    go _             = Nothing

-- | Return the next token's position w/o consuming anything
nextTokPos :: TokenParser P.Position
nextTokPos = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      { consumed: false
      , input: toks
      , result: Right ppos
      , position: pos }
    _ -> P.parseFailed toks pos "expected token, met EOF"

runTokenParser :: forall a.
                  (List PositionedToken)
                -> TokenParser a
                -> Either P.ParseError a
runTokenParser s =
  flip evalState
  ({ indentation: 0, line: 0 })
  <<< P.runParserT
  (P.PState { input: s, position: P.initialPos })


Use readFileSync

Use readFileSync

-----------------------------------------------------------------------------
--
-- Module      :  Compiler
-- Copyright   :  (c) Phil Freeman 2013-14
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- | psc frontend to the PureScript library
--
-----------------------------------------------------------------------------

module Compiler where

import Debug.Trace

import Data.Maybe
import Data.Tuple
import Data.Tuple3
import Data.Array (concat, map)
import Data.Either

import Data.Traversable (for)

import Control.Monad.Eff
import Control.Monad.Eff.Exception

import Control.Apply
import Control.Monad.Identity
import Control.Monad.State.Class
import Control.Monad.Error.Trans
import Control.Monad.Error.Class
import Control.Monad.Cont.Trans

import Node.Args

import Language.PureScript
import Language.PureScript.Declarations
import Language.PureScript.Options

import qualified Language.PureScript.Parser.Lexer as P
import qualified Language.PureScript.Parser.Common as P
import qualified Language.PureScript.Parser.Declarations as P

foreign import data FS :: !

foreign import data Process :: !

foreign import exit
  "function exit(code) {\
  \  return function() {\
  \    process.exit(code);\
  \  };\
  \}" :: forall eff. Number -> Eff (process :: Process | eff) {}

foreign import readFile
  "function readFile(filename) {\
  \  return function(k) {\
  \    return function(fail) {\
  \      return function() {\
  \        try {\
  \          return k(require('fs').readFileSync(filename, 'utf8'));\
  \        } catch(err) {\
  \          return fail(err);\
  \        }\
  \      };\
  \    };\
  \  };\
  \}" :: forall eff r. String -> (String -> r) -> (String -> r) -> Eff (fs :: FS | eff) r

type AppMonad eff = ErrorT String (Eff (fs :: FS | eff))

runAppMonad :: forall eff a. AppMonad eff a -> Eff (fs :: FS | eff) (Either String a)
runAppMonad app = runErrorT app

readFileApp :: forall eff. String -> AppMonad eff String
readFileApp filename = ErrorT $ readFile filename Right Left

preludeFilename :: String
preludeFilename = "prelude/prelude.purs"

modulesFromText :: String -> Either String [Module]
modulesFromText text = do
  tokens <- P.lex text
  P.runTokenParser P.parseModules tokens

readInput :: forall eff. [String] -> AppMonad eff [Module]
readInput input =
  concat <$> for input (\inputFile -> do
    text <- readFileApp inputFile
    case modulesFromText text of
      Left err -> throwError err
      Right ms -> return ms)

runCompiler :: forall eff. Options -> [String] -> Maybe String -> Maybe String -> Eff (trace :: Trace, fs :: FS, process :: Process | eff) {}
runCompiler opts input output externs = do
  modules <- runAppMonad (readInput input)
  case modules of
    Left err -> do
      trace err
      exit 1
    Right ms -> do
      case compile opts ms of
        Left err -> do
          trace err
          exit 1
        Right (Tuple3 js exts _) -> do
          case output of
            Just path -> trace "Not implemented" -- mkdirp path >> U.writeFile path js
            Nothing -> trace js
          case externs of
            Just path -> trace "Not implemented" -- mkdirp path >> U.writeFile path exts
            Nothing -> return {}
          exit 0

flag :: String -> String -> Args Boolean
flag shortForm longForm = maybe false (const true) <$> opt (flagOnly shortForm <|> flagOnly longForm)

useStdIn :: Args Boolean
useStdIn = flag "s" "stdin"

inputFiles :: Args [String]
inputFiles = many argOnly

outputFile :: Args (Maybe String)
outputFile = opt (flagArg "o" <|> flagArg "output")

externsFile :: Args (Maybe String)
externsFile = opt (flagArg "e" <|> flagArg "externs")

noTco :: Args Boolean
noTco = flagOpt "no-tco"

performRuntimeTypeChecks :: Args Boolean
performRuntimeTypeChecks = flagOpt "runtime-type-checks"

noPrelude :: Args Boolean
noPrelude = flagOpt "no-prelude"

noMagicDo :: Args Boolean
noMagicDo = flagOpt "no-magic-do"

runMain :: Args (Maybe String)
runMain = opt (flagArg "main")

noOpts :: Args Boolean
noOpts = flagOpt "no-opts"

browserNamespace :: Args String
browserNamespace = flagArg "browser-namespace" <|> pure "PS"

dceModules :: Args [String]
dceModules = many (flagArg "m" <|> flagArg "module")

codeGenModules :: Args [String]
codeGenModules = many (flagArg "codegen")

verboseErrors :: Args Boolean
verboseErrors = flag "v" "verbose-errors"

options :: Args Options
options = mkOptions <$> noPrelude
                    <*> noTco
                    <*> performRuntimeTypeChecks
                    <*> noMagicDo
                    <*> runMain
                    <*> noOpts
                    <*> (Just <$> browserNamespace)
                    <*> dceModules
                    <*> codeGenModules
                    <*> verboseErrors

inputFilesAndPrelude :: Args [String]
inputFilesAndPrelude = combine <$> noPrelude <*> inputFiles
  where
  combine true  input = input
  combine false input = preludeFilename : input

term :: Args (Eff (trace :: Trace, fs :: FS, process :: Process) {})
term = runCompiler <$> options <*> inputFilesAndPrelude <*> outputFile <*> externsFile

main = catchException (\err -> print err) $ readArgs' term

-----------------------------------------------------------------------------
--
-- Module      :  Compiler
-- Copyright   :  (c) Phil Freeman 2013-14
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- | psc frontend to the PureScript library
--
-----------------------------------------------------------------------------

module Compiler where

import Debug.Trace

import Data.Maybe
import Data.Tuple
import Data.Tuple3
import Data.Array (concat, map)
import Data.Either

import Data.Traversable (for)

import Control.Monad.Eff
import Control.Monad.Eff.Exception

import Control.Apply
import Control.Monad.Identity
import Control.Monad.State.Class
import Control.Monad.Error.Trans
import Control.Monad.Error.Class
import Control.Monad.Cont.Trans

import Node.Args

import Language.PureScript
import Language.PureScript.Declarations
import Language.PureScript.Options

import qualified Language.PureScript.Parser.Lexer as P
import qualified Language.PureScript.Parser.Common as P
import qualified Language.PureScript.Parser.Declarations as P

foreign import data FS :: !

foreign import data Process :: !

foreign import exit
  "function exit(code) {\
  \  return function() {\
  \    process.exit(code);\
  \  };\
  \}" :: forall eff. Number -> Eff (process :: Process | eff) {}

foreign import readFile
  "function readFile(filename) {\
  \  return function(k) {\
  \    return function(fail) {\
  \      return function() {\
  \        require('fs').readFile(filename, 'utf8', function(err, data) {\
  \          if (err) {\
  \            fail(err)();\
  \          } else {\
  \            k(data)();\
  \          }\
  \        });\
  \      };\
  \    };\
  \  };\
  \}" :: forall eff. String -> (String -> Eff (fs :: FS | eff) {}) -> (String -> Eff (fs :: FS | eff) {}) -> Eff (fs :: FS | eff) {}

type AppMonad eff = ErrorT String (ContT {} (Eff (fs :: FS | eff)))

runAppMonad :: forall eff a. AppMonad eff a -> (Either String a -> Eff (fs :: FS | eff) {}) -> Eff (fs :: FS | eff) {}
runAppMonad app = runContT (runErrorT app)

readFileCont :: forall eff. String -> AppMonad eff String
readFileCont filename = ErrorT $ ContT $ \k -> readFile filename (k <<< Right) (k <<< Left)

preludeFilename :: String
preludeFilename = "prelude/prelude.purs"

modulesFromText :: String -> Either String [Module]
modulesFromText text = do
  tokens <- P.lex text
  P.runTokenParser P.parseModules tokens

readInput :: forall eff. [String] -> AppMonad eff [Module]
readInput input =
  concat <$> for input (\inputFile -> do
    text <- readFileCont inputFile
    case modulesFromText text of
      Left err -> throwError err
      Right ms -> return ms)

runCompiler :: forall eff. Options -> [String] -> Maybe String -> Maybe String -> Eff (trace :: Trace, fs :: FS, process :: Process | eff) {}
runCompiler opts input output externs = runAppMonad (readInput input) $ \modules ->
  case modules of
    Left err -> do
      trace err
      exit 1
    Right ms -> do
      case compile opts ms of
        Left err -> do
          trace err
          exit 1
        Right (Tuple3 js exts _) -> do
          case output of
            Just path -> trace "Not implemented" -- mkdirp path >> U.writeFile path js
            Nothing -> trace js
          case externs of
            Just path -> trace "Not implemented" -- mkdirp path >> U.writeFile path exts
            Nothing -> return {}
          exit 0

flag :: String -> String -> Args Boolean
flag shortForm longForm = maybe false (const true) <$> opt (flagOnly shortForm <|> flagOnly longForm)

useStdIn :: Args Boolean
useStdIn = flag "s" "stdin"

inputFiles :: Args [String]
inputFiles = many argOnly

outputFile :: Args (Maybe String)
outputFile = opt (flagArg "o" <|> flagArg "output")

externsFile :: Args (Maybe String)
externsFile = opt (flagArg "e" <|> flagArg "externs")

noTco :: Args Boolean
noTco = flagOpt "no-tco"

performRuntimeTypeChecks :: Args Boolean
performRuntimeTypeChecks = flagOpt "runtime-type-checks"

noPrelude :: Args Boolean
noPrelude = flagOpt "no-prelude"

noMagicDo :: Args Boolean
noMagicDo = flagOpt "no-magic-do"

runMain :: Args (Maybe String)
runMain = opt (flagArg "main")

noOpts :: Args Boolean
noOpts = flagOpt "no-opts"

browserNamespace :: Args String
browserNamespace = flagArg "browser-namespace" <|> pure "PS"

dceModules :: Args [String]
dceModules = many (flagArg "m" <|> flagArg "module")

codeGenModules :: Args [String]
codeGenModules = many (flagArg "codegen")

verboseErrors :: Args Boolean
verboseErrors = flag "v" "verbose-errors"

options :: Args Options
options = mkOptions <$> noPrelude
                    <*> noTco
                    <*> performRuntimeTypeChecks
                    <*> noMagicDo
                    <*> runMain
                    <*> noOpts
                    <*> (Just <$> browserNamespace)
                    <*> dceModules
                    <*> codeGenModules
                    <*> verboseErrors

inputFilesAndPrelude :: Args [String]
inputFilesAndPrelude = combine <$> noPrelude <*> inputFiles
  where
  combine true  input = input
  combine false input = preludeFilename : input

term :: Args (Eff (trace :: Trace, fs :: FS, process :: Process) {})
term = runCompiler <$> options <*> inputFilesAndPrelude <*> outputFile <*> externsFile

main = catchException (\err -> print err) $ readArgs' term


i keep doing this.

i keep doing this.

module Data.DOM.Simple.Events where

import Control.Monad.Eff

import Data.DOM.Simple.Element
import Data.DOM.Simple.Ajax

class EventBindable b where
  addEventListener    :: forall t ta a. String -> (Eff (dom :: DOM | t) a) -> b -> (Eff (dom :: DOM | ta) Unit)
  removeEventListener :: forall t ta a. String -> (Eff (dom :: DOM | t) a) -> b -> (Eff (dom :: DOM | ta) Unit)

foreign import unsafeAddEventListener
  "function unsafeAddEventListener(targ) {     \
  \  return function (cb) {                    \
  \     return function (src) {                \
  \       return function () {                 \
  \         src.addEventListener(targ, cb);    \
  \       };                                   \
  \     };                                     \
  \  };                                        \
  \}" :: forall t ta a b. String -> (Eff (dom :: DOM | t) a) -> b -> (Eff (dom :: DOM | ta) Unit)

foreign import unsafeRemoveEventListener
  "function unsafeRemoveEventListener(targ) {   \
  \  return function (cb) {                     \
  \     return function (src) {                 \
  \       return function () {                  \
  \         src.removeEventListener(targ, cb);  \
  \       };                                    \
  \     };                                      \
  \  };                                         \
  \}" :: forall t ta a b. String -> (Eff (dom :: DOM | t) a) -> b -> (Eff (dom :: DOM | ta) Unit)

instance eventBindableHTMLElement :: EventBindable HTMLElement where
  addEventListener = unsafeAddEventListener
  removeEventListener = unsafeRemoveEventListener

instance eventBindableHTMLWindow :: EventBindable HTMLWindow where
  addEventListener = unsafeAddEventListener
  removeEventListener = unsafeRemoveEventListener

instance eventBindableXMLHttpRequest :: EventBindable XMLHttpRequest where
  addEventListener = unsafeAddEventListener
  removeEventListener = unsafeRemoveEventListener

ready :: forall t ta a b. (Eff (dom :: DOM | t) a) -> (Eff (dom :: DOM | ta) Unit)
ready cb = getDocument globalWindow >>= (addEventListener "DOMContentLoaded" cb)

module Data.DOM.Simple.Events where

import Control.Monad.Eff

import Data.DOM.Simple.Element
import Data.DOM.Simple.Ajax

class EventBindable b where
  addEventListener    :: forall t ta a. String -> (Eff (dom :: DOM | t) a) -> b -> (Eff (dom :: DOM | ta) Unit)
  removeEventListener :: forall t ta a. String -> (Eff (dom :: DOM | t) a) -> b -> (Eff (dom :: DOM | ta) Unit)

foreign import unsafeAddEventListener
  "function addEventListener(targ) {           \
  \  return function (cb) {                    \
  \     return function (src) {                \
  \       return function () {                 \
  \         src.addEventListener(targ, cb);    \
  \       };                                   \
  \     };                                     \
  \  };                                        \
  \}" :: forall t ta a b. String -> (Eff (dom :: DOM | t) a) -> b -> (Eff (dom :: DOM | ta) Unit)

foreign import unsafeRemoveEventListener
  "function removeEventListener(targ) {         \
  \  return function (cb) {                     \
  \     return function (src) {                 \
  \       return function () {                  \
  \         src.removeEventListener(targ, cb);  \
  \       };                                    \
  \     };                                      \
  \  };                                         \
  \}" :: forall t ta a b. String -> (Eff (dom :: DOM | t) a) -> b -> (Eff (dom :: DOM | ta) Unit)

instance eventBindableHTMLElement :: EventBindable HTMLElement where
  addEventListener = unsafeAddEventListener
  removeEventListener = unsafeRemoveEventListener

instance eventBindableHTMLWindow :: EventBindable HTMLWindow where
  addEventListener = unsafeAddEventListener
  removeEventListener = unsafeRemoveEventListener

instance eventBindableXMLHttpRequest :: EventBindable XMLHttpRequest where
  addEventListener = unsafeAddEventListener
  removeEventListener = unsafeRemoveEventListener

ready :: forall t ta a b. (Eff (dom :: DOM | t) a) -> (Eff (dom :: DOM | ta) Unit)
ready cb = getDocument globalWindow >>= (addEventListener "DOMContentLoaded" cb)