[CSE-166] Fix selected language

[CSE-166] Fix selected language

module Explorer.View.Common (
    placeholderView
    , txHeaderView
    , txBodyView
    , emptyTxBodyView
    , emptyTxHeaderView
    , emptyView
    , getMaxPaginationNumber
    , mkTxHeaderViewProps
    , class TxHeaderViewPropsFactory
    , mkTxBodyViewProps
    , class TxBodyViewPropsFactory
    , currencyCSSClass
    , paginationView
    , txPaginationView
    , EmptyViewProps
    , mkEmptyViewProps
    , txEmptyContentView
    , noData
    , logoView
    , clickableLogoView
    , langView
    ) where

import Prelude

import Data.Foldable (for_)
import Data.Int (ceil, fromString, toNumber)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..))

import Explorer.I18n.Lang (Language(..), readLanguage, translate)
import Explorer.I18n.Lenses (common, cDateFormat) as I18nL
import Explorer.Lenses.State (lang)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (initialState)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), PageNumber(..), State)
import Explorer.Util.DOM (enterKeyPressed)
import Explorer.Util.Factory (mkCAddress, mkCTxId, mkCoin)
import Explorer.Util.String (formatADA)
import Explorer.Util.Time (prettyDate)
import Explorer.View.Lenses (txbAmount, txbInputs, txbOutputs, txhAmount, txhHash, txhTimeIssued)
import Exporer.View.Types (TxBodyViewProps(..), TxHeaderViewProps(..))

import Pos.Explorer.Web.ClientTypes (CCoin, CAddress(..), CTxBrief(..), CTxEntry(..), CTxSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CHash, _CTxId, ctbId, ctbInputs, ctbOutputs, ctbOutputSum, ctbTimeIssued, cteId, cteTimeIssued, ctsBlockTimeIssued, ctsId, ctsInputs, ctsOutputs, ctsTotalOutput)

import Pux.DOM.Events (DOMEvent, onBlur, onChange, onFocus, onKeyDown, onClick, targetValue) as P
import Pux.DOM.HTML (HTML) as P

import Text.Smolder.HTML (a, div, p, span, input, option, select) as S
import Text.Smolder.HTML.Attributes (className, href, value, disabled, selected, type', min, max) as S
import Text.Smolder.Markup (text) as S
import Text.Smolder.Markup ((#!), (!), (!?))

-- -----------------
-- tx header
-- -----------------

-- | Factory to create TxHeaderViewProps by a given type
class TxHeaderViewPropsFactory a where
    mkTxHeaderViewProps :: a -> TxHeaderViewProps

-- | Creates a TxHeaderViewProps by a given CTxEntry
instance cTxEntryTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxEntry where
    mkTxHeaderViewProps (CTxEntry entry) = TxHeaderViewProps
        { txhHash: entry ^. cteId
        , txhTimeIssued: Just $ entry ^. cteTimeIssued
        , txhAmount: entry . cteAmount
        }

-- | Creates a TxHeaderViewProps by a given CTxBrief
instance cTxBriefTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxBrief where
    mkTxHeaderViewProps (CTxBrief txBrief) = TxHeaderViewProps
        { txhHash: txBrief ^. ctbId
        , txhTimeIssued: Just $ txBrief ^. ctbTimeIssued
        , txhAmount: txBrief ^. ctbOutputSum
        }

-- | Creates a TxHeaderViewProps by a given CTxSummary
instance cTxSummaryTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxSummary where
    mkTxHeaderViewProps (CTxSummary txSummary) = TxHeaderViewProps
        { txhHash: txSummary ^. ctsId
        , txhTimeIssued: txSummary ^. ctsBlockTimeIssued
        , txhAmount: txSummary ^. ctsTotalOutput
        }

-- | Creates a TxHeaderViewProps by a given EmptyViewProps
instance emtpyTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory EmptyViewProps where
    mkTxHeaderViewProps _ = TxHeaderViewProps
        { txhHash: mkCTxId noData
        , txhTimeIssued: Nothing
        , txhAmount: mkCoin "0"
        }

txHeaderView :: Language -> TxHeaderViewProps -> P.HTML Action
txHeaderView lang (TxHeaderViewProps props) =
    S.div ! S.className "transaction-header" $ do
        S.div ! S.className "hash-container"
              $ S.a ! S.href (toUrl txRoute)
              #! P.onClick (Navigate $ toUrl txRoute)
              ! S.className "hash"
              $ S.text (props ^. (txhHash <<< _CTxId <<< _CHash))
        S.div ! S.className "date"
              $ S.text $ case props ^. txhTimeIssued of
                              Just time ->
                                  let format = translate (I18nL.common <<< I18nL.cDateFormat) lang
                                  in fromMaybe noData $ prettyDate format time
                              Nothing -> noData
        txAmountView (props ^. txhAmount) lang
    where
        txRoute = Tx $ props ^. txhHash

emptyTxHeaderView :: P.HTML Action
emptyTxHeaderView =
    S.div ! S.className "transaction-header"
          $ mempty

txAmountView :: CCoin -> Language -> P.HTML Action
txAmountView coin lang =
    S.div ! S.className "amount-container"
          $ S.div ! S.className "amount bg-ada"
                  $ S.text (formatADA coin lang)

-- -----------------
-- tx body
-- -----------------

-- | Factory to create TxBodyViewProps by a given type
class TxBodyViewPropsFactory a where
    mkTxBodyViewProps :: a -> TxBodyViewProps

-- | Creates a TxBodyViewProps by a given CTxSummary
instance cTxSummaryTxBodyViewPropsFactory :: TxBodyViewPropsFactory CTxSummary where
    mkTxBodyViewProps (CTxSummary txSummary) = TxBodyViewProps
        { txbInputs: txSummary ^. ctsInputs
        , txbOutputs: txSummary ^. ctsOutputs
        , txbAmount: txSummary ^. ctsTotalOutput
        }

-- | Creates a TxBodyViewProps by a given CTxBrief
instance cTxBriefTxBodyViewPropsFactory :: TxBodyViewPropsFactory CTxBrief where
    mkTxBodyViewProps (CTxBrief txBrief) = TxBodyViewProps
        { txbInputs: txBrief ^. ctbInputs
        , txbOutputs: txBrief ^. ctbOutputs
        , txbAmount: txBrief ^. ctbOutputSum
        }

-- | Creates a TxBodyViewProps by a given EmptyViewProps
instance emptyTxBodyViewPropsFactory :: TxBodyViewPropsFactory EmptyViewProps where
    mkTxBodyViewProps _ = TxBodyViewProps
        { txbInputs: []
        , txbOutputs: []
        , txbAmount: mkCoin "0"
        }

txBodyView :: Language -> TxBodyViewProps -> P.HTML Action
txBodyView lang (TxBodyViewProps props) =
    S.div ! S.className "transaction-body" $ do
        S.div ! S.className "from-hash-container"
              $ for_ (props ^. txbInputs) txFromView
        S.div ! S.className "to-hash-container bg-transaction-arrow"
              $ S.div ! S.className "to-hash-wrapper"
                      $ for_ (props ^. txbOutputs) txToView
        S.div ! S.className "amounts-container"
              $ for_ (props ^. txbOutputs) (txBodyAmountView lang)
        txAmountView (props ^. txbAmount) lang

emptyTxBodyView :: P.HTML Action
emptyTxBodyView =
    S.div ! S.className "transaction-body"
          $ mempty

txFromView :: Tuple CAddress CCoin -> P.HTML Action
txFromView (Tuple (CAddress cAddress) _) =
    let addressRoute = Address $ mkCAddress cAddress in
    S.a ! S.href (toUrl addressRoute)
        #! P.onClick (Navigate $ toUrl addressRoute)
        ! S.className "from-hash"
        $ S.text cAddress

txToView :: Tuple CAddress CCoin -> P.HTML Action
txToView (Tuple (CAddress cAddress) _) =
    let addressRoute = Address $ mkCAddress cAddress in
    S.a ! S.href (toUrl addressRoute)
        #! P.onClick (Navigate $ toUrl addressRoute)
        ! S.className "to-hash"
        $ S.text cAddress

txBodyAmountView :: Language -> Tuple CAddress CCoin -> P.HTML Action
txBodyAmountView lang (Tuple _ coin) =
    S.div ! S.className "amount-wrapper"
          $ S.span  ! S.className "plain-amount bg-ada-dark"
                    $ S.text (formatADA coin lang)

-- -----------------
-- pagination
-- -----------------

type PaginationViewProps =
    { label :: String
    , currentPage :: PageNumber
    , minPage :: PageNumber
    , maxPage :: PageNumber
    , editable :: Boolean
    , changePageAction :: (PageNumber -> Action)
    , editableAction :: (P.DOMEvent -> Boolean -> Action)
    , invalidPageAction :: (P.DOMEvent -> Action)
    , disabled :: Boolean
    }

txPaginationView :: PaginationViewProps -> P.HTML Action
txPaginationView props =
    S.div ! S.className "transaction-pagination"
          $ paginationView props

paginationView :: PaginationViewProps -> P.HTML Action
paginationView props =
    S.div ! S.className "pagination-wrapper" $ do
          S.div ! S.className "pagination" $ do
                S.div ! S.className "pagination__container" $ do
                      S.div ! S.className ("btn-page" <> disablePrevBtnClazz)
                              #! P.onClick prevClickHandler
                              $ S.div ! S.className "icon bg-triangle-left"
                                      $ mempty
                      (S.input !? not props.editable) (S.value <<< show $ unwrap props.currentPage)
                            ! S.className "page-number"
                            -- ! S.disabled (show $ props.maxPage == props.minPage)
                            ! S.disabled (if props.maxPage == props.minPage then "disabled" else "")
                            ! S.min (show $ unwrap props.minPage)
                            ! S.max (show $ unwrap props.maxPage)
                            #! P.onFocus (\ev -> props.editableAction ev true)
                            #! P.onBlur (\ev -> props.editableAction ev false)
                            #! P.onKeyDown onKeyDownHandler
                      S.p ! S.className "label"
                          $ S.text props.label
                      S.input ! S.className "page-number"
                              ! S.disabled (show true)
                              ! S.type' "search"
                              ! S.value (show $ unwrap props.maxPage)
                      S.div ! S.className ("btn-page" <> disableNextBtnClazz)
                            #! P.onClick nextClickHandler
                            $ S.div ! S.className "icon bg-triangle-right"
                                    $ mempty
          S.div ! S.className ("pagination-cover" <> if props.disabled then " show" else "")
                #! P.onClick (const NoOp) -- add click handler to hide clickes from children
                $ mempty
          where
              disablePrevBtnClazz = if props.currentPage == props.minPage then " disabled" else ""
              disableNextBtnClazz = if props.currentPage == props.maxPage then " disabled" else ""
              nextClickHandler :: P.DOMEvent -> Action
              nextClickHandler event =
                  if props.currentPage < props.maxPage then
                  props.changePageAction <<< PageNumber $ (unwrap props.currentPage) + 1
                  else
                  NoOp

              prevClickHandler :: P.DOMEvent -> Action
              prevClickHandler _ =
                  if props.currentPage > props.minPage && not props.disabled then
                  props.changePageAction <<< PageNumber $ (unwrap props.currentPage) - 1
                  else
                  NoOp

              onKeyDownHandler :: P.DOMEvent -> Action
              onKeyDownHandler event =
                  if props.disabled
                      then NoOp
                      else
                          if enterKeyPressed event
                          then
                              let page = PageNumber <<< fromMaybe (unwrap props.currentPage) <<< fromString $ P.targetValue event in
                              if page >= props.minPage && page <= props.maxPage
                                  then props.changePageAction page
                                  else props.invalidPageAction event
                          else NoOp

getMaxPaginationNumber :: Int -> Int -> Int
getMaxPaginationNumber quantity max =
    ceil (toNumber quantity / toNumber max)

-- -----------------
-- txs empty view
-- -----------------

txEmptyContentView :: String -> P.HTML Action
txEmptyContentView message =
    S.div ! S.className "tx-empty__container"
          $ S.text message

-- -----------------
-- logo
-- -----------------

logoView' :: Maybe Route -> P.HTML Action
logoView' mRoute =
    let logoContentTag = case mRoute of
                              Just route ->
                                  S.a ! S.href (toUrl route)
                                      #! P.onClick (Navigate $ toUrl route)
                                      $ mempty
                              Nothing ->
                                  S.div $ mempty
    in
    S.div ! S.className "logo__container"
          $ S.div ! S.className "logo__wrapper"
                  $ logoContentTag  ! S.className "logo__img bg-logo"
                                    ! S.href (toUrl Dashboard)

logoView :: P.HTML Action
logoView = logoView' Nothing

clickableLogoView :: Route -> P.HTML Action
clickableLogoView = logoView' <<< Just

-- -----------------
-- lang
-- -----------------

langItems :: Array Language
langItems =
    [ English
    , Japanese
    , German
    ]

langView :: State -> P.HTML Action
langView state =
    S.select  ! S.className "lang__select bg-arrow-up"
              ! S.value (show $ state ^. lang)
              #! P.onChange (SetLanguage <<< fromMaybe (_.lang initialState) <<< readLanguage <<< P.targetValue)
              $ for_ langItems (langItemView state)

langItemView :: State -> Language -> P.HTML Action
langItemView state lang' =
  let isSelected = lang' == state ^. lang in
  (S.option !? isSelected) (S.className "selected")
      ! S.value (show lang')
      $ S.text (show lang')

-- -----------------
-- helper
-- -----------------

newtype EmptyViewProps = EmptyViewProps {}

mkEmptyViewProps :: EmptyViewProps
mkEmptyViewProps = EmptyViewProps {}

noData :: String
noData = "--"

-- | Helper to add currency classes
currencyCSSClass :: Maybe CCurrency -> String
currencyCSSClass mCurrency =
  case mCurrency of
      Just ADA -> "ada bg-ada-dark"
      Just USD -> "usd bg-usd-dark"
      _ -> ""

-- TODO (jk) Remove placeholderView if all views are implemented
placeholderView :: String -> P.HTML Action
placeholderView label =
    S.div ! S.className "explorer-dashboard__content"
          $ S.text label

emptyView :: P.HTML Action
emptyView = S.div $ mempty

module Explorer.View.Common (
    placeholderView
    , txHeaderView
    , txBodyView
    , emptyTxBodyView
    , emptyTxHeaderView
    , emptyView
    , getMaxPaginationNumber
    , mkTxHeaderViewProps
    , class TxHeaderViewPropsFactory
    , mkTxBodyViewProps
    , class TxBodyViewPropsFactory
    , currencyCSSClass
    , paginationView
    , txPaginationView
    , EmptyViewProps
    , mkEmptyViewProps
    , txEmptyContentView
    , noData
    , logoView
    , clickableLogoView
    , langView
    ) where

import Prelude

import Data.Foldable (for_)
import Data.Int (ceil, fromString, toNumber)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..))

import Explorer.I18n.Lang (Language(..), readLanguage, translate)
import Explorer.I18n.Lenses (common, cDateFormat) as I18nL
import Explorer.Lenses.State (lang)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (initialState)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), PageNumber(..), State)
import Explorer.Util.DOM (enterKeyPressed)
import Explorer.Util.Factory (mkCAddress, mkCTxId, mkCoin)
import Explorer.Util.String (formatADA)
import Explorer.Util.Time (prettyDate)
import Explorer.View.Lenses (txbAmount, txbInputs, txbOutputs, txhAmount, txhHash, txhTimeIssued)
import Exporer.View.Types (TxBodyViewProps(..), TxHeaderViewProps(..))

import Pos.Explorer.Web.ClientTypes (CCoin, CAddress(..), CTxBrief(..), CTxEntry(..), CTxSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CHash, _CTxId, ctbId, ctbInputs, ctbOutputs, ctbOutputSum, ctbTimeIssued, cteId, cteTimeIssued, ctsBlockTimeIssued, ctsId, ctsInputs, ctsOutputs, ctsTotalOutput)

import Pux.DOM.Events (DOMEvent, onBlur, onChange, onFocus, onKeyDown, onClick, targetValue) as P
import Pux.DOM.HTML (HTML) as P

import Text.Smolder.HTML (a, div, p, span, input, option, select) as S
import Text.Smolder.HTML.Attributes (className, href, value, disabled, selected, type', min, max) as S
import Text.Smolder.Markup (text) as S
import Text.Smolder.Markup ((#!), (!), (!?))

-- -----------------
-- tx header
-- -----------------

-- | Factory to create TxHeaderViewProps by a given type
class TxHeaderViewPropsFactory a where
    mkTxHeaderViewProps :: a -> TxHeaderViewProps

-- | Creates a TxHeaderViewProps by a given CTxEntry
instance cTxEntryTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxEntry where
    mkTxHeaderViewProps (CTxEntry entry) = TxHeaderViewProps
        { txhHash: entry ^. cteId
        , txhTimeIssued: Just $ entry ^. cteTimeIssued
        , txhAmount: entry . cteAmount
        }

-- | Creates a TxHeaderViewProps by a given CTxBrief
instance cTxBriefTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxBrief where
    mkTxHeaderViewProps (CTxBrief txBrief) = TxHeaderViewProps
        { txhHash: txBrief ^. ctbId
        , txhTimeIssued: Just $ txBrief ^. ctbTimeIssued
        , txhAmount: txBrief ^. ctbOutputSum
        }

-- | Creates a TxHeaderViewProps by a given CTxSummary
instance cTxSummaryTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxSummary where
    mkTxHeaderViewProps (CTxSummary txSummary) = TxHeaderViewProps
        { txhHash: txSummary ^. ctsId
        , txhTimeIssued: txSummary ^. ctsBlockTimeIssued
        , txhAmount: txSummary ^. ctsTotalOutput
        }

-- | Creates a TxHeaderViewProps by a given EmptyViewProps
instance emtpyTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory EmptyViewProps where
    mkTxHeaderViewProps _ = TxHeaderViewProps
        { txhHash: mkCTxId noData
        , txhTimeIssued: Nothing
        , txhAmount: mkCoin "0"
        }

txHeaderView :: Language -> TxHeaderViewProps -> P.HTML Action
txHeaderView lang (TxHeaderViewProps props) =
    S.div ! S.className "transaction-header" $ do
        S.div ! S.className "hash-container"
              $ S.a ! S.href (toUrl txRoute)
              #! P.onClick (Navigate $ toUrl txRoute)
              ! S.className "hash"
              $ S.text (props ^. (txhHash <<< _CTxId <<< _CHash))
        S.div ! S.className "date"
              $ S.text $ case props ^. txhTimeIssued of
                              Just time ->
                                  let format = translate (I18nL.common <<< I18nL.cDateFormat) lang
                                  in fromMaybe noData $ prettyDate format time
                              Nothing -> noData
        txAmountView (props ^. txhAmount) lang
    where
        txRoute = Tx $ props ^. txhHash

emptyTxHeaderView :: P.HTML Action
emptyTxHeaderView =
    S.div ! S.className "transaction-header"
          $ mempty

txAmountView :: CCoin -> Language -> P.HTML Action
txAmountView coin lang =
    S.div ! S.className "amount-container"
          $ S.div ! S.className "amount bg-ada"
                  $ S.text (formatADA coin lang)

-- -----------------
-- tx body
-- -----------------

-- | Factory to create TxBodyViewProps by a given type
class TxBodyViewPropsFactory a where
    mkTxBodyViewProps :: a -> TxBodyViewProps

-- | Creates a TxBodyViewProps by a given CTxSummary
instance cTxSummaryTxBodyViewPropsFactory :: TxBodyViewPropsFactory CTxSummary where
    mkTxBodyViewProps (CTxSummary txSummary) = TxBodyViewProps
        { txbInputs: txSummary ^. ctsInputs
        , txbOutputs: txSummary ^. ctsOutputs
        , txbAmount: txSummary ^. ctsTotalOutput
        }

-- | Creates a TxBodyViewProps by a given CTxBrief
instance cTxBriefTxBodyViewPropsFactory :: TxBodyViewPropsFactory CTxBrief where
    mkTxBodyViewProps (CTxBrief txBrief) = TxBodyViewProps
        { txbInputs: txBrief ^. ctbInputs
        , txbOutputs: txBrief ^. ctbOutputs
        , txbAmount: txBrief ^. ctbOutputSum
        }

-- | Creates a TxBodyViewProps by a given EmptyViewProps
instance emptyTxBodyViewPropsFactory :: TxBodyViewPropsFactory EmptyViewProps where
    mkTxBodyViewProps _ = TxBodyViewProps
        { txbInputs: []
        , txbOutputs: []
        , txbAmount: mkCoin "0"
        }

txBodyView :: Language -> TxBodyViewProps -> P.HTML Action
txBodyView lang (TxBodyViewProps props) =
    S.div ! S.className "transaction-body" $ do
        S.div ! S.className "from-hash-container"
              $ for_ (props ^. txbInputs) txFromView
        S.div ! S.className "to-hash-container bg-transaction-arrow"
              $ S.div ! S.className "to-hash-wrapper"
                      $ for_ (props ^. txbOutputs) txToView
        S.div ! S.className "amounts-container"
              $ for_ (props ^. txbOutputs) (txBodyAmountView lang)
        txAmountView (props ^. txbAmount) lang

emptyTxBodyView :: P.HTML Action
emptyTxBodyView =
    S.div ! S.className "transaction-body"
          $ mempty

txFromView :: Tuple CAddress CCoin -> P.HTML Action
txFromView (Tuple (CAddress cAddress) _) =
    let addressRoute = Address $ mkCAddress cAddress in
    S.a ! S.href (toUrl addressRoute)
        #! P.onClick (Navigate $ toUrl addressRoute)
        ! S.className "from-hash"
        $ S.text cAddress

txToView :: Tuple CAddress CCoin -> P.HTML Action
txToView (Tuple (CAddress cAddress) _) =
    let addressRoute = Address $ mkCAddress cAddress in
    S.a ! S.href (toUrl addressRoute)
        #! P.onClick (Navigate $ toUrl addressRoute)
        ! S.className "to-hash"
        $ S.text cAddress

txBodyAmountView :: Language -> Tuple CAddress CCoin -> P.HTML Action
txBodyAmountView lang (Tuple _ coin) =
    S.div ! S.className "amount-wrapper"
          $ S.span  ! S.className "plain-amount bg-ada-dark"
                    $ S.text (formatADA coin lang)

-- -----------------
-- pagination
-- -----------------

type PaginationViewProps =
    { label :: String
    , currentPage :: PageNumber
    , minPage :: PageNumber
    , maxPage :: PageNumber
    , editable :: Boolean
    , changePageAction :: (PageNumber -> Action)
    , editableAction :: (P.DOMEvent -> Boolean -> Action)
    , invalidPageAction :: (P.DOMEvent -> Action)
    , disabled :: Boolean
    }

txPaginationView :: PaginationViewProps -> P.HTML Action
txPaginationView props =
    S.div ! S.className "transaction-pagination"
          $ paginationView props

paginationView :: PaginationViewProps -> P.HTML Action
paginationView props =
    S.div ! S.className "pagination-wrapper" $ do
          S.div ! S.className "pagination" $ do
                S.div ! S.className "pagination__container" $ do
                      S.div ! S.className ("btn-page" <> disablePrevBtnClazz)
                              #! P.onClick prevClickHandler
                              $ S.div ! S.className "icon bg-triangle-left"
                                      $ mempty
                      (S.input !? not props.editable) (S.value <<< show $ unwrap props.currentPage)
                            ! S.className "page-number"
                            -- ! S.disabled (show $ props.maxPage == props.minPage)
                            ! S.disabled (if props.maxPage == props.minPage then "disabled" else "")
                            ! S.min (show $ unwrap props.minPage)
                            ! S.max (show $ unwrap props.maxPage)
                            #! P.onFocus (\ev -> props.editableAction ev true)
                            #! P.onBlur (\ev -> props.editableAction ev false)
                            #! P.onKeyDown onKeyDownHandler
                      S.p ! S.className "label"
                          $ S.text props.label
                      S.input ! S.className "page-number"
                              ! S.disabled (show true)
                              ! S.type' "search"
                              ! S.value (show $ unwrap props.maxPage)
                      S.div ! S.className ("btn-page" <> disableNextBtnClazz)
                            #! P.onClick nextClickHandler
                            $ S.div ! S.className "icon bg-triangle-right"
                                    $ mempty
          S.div ! S.className ("pagination-cover" <> if props.disabled then " show" else "")
                #! P.onClick (const NoOp) -- add click handler to hide clickes from children
                $ mempty
          where
              disablePrevBtnClazz = if props.currentPage == props.minPage then " disabled" else ""
              disableNextBtnClazz = if props.currentPage == props.maxPage then " disabled" else ""
              nextClickHandler :: P.DOMEvent -> Action
              nextClickHandler event =
                  if props.currentPage < props.maxPage then
                  props.changePageAction <<< PageNumber $ (unwrap props.currentPage) + 1
                  else
                  NoOp

              prevClickHandler :: P.DOMEvent -> Action
              prevClickHandler _ =
                  if props.currentPage > props.minPage && not props.disabled then
                  props.changePageAction <<< PageNumber $ (unwrap props.currentPage) - 1
                  else
                  NoOp

              onKeyDownHandler :: P.DOMEvent -> Action
              onKeyDownHandler event =
                  if props.disabled
                      then NoOp
                      else
                          if enterKeyPressed event
                          then
                              let page = PageNumber <<< fromMaybe (unwrap props.currentPage) <<< fromString $ P.targetValue event in
                              if page >= props.minPage && page <= props.maxPage
                                  then props.changePageAction page
                                  else props.invalidPageAction event
                          else NoOp

getMaxPaginationNumber :: Int -> Int -> Int
getMaxPaginationNumber quantity max =
    ceil (toNumber quantity / toNumber max)

-- -----------------
-- txs empty view
-- -----------------

txEmptyContentView :: String -> P.HTML Action
txEmptyContentView message =
    S.div ! S.className "tx-empty__container"
          $ S.text message

-- -----------------
-- logo
-- -----------------

logoView' :: Maybe Route -> P.HTML Action
logoView' mRoute =
    let logoContentTag = case mRoute of
                              Just route ->
                                  S.a ! S.href (toUrl route)
                                      #! P.onClick (Navigate $ toUrl route)
                                      $ mempty
                              Nothing ->
                                  S.div $ mempty
    in
    S.div ! S.className "logo__container"
          $ S.div ! S.className "logo__wrapper"
                  $ logoContentTag  ! S.className "logo__img bg-logo"
                                    ! S.href (toUrl Dashboard)

logoView :: P.HTML Action
logoView = logoView' Nothing

clickableLogoView :: Route -> P.HTML Action
clickableLogoView = logoView' <<< Just

-- -----------------
-- lang
-- -----------------

-- currency

langItems :: Array Language
langItems =
    [ English
    , Japanese
    , German
    ]

langView :: State -> P.HTML Action
langView state =
    S.select  ! S.className "lang__select bg-arrow-up"
              #! P.onChange (SetLanguage <<< fromMaybe (_.lang initialState) <<< readLanguage <<< P.targetValue)
              $ for_ langItems (langItemView state)

langItemView :: State -> Language -> P.HTML Action
langItemView state lang' =
  let selected = (show lang') == (show $ state ^. lang) in
  (S.option !? selected) (S.className "selected")
      ! S.value (show lang')
      ! S.selected (show selected)
      $ S.text (show lang')

-- -----------------
-- helper
-- -----------------

newtype EmptyViewProps = EmptyViewProps {}

mkEmptyViewProps :: EmptyViewProps
mkEmptyViewProps = EmptyViewProps {}

noData :: String
noData = "--"

-- | Helper to add currency classes
currencyCSSClass :: Maybe CCurrency -> String
currencyCSSClass mCurrency =
  case mCurrency of
      Just ADA -> "ada bg-ada-dark"
      Just USD -> "usd bg-usd-dark"
      _ -> ""

-- TODO (jk) Remove placeholderView if all views are implemented
placeholderView :: String -> P.HTML Action
placeholderView label =
    S.div ! S.className "explorer-dashboard__content"
          $ S.text label

emptyView :: P.HTML Action
emptyView = S.div $ mempty


Add `succ` and `pred`

Add `succ` and `pred`

module Data.Enum where

import Data.Maybe

class Enum a where
  toEnum :: Number -> Maybe a
  fromEnum :: a -> Number

succ :: forall a. (Enum a) => a -> Maybe a
succ x = toEnum (fromEnum x + 1)

pred :: forall a. (Enum a) => a -> Maybe a
pred x = toEnum (fromEnum x - 1)


Fix accidental export of listenImpl

Fix accidental export of listenImpl

-- | This module defines low-level bindings to the Node HTTP module.

module Node.HTTP
  ( Server
  , Request
  , Response
  , HTTP

  , createServer
  , listen
  , ListenOptions
  , listenSocket

  , httpVersion
  , requestHeaders
  , requestMethod
  , requestURL
  , requestAsStream

  , setHeader
  , setHeaders
  , setStatusCode
  , setStatusMessage
  , responseAsStream
  ) where

import Prelude

import Control.Monad.Eff (Eff)

import Data.Maybe (Maybe)
import Data.Nullable (Nullable, toNullable)
import Data.StrMap (StrMap)

import Node.Stream (Writable, Readable)

import Unsafe.Coerce (unsafeCoerce)

-- | The type of a HTTP server object
foreign import data Server :: *

-- | A HTTP request object
foreign import data Request :: *

-- | A HTTP response object
foreign import data Response :: *

-- | The effect associated with using the HTTP module.
foreign import data HTTP :: !

-- | Create a HTTP server, given a function to be executed when a request is received.
foreign import createServer :: forall eff. (Request -> Response -> Eff (http :: HTTP | eff) Unit) -> Eff (http :: HTTP | eff) Server

foreign import listenImpl :: forall eff. Server -> Int -> String -> Nullable Int -> Eff (http :: HTTP | eff) Unit -> Eff (http :: HTTP | eff) Unit

-- | Listen on a port in order to start accepting HTTP requests. The specified callback will be run when setup is complete.
listen :: forall eff. Server -> ListenOptions -> Eff (http :: HTTP | eff) Unit -> Eff (http :: HTTP | eff) Unit
listen server opts done = listenImpl server opts.port opts.hostname (toNullable opts.backlog) done

-- | Options to be supplied to `listen`. See the [Node API](https://nodejs.org/dist/latest-v6.x/docs/api/http.html#http_server_listen_handle_callback) for detailed information about these.
type ListenOptions =
  { hostname :: String
  , port :: Int
  , backlog :: Maybe Int
  }

-- | Listen on a unix socket. The specified callback will be run when setup is complete.
foreign import listenSocket :: forall eff. Server -> String -> Eff (http :: HTTP | eff) Unit -> Eff (http :: HTTP | eff) Unit

-- | Get the request HTTP version
httpVersion :: Request -> String
httpVersion = _.httpVersion <<< unsafeCoerce

-- | Get the request headers as a hash
requestHeaders :: Request -> StrMap String
requestHeaders = _.headers <<< unsafeCoerce

-- | Get the request method (GET, POST, etc.)
requestMethod :: Request -> String
requestMethod = _.method <<< unsafeCoerce

-- | Get the request URL
requestURL :: Request -> String
requestURL = _.url <<< unsafeCoerce

-- | Coerce the request object into a readable stream.
requestAsStream :: forall eff. Request -> Readable () (http :: HTTP | eff)
requestAsStream = unsafeCoerce

-- | Set a header with a single value.
foreign import setHeader :: forall eff. Response -> String -> String -> Eff (http :: HTTP | eff) Unit

-- | Set a header with multiple values.
foreign import setHeaders :: forall eff. Response -> String -> Array String -> Eff (http :: HTTP | eff) Unit

-- | Set the status code.
foreign import setStatusCode :: forall eff. Response -> Int -> Eff (http :: HTTP | eff) Unit

-- | Set the status message.
foreign import setStatusMessage :: forall eff. Response -> String -> Eff (http :: HTTP | eff) Unit

-- | Coerce the response object into a writable stream.
responseAsStream :: forall eff. Response -> Writable () (http :: HTTP | eff)
responseAsStream = unsafeCoerce

-- | This module defines low-level bindings to the Node HTTP module.

module Node.HTTP where

import Prelude

import Control.Monad.Eff (Eff)

import Data.Maybe (Maybe)
import Data.Nullable (Nullable, toNullable)
import Data.StrMap (StrMap)

import Node.Stream (Writable, Readable)

import Unsafe.Coerce (unsafeCoerce)

-- | The type of a HTTP server object
foreign import data Server :: *

-- | A HTTP request object
foreign import data Request :: *

-- | A HTTP response object
foreign import data Response :: *

-- | The effect associated with using the HTTP module.
foreign import data HTTP :: !

-- | Create a HTTP server, given a function to be executed when a request is received.
foreign import createServer :: forall eff. (Request -> Response -> Eff (http :: HTTP | eff) Unit) -> Eff (http :: HTTP | eff) Server

foreign import listenImpl :: forall eff. Server -> Int -> String -> Nullable Int -> Eff (http :: HTTP | eff) Unit -> Eff (http :: HTTP | eff) Unit

-- | Listen on a port in order to start accepting HTTP requests. The specified callback will be run when setup is complete.
listen :: forall eff. Server -> ListenOptions -> Eff (http :: HTTP | eff) Unit -> Eff (http :: HTTP | eff) Unit
listen server opts done = listenImpl server opts.port opts.hostname (toNullable opts.backlog) done

-- | Listen on a unix socket. The specified callback will be run when setup is complete.
foreign import listenSocket :: forall eff. Server -> String -> Eff (http :: HTTP | eff) Unit -> Eff (http :: HTTP | eff) Unit

-- | Options to be supplied to `listen`. See the [Node API](https://nodejs.org/dist/latest-v6.x/docs/api/http.html#http_server_listen_handle_callback) for detailed information about these.
type ListenOptions =
  { hostname :: String
  , port :: Int
  , backlog :: Maybe Int
  }

-- | Get the request HTTP version
httpVersion :: Request -> String
httpVersion = _.httpVersion <<< unsafeCoerce

-- | Get the request headers as a hash
requestHeaders :: Request -> StrMap String
requestHeaders = _.headers <<< unsafeCoerce

-- | Get the request method (GET, POST, etc.)
requestMethod :: Request -> String
requestMethod = _.method <<< unsafeCoerce

-- | Get the request URL
requestURL :: Request -> String
requestURL = _.url <<< unsafeCoerce

-- | Coerce the request object into a readable stream.
requestAsStream :: forall eff. Request -> Readable () (http :: HTTP | eff)
requestAsStream = unsafeCoerce

-- | Set a header with a single value.
foreign import setHeader :: forall eff. Response -> String -> String -> Eff (http :: HTTP | eff) Unit

-- | Set a header with multiple values.
foreign import setHeaders :: forall eff. Response -> String -> Array String -> Eff (http :: HTTP | eff) Unit

-- | Set the status code.
foreign import setStatusCode :: forall eff. Response -> Int -> Eff (http :: HTTP | eff) Unit

-- | Set the status message.
foreign import setStatusMessage :: forall eff. Response -> String -> Eff (http :: HTTP | eff) Unit

-- | Coerce the response object into a writable stream.
responseAsStream :: forall eff. Response -> Writable () (http :: HTTP | eff)
responseAsStream = unsafeCoerce


Simply make the cubes a little smaller, closes #7

module Isomer where

import Control.Monad.Eff

foreign import data Isomer :: !

foreign import data IsomerInstance :: *

foreign import data IsomerColor :: *

-- | (Install and) return the Isomer instance on the canvas with the given id
foreign import getIsomerInstance
  """
  var getIsomerInstance = (function() {
    var instances = {};

    return function(canvasId) {
      return function() {
        if (!instances.hasOwnProperty(canvasId)) {
          var canvas = document.getElementById(canvasId);
          instances[canvasId] = new Isomer(canvas);
        }
        return instances[canvasId];
      };
    };
  })();""" :: forall eff. String
           -> Eff (isomer :: Isomer | eff) IsomerInstance

-- | Render a single colored cube at the given position
foreign import renderCube
  """
  function renderCube(isomer) {
    return function(x) {
      return function(y) {
        return function(z) {
          return function(color) {
            return function() {
              isomer.add(
                new Isomer.Shape.Prism(
                  new Isomer.Point(x, y, z),
                  0.9, 0.9, 0.9
                ),
                color
              );
              return {};
            };
          }
        }
      };
    };
  }
  """ :: forall eff. IsomerInstance
      -> Number
      -> Number
      -> Number
      -> IsomerColor
      -> Eff (isomer :: Isomer | eff) Unit

-- | Clear the whole canvas that belongs to the Isomer instance
foreign import clearCanvas
  """
  function clearCanvas(isomer) {
    return function() {
      isomer.canvas.clear();
      return {};
    };
  }
  """ :: forall eff. IsomerInstance
      -> Eff (isomer :: Isomer | eff) Unit

-- | Set Isomer scale factor and origin (X and Y)
foreign import setIsomerConfig
  """
  function setIsomerConfig(isomer) {
    return function(scale) {
      return function(originX) {
        return function(originY) {
          return function() {
            isomer.scale = scale;
            isomer.originX = originX;
            isomer.originY = originY;
            isomer._calculateTransformation();
            return {};
          }
        };
      };
    };
  }""" :: forall eff. IsomerInstance
       -> Number
       -> Number
       -> Number
       -> Eff (isomer :: Isomer | eff) Unit

-- | Create Isomer.Color object from its RGB representation
foreign import colorFromRGB
  """
  function colorFromRGB(r) {
    return function(g) {
      return function(b) {
        return new Isomer.Color(r, g, b);
      };
    };
  }
  """ :: Number
      -> Number
      -> Number
      -> IsomerColor

module Isomer where

import Control.Monad.Eff

foreign import data Isomer :: !

foreign import data IsomerInstance :: *

foreign import data IsomerColor :: *

-- | (Install and) return the Isomer instance on the canvas with the given id
foreign import getIsomerInstance
  """
  var getIsomerInstance = (function() {
    var instances = {};

    return function(canvasId) {
      return function() {
        if (!instances.hasOwnProperty(canvasId)) {
          var canvas = document.getElementById(canvasId);
          instances[canvasId] = new Isomer(canvas);
        }
        return instances[canvasId];
      };
    };
  })();""" :: forall eff. String
           -> Eff (isomer :: Isomer | eff) IsomerInstance

-- | Render a single colored cube at the given position
foreign import renderCube
  """
  function renderCube(isomer) {
    return function(x) {
      return function(y) {
        return function(z) {
          return function(color) {
            return function() {
              isomer.add(
                new Isomer.Shape.Prism(
                  new Isomer.Point(x, y, z),
                  1, 1, 1
                ),
                color
              );
              return {};
            };
          }
        }
      };
    };
  }
  """ :: forall eff. IsomerInstance
      -> Number
      -> Number
      -> Number
      -> IsomerColor
      -> Eff (isomer :: Isomer | eff) Unit

-- | Clear the whole canvas that belongs to the Isomer instance
foreign import clearCanvas
  """
  function clearCanvas(isomer) {
    return function() {
      isomer.canvas.clear();
      return {};
    };
  }
  """ :: forall eff. IsomerInstance
      -> Eff (isomer :: Isomer | eff) Unit

-- | Set Isomer scale factor and origin (X and Y)
foreign import setIsomerConfig
  """
  function setIsomerConfig(isomer) {
    return function(scale) {
      return function(originX) {
        return function(originY) {
          return function() {
            isomer.scale = scale;
            isomer.originX = originX;
            isomer.originY = originY;
            isomer._calculateTransformation();
            return {};
          }
        };
      };
    };
  }""" :: forall eff. IsomerInstance
       -> Number
       -> Number
       -> Number
       -> Eff (isomer :: Isomer | eff) Unit

-- | Create Isomer.Color object from its RGB representation
foreign import colorFromRGB
  """
  function colorFromRGB(r) {
    return function(g) {
      return function(b) {
        return new Isomer.Color(r, g, b);
      };
    };
  }
  """ :: Number
      -> Number
      -> Number
      -> IsomerColor


Remove unused `foldpP` FFI import

Remove unused `foldpP` FFI import

module Signal
  ( Signal()
  , constant
  , merge
  , mergeMany
  , foldp
  , sampleOn
  , dropRepeats
  , dropRepeats'
  , runSignal
  , unwrap
  , filter
  , filterMap
  , (<~)
  , (~>)
  , (~)
  , squigglyMap
  , squigglyApply
  , flippedMap
  , map2
  , map3
  , map4
  , map5
  ) where

import Control.Monad.Eff (Eff())
import Prelude ((<$>), flip, Unit(), class Eq, class Semigroup, class Functor, class Applicative, class Apply, map, apply)
import Data.Foldable (foldl, class Foldable)
import Data.Maybe (Maybe(..), fromMaybe, isJust)

foreign import data Signal :: * -> *

-- |Creates a signal with a constant value.
foreign import constant :: forall a. a -> Signal a

foreign import mapSig :: forall a b. (a -> b) -> Signal a -> Signal b
foreign import applySig :: forall a b. Signal (a -> b) -> Signal a -> Signal b

-- |Merge two signals, returning a new signal which will yield a value
-- |whenever either of the input signals yield. Its initial value will be
-- |that of the first signal.
foreign import merge :: forall a. (Signal a) -> (Signal a) -> (Signal a)

-- |Merge all signals inside a `Foldable`, returning a `Maybe` which will
-- |either contain the resulting signal, or `Nothing` if the `Foldable`
-- |was empty.
mergeMany :: forall f a. (Functor f, Foldable f) => f (Signal a) -> Maybe (Signal a)
mergeMany sigs = foldl mergeMaybe Nothing (Just <$> sigs)
  where mergeMaybe a Nothing = a
        mergeMaybe Nothing a = a
        mergeMaybe (Just a) (Just b) = Just (merge a b)

-- |Creates a past dependent signal. The function argument takes the value of
-- |the input signal, and the previous value of the output signal, to produce
-- |the new value of the output signal.
foreign import foldp :: forall a b. (a -> b -> b) -> b -> (Signal a) -> (Signal b)

-- |Creates a signal which yields the current value of the second signal every
-- |time the first signal yields.
foreign import sampleOn :: forall a b. (Signal a) -> (Signal b) -> (Signal b)

-- |Create a signal which only yields values which aren't equal to the previous
-- |value of the input signal.
foreign import dropRepeats :: forall a. (Eq a) => Signal a -> Signal a

-- |Create a signal which only yields values which aren't equal to the previous
-- |value of the input signal, using JavaScript's `!==` operator to determine
-- |disequality.
foreign import dropRepeats' :: forall a. (Signal a) -> (Signal a)

-- |Given a signal of effects with no return value, run each effect as it
-- |comes in.
foreign import runSignal :: forall e. Signal (Eff e Unit) -> Eff e Unit

-- |Takes a signal of effects of `a`, and produces an effect which returns a
-- |signal which will take each effect produced by the input signal, run it,
-- |and yield its returned value.
foreign import unwrap :: forall e a. Signal (Eff e a) -> Eff e (Signal a)

-- |Takes a signal and filters out yielded values for which the provided
-- |predicate function returns `false`.
foreign import filter :: forall a. (a -> Boolean) -> a -> (Signal a) -> (Signal a)

-- |Map a signal over a function which returns a `Maybe`, yielding only the
-- |values inside `Just`s, dropping the `Nothing`s.
filterMap :: forall a b. (a -> Maybe b) -> b -> Signal a -> Signal b
filterMap f def sig = (fromMaybe def) <$> filter isJust (Just def) (f <$> sig)

instance functorSignal :: Functor Signal where
  map = mapSig

instance applySignal :: Apply Signal where
  apply = applySig

instance applicativeSignal :: Applicative Signal where
  pure = constant

instance semigroupSignal :: Semigroup (Signal a) where
  append = merge

infixl 4 squigglyMap as <~
infixl 4 squigglyApply as ~
infixl 4 flippedMap as ~>

squigglyMap :: forall f a b. Functor f => (a -> b) -> f a -> f b
squigglyMap = map

squigglyApply :: forall f a b. Apply f => f (a -> b) -> f a -> f b
squigglyApply = apply

flippedMap :: forall f a b. Functor f => f a -> (a -> b) -> f b
flippedMap = flip map

map2 :: forall a b c. (a -> b -> c) -> Signal a -> Signal b -> Signal c
map2 f a b = f <~ a ~ b

map3 :: forall a b c d. (a -> b -> c -> d) -> Signal a -> Signal b -> Signal c -> Signal d
map3 f a b c = f <~ a ~ b ~ c

map4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e
map4 f a b c d = f <~ a ~ b ~ c ~ d

map5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f
map5 f a b c d e = f <~ a ~ b ~ c ~ d ~ e

module Signal
  ( Signal()
  , constant
  , merge
  , mergeMany
  , foldp
  , sampleOn
  , dropRepeats
  , dropRepeats'
  , runSignal
  , unwrap
  , filter
  , filterMap
  , (<~)
  , (~>)
  , (~)
  , squigglyMap
  , squigglyApply
  , flippedMap
  , map2
  , map3
  , map4
  , map5
  ) where

import Control.Monad.Eff (Eff())
import Prelude ((<$>), flip, Unit(), class Eq, class Semigroup, class Functor, class Applicative, class Apply, map, apply)
import Data.Foldable (foldl, class Foldable)
import Data.Maybe (Maybe(..), fromMaybe, isJust)

foreign import data Signal :: * -> *

-- |Creates a signal with a constant value.
foreign import constant :: forall a. a -> Signal a

foreign import mapSig :: forall a b. (a -> b) -> Signal a -> Signal b
foreign import applySig :: forall a b. Signal (a -> b) -> Signal a -> Signal b

-- |Merge two signals, returning a new signal which will yield a value
-- |whenever either of the input signals yield. Its initial value will be
-- |that of the first signal.
foreign import merge :: forall a. (Signal a) -> (Signal a) -> (Signal a)

-- |Merge all signals inside a `Foldable`, returning a `Maybe` which will
-- |either contain the resulting signal, or `Nothing` if the `Foldable`
-- |was empty.
mergeMany :: forall f a. (Functor f, Foldable f) => f (Signal a) -> Maybe (Signal a)
mergeMany sigs = foldl mergeMaybe Nothing (Just <$> sigs)
  where mergeMaybe a Nothing = a
        mergeMaybe Nothing a = a
        mergeMaybe (Just a) (Just b) = Just (merge a b)

foreign import foldpP :: forall a b c. (c -> Signal c) -> (a -> b -> b) -> b -> (Signal a) -> (Signal b)

-- |Creates a past dependent signal. The function argument takes the value of
-- |the input signal, and the previous value of the output signal, to produce
-- |the new value of the output signal.
foreign import foldp :: forall a b. (a -> b -> b) -> b -> (Signal a) -> (Signal b)

-- |Creates a signal which yields the current value of the second signal every
-- |time the first signal yields.
foreign import sampleOn :: forall a b. (Signal a) -> (Signal b) -> (Signal b)

-- |Create a signal which only yields values which aren't equal to the previous
-- |value of the input signal.
foreign import dropRepeats :: forall a. (Eq a) => Signal a -> Signal a

-- |Create a signal which only yields values which aren't equal to the previous
-- |value of the input signal, using JavaScript's `!==` operator to determine
-- |disequality.
foreign import dropRepeats' :: forall a. (Signal a) -> (Signal a)

-- |Given a signal of effects with no return value, run each effect as it
-- |comes in.
foreign import runSignal :: forall e. Signal (Eff e Unit) -> Eff e Unit

-- |Takes a signal of effects of `a`, and produces an effect which returns a
-- |signal which will take each effect produced by the input signal, run it,
-- |and yield its returned value.
foreign import unwrap :: forall e a. Signal (Eff e a) -> Eff e (Signal a)

-- |Takes a signal and filters out yielded values for which the provided
-- |predicate function returns `false`.
foreign import filter :: forall a. (a -> Boolean) -> a -> (Signal a) -> (Signal a)

-- |Map a signal over a function which returns a `Maybe`, yielding only the
-- |values inside `Just`s, dropping the `Nothing`s.
filterMap :: forall a b. (a -> Maybe b) -> b -> Signal a -> Signal b
filterMap f def sig = (fromMaybe def) <$> filter isJust (Just def) (f <$> sig)

instance functorSignal :: Functor Signal where
  map = mapSig

instance applySignal :: Apply Signal where
  apply = applySig

instance applicativeSignal :: Applicative Signal where
  pure = constant

instance semigroupSignal :: Semigroup (Signal a) where
  append = merge

infixl 4 squigglyMap as <~
infixl 4 squigglyApply as ~
infixl 4 flippedMap as ~>

squigglyMap :: forall f a b. Functor f => (a -> b) -> f a -> f b
squigglyMap = map

squigglyApply :: forall f a b. Apply f => f (a -> b) -> f a -> f b
squigglyApply = apply

flippedMap :: forall f a b. Functor f => f a -> (a -> b) -> f b
flippedMap = flip map

map2 :: forall a b c. (a -> b -> c) -> Signal a -> Signal b -> Signal c
map2 f a b = f <~ a ~ b

map3 :: forall a b c d. (a -> b -> c -> d) -> Signal a -> Signal b -> Signal c -> Signal d
map3 f a b c = f <~ a ~ b ~ c

map4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e
map4 f a b c d = f <~ a ~ b ~ c ~ d

map5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f
map5 f a b c d e = f <~ a ~ b ~ c ~ d ~ e


Refactoring...

Refactoring...

module Gattaca.Experiments.Rx where

import Control.Monad
import Debug.Trace
import Data.Foldable
import Gattaca.Experiments.Utils

import Data.Monoid
import Control.Monad.State
import Control.Monad.State.Class

data Observer m a = Observer (a -> m Unit)
                             (Unit -> m Unit)

data Observable m a = Observable (Observer m a -> m Unit)

create :: forall m a.(Monad m) => (Observer m a -> m Unit) -> Observable m a
create = Observable

onNext :: forall m a.(Monad m) => a -> Observer m a -> m Unit
onNext x (Observer o _) = o x

onCompleted :: forall m a.(Monad m) => Observer m a -> m Unit
onCompleted (Observer _ c) = c unit

subscribe :: forall m a.(Monad m) => (a -> m Unit) -> (Unit -> m Unit) -> Observable m a -> m Unit
subscribe n c (Observable os) = os (Observer n c)

filter :: forall m a.(Monad m) => (a -> Boolean) -> Observable m a -> Observable m a
filter f os = create (\o -> os |> subscribe (\x -> if (f x) then (o |> onNext x) else return unit)
                                            (\unit -> o |> onCompleted))

toObservable :: forall m a. (Monad m) => [a] -> Observable m a
toObservable xs = create (\o -> do sequence_ ((\x -> onNext x o) <$> xs)
                                   o |> onCompleted)

toList :: forall a.Observable (State [a]) a -> [a]
toList os = execState (os |> subscribe (\x -> modify (\xs -> xs ++ [x])) (\unit -> return unit)) []

instance functorObservable :: (Monad m) => Functor (Observable m) where
  (<$>) f os = create (\o -> os |> subscribe (\x -> o |> onNext (f x))
                                             (\unit -> o |> onCompleted))

instance applyObservable :: (Monad m) => Apply (Observable m) where
  (<*>) fs xs = create (\o -> fs |> subscribe (\f -> xs |> subscribe (\x -> o |> onNext (f x))
                                                                     (\unit -> o |> onCompleted))
                                              (\unit -> o |> onCompleted))

instance applicativeObservable :: (Monad m) => Applicative (Observable m) where
   pure x = create (\o -> o |> onNext x)

instance semigroupObservable :: (Monad m) => Semigroup (Observable m a) where
  (<>) xs ys = create (\o -> xs |> subscribe (\x -> o |> onNext x)
                                             (\unit -> ys |> subscribe (\x -> o |> onNext x)
                                                                       (\unit -> o |> onCompleted)))

instance monoidObservable :: (Monad m) => Monoid (Observable m a) where
    mempty = create (\o -> o |> onCompleted)

module Gattaca.Experiments.Rx where

import Control.Monad
import Debug.Trace
import Data.Foldable
import Gattaca.Experiments.Utils

import Data.Monoid
import Control.Monad.State
import Control.Monad.State.Class

data Observer m a = Observer (a -> m Unit)
                             (Unit -> m Unit)

data Observable m a = Observable (Observer m a -> m Unit)

create :: forall m a.(Monad m) => (Observer m a -> m Unit) -> Observable m a
create = Observable

onNext :: forall m a.(Monad m) => a -> Observer m a -> m Unit
onNext x (Observer o _) = o x

onCompleted :: forall m a.(Monad m) => Observer m a -> m Unit
onCompleted (Observer _ c) = c unit

subscribe :: forall m a.(Monad m) => (a -> m Unit) -> (Unit -> m Unit) -> Observable m a -> m Unit
subscribe n c (Observable os) = os (Observer n c)

instance functorObservable :: (Monad m) => Functor (Observable m) where
  (<$>) f os = create (\o -> os |> subscribe (\x -> o |> onNext (f x))
                                             (\unit -> o |> onCompleted))

instance applyObservable :: (Monad m) => Apply (Observable m) where
  (<*>) fs xs = create (\o -> fs |> subscribe (\f -> xs |> subscribe (\x -> o |> onNext (f x))
                                                                     (\unit -> o |> onCompleted))
                                              (\unit -> o |> onCompleted))

instance applicativeObservable :: (Monad m) => Applicative (Observable m) where
   pure x = create (\o -> o |> onNext x)

filter :: forall m a.(Monad m) => (a -> Boolean) -> Observable m a -> Observable m a
filter f os = create (\o -> os |> subscribe (\x -> if (f x) then (o |> onNext x) else return unit)
                                            (\unit -> o |> onCompleted))

concat :: forall m a.(Monad m) => Observable m a -> Observable m a -> Observable m a
concat xs ys = create (\o -> xs |> subscribe (\x -> o |> onNext x)
                                             (\unit -> ys |> subscribe (\x -> o |> onNext x)
                                                                       (\unit -> o |> onCompleted)))

instance semigroupObservable :: (Monad m) => Semigroup (Observable m a) where
    (<>) = concat

empty :: forall m a.(Monad m) => Observable m a
empty = create (\o -> o |> onCompleted)

instance monoidObservable :: (Monad m) => Monoid (Observable m a) where
    mempty = empty

toObservable :: forall m a. (Monad m) => [a] -> Observable m a
toObservable xs = create (\o -> do sequence_ ((\x -> onNext x o) <$> xs)
                                   o |> onCompleted)

toList :: forall a.Observable (State [a]) a -> [a]
toList os = execState (os |> subscribe (\x -> modify (\xs -> xs ++ [x])) (\unit -> return unit)) []


Update interpreter to work with new Feature types

module Genetics.Browser.GlyphF.Interpret
       ( writeGlyph )
       where

import Prelude

import Control.Monad.Eff.Unsafe (unsafePerformEff)
import Control.Monad.Except (runExcept)
import Data.Either (Either(..))
import Data.Foldable (fold)
import Data.Foreign (F, Foreign, Prop(..), renderForeignError, toForeign, writeObject)
import Data.Foreign.Null (writeNull)
import Data.Maybe (Maybe, fromMaybe)
import Data.Newtype (unwrap)
import Genetics.Browser.Feature (Feature)
import Genetics.Browser.Glyph (Glyph)
import Genetics.Browser.GlyphF.Canvas as Canvas
import Genetics.Browser.GlyphF.Position (glyphToGlyphPosition)
import Genetics.Browser.GlyphF.SVG as SVG

writeGlyph' :: ∀ a c r. Maybe (Feature c r) -> Glyph a -> Foreign
writeGlyph' f g = writeObject [ unsafeProp "draw" $ unsafePerformEff <<< \ctx -> Canvas.renderGlyph ctx g
                              , unsafeProp "min" $ const p.min
                              , unsafeProp "max" $ const p.max
                              , unsafeProp "minY" $ const p.minY
                              , unsafeProp "maxY" $ const p.maxY
                              , unsafeProp "feature" f'
                              , unsafeProp "toSVG" $ unsafePerformEff <<< \_ -> SVG.renderGlyph g
                              ]
    where p = unwrap $ glyphToGlyphPosition g
          f' = fromMaybe writeNull (toForeign <$> f)
          unsafeProp :: ∀ x. String -> x -> Prop
          unsafeProp k v = Prop { key: k, value: toForeign v }

-- If the Glyph is wrapped in an F, and there is an error,
-- the error is propagated to the browser and the user is informed
writeGlyph :: ∀ a c r. Maybe (Feature c r) -> F (Glyph a) -> Foreign
writeGlyph f fG = case runExcept fG of
  Left errors -> toForeign $ fold $ renderForeignError <$> errors
  Right glyph -> writeGlyph' f glyph

module Genetics.Browser.GlyphF.Interpret
       ( writeGlyph )
       where

import Prelude

import Control.Monad.Eff.Unsafe (unsafePerformEff)
import Control.Monad.Except (runExcept)
import Data.Either (Either(..))
import Data.Foldable (fold)
import Data.Foreign (F, Foreign, Prop(..), renderForeignError, toForeign, writeObject)
import Data.Foreign.Null (writeNull)
import Data.Maybe (Maybe, fromMaybe)
import Data.Newtype (unwrap)
import Genetics.Browser.Feature (Feature)
import Genetics.Browser.Glyph (Glyph)
import Genetics.Browser.GlyphF.Canvas as Canvas
import Genetics.Browser.GlyphF.Position (glyphToGlyphPosition)
import Genetics.Browser.GlyphF.SVG as SVG

writeGlyph' :: ∀ a r. Maybe (Feature r) -> Glyph a -> Foreign
writeGlyph' f g = writeObject [ unsafeProp "draw" $ unsafePerformEff <<< \ctx -> Canvas.renderGlyph ctx g
                             , unsafeProp "min" $ const p.min
                             , unsafeProp "max" $ const p.max
                             , unsafeProp "minY" $ const p.minY
                             , unsafeProp "maxY" $ const p.maxY
                             , unsafeProp "feature" f'
                             , unsafeProp "toSVG" $ unsafePerformEff <<< \_ -> SVG.renderGlyph g
                             ]
    where p = unwrap $ glyphToGlyphPosition g
          f' = fromMaybe writeNull (toForeign <$> f)
          unsafeProp :: ∀ x. String -> x -> Prop
          unsafeProp k v = Prop { key: k, value: toForeign v }

-- If the Glyph is wrapped in an F, and there is an error,
-- the error is propagated to the browser and the user is informed
writeGlyph :: ∀ a r. Maybe (Feature r) -> F (Glyph a) -> Foreign
writeGlyph f fG = case runExcept fG of
  Left errors -> toForeign $ fold $ renderForeignError <$> errors
  Right glyph -> writeGlyph' f glyph


Added TODO note

Added TODO note

module Parser where

import Prelude
import Data.String as String
import Data.Foldable (foldl)
import Data.List (List(..), many, concat, elemIndex, length)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple (Tuple(..), fst)
import Data.Tuple.Nested (Tuple3, uncurry3, tuple3)
import Data.Array (modifyAt, snoc)
import Data.Array (fromFoldable, toUnfoldable) as Array
import Data.Either (Either)

import Control.Alt ((<|>))
import Control.Apply (lift2)
-- import Control.Applicative ((<*), (*>))
import Control.Lazy (fix)
import Control.Monad.State (runState)

import Text.Parsing.Parser (ParseError, ParserT, runParserT, fail)
import Text.Parsing.Parser.Combinators as PC
import Text.Parsing.Parser.Expr (OperatorTable, Assoc(AssocRight, AssocNone, AssocLeft), Operator(Infix, Prefix), buildExprParser)
import Text.Parsing.Parser.String (whiteSpace, char, string, oneOf, noneOf)
import Text.Parsing.Parser.Token (unGenLanguageDef, upper, digit)
import Text.Parsing.Parser.Language (haskellDef)
import Text.Parsing.Parser.Pos (initialPos)

import AST
  ( MType
  , Tree(..)
  , Atom(..)
  , Binding(..)
  , Definition(Def)
  , Op(..)
  , QualTree(..)
  , TypeQual
  , TypeTree
  , toOpTuple
  , ADTDef(..)
  , Associativity(..)
  , DataCons(..)
  , Type(..)
  , AD(..))
import IndentParser (IndentParser, block, withPos, block1, indented', sameLine)

---------------------------------------------------------
-- Utils
---------------------------------------------------------

type FixedIndentParser s a = IndentParser s a -> IndentParser s a

---------------------------------------------------------
-- Helpful combinators
---------------------------------------------------------

-- | @ many1 @ should prabably be inside Text.Parsing.Parser.Combinators
many1 :: forall s m a. (Monad m) => ParserT s m a -> ParserT s m (List a)
many1 p = lift2 Cons p (many p)

--skips whitespaces
skipSpaces :: forall m. (Monad m) => ParserT String m Unit
skipSpaces = void $ many $ oneOf [' ', '\t']

--skips whitespaces and linebreaks
skipWhite :: forall m. (Monad m) => ParserT String m Unit
skipWhite = void $ many $ oneOf ['\n', '\r', '\f', ' ', '\t']

--lexeme parser (skips trailing whitespaces and linebreaks)
ilexe :: forall a m. (Monad m) => ParserT String m a -> ParserT String m a
ilexe p = p >>= \a -> skipWhite *> pure a

-- parses <p> if it is on the same line or indented, does NOT change indentation state
indent :: forall a. IndentParser String a -> IndentParser String a
indent p = ((sameLine <|> indented') PC.<?> "Missing indentation! Did you type a tab-character?") *> ilexe p

---------------------------------------------------------
-- Parsers for Primitives
---------------------------------------------------------

symbol :: forall m. (Monad m) => ParserT String m Char
symbol = oneOf
  [':','!','#','$','%','&','*'
  ,'+','.','/','<','>','=','?'
  ,'@','\\','^','|','-','~','_'
  ,'°']

integer :: forall m. (Monad m) => ParserT String m Int
integer = convert <$> many1 digit
  where
    convert :: List Char -> Int
    convert = foldl (\acc x -> acc * 10 + table x) 0

    table '0' = 0
    table '1' = 1
    table '2' = 2
    table '3' = 3
    table '4' = 4
    table '5' = 5
    table '6' = 6
    table '7' = 7
    table '8' = 8
    table '9' = 9
    table _   = 47

boolean :: forall m. (Monad m) => ParserT String m Boolean
boolean = string "True"  *> pure true
      <|> string "False" *> pure false

charLiteral :: forall m. (Monad m) => ParserT String m Char
charLiteral = do
  char '\''
  c <- character'
  char '\''
  pure c

-- | Parser for characters at the start of variables
lower :: forall m. (Monad m) => ParserT String m Char
lower = oneOf $ String.toCharArray "abcdefghijklmnopqrstuvwxyz"

-- | Parser for all characters after the first in names
anyLetter :: forall m. (Monad m) => ParserT String m Char
anyLetter = char '_' <|> lower <|> upper <|> char '\'' <|> digit

character' :: forall m. (Monad m) => ParserT String m Char
character' =
      (char '\\' *>
        (    (char 'n' *> pure '\n')
         <|> (char 'r' *> pure '\r')
         <|> char '\\'
         <|> char '"'
         <|> char '\''))
  <|> (noneOf ['\\', '\'', '"'])

-- | Parser for variables names
name :: forall m. (Monad m) => ParserT String m String
name = do
  c  <- char '_' <|> lower
  cs <- many anyLetter
  let nm = String.fromCharArray $ Array.fromFoldable $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> pure nm
    Just _  -> fail $ nm <> " is a reserved word!"
  where
    -- | List of reserved key words
    reservedWords :: List String
    reservedWords = Array.toUnfoldable $ (unGenLanguageDef haskellDef).reservedNames

-- | Parser for type names
typeName :: forall m. (Monad m) => ParserT String m String
typeName = do
  c  <- upper
  cs <- many anyLetter
  let nm = String.fromCharArray $ Array.fromFoldable $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> pure nm
    Just _  -> fail $ nm <> " is a reserved word!"
  where
    -- | List of reserved key words
    reservedWords :: List String
    reservedWords = Array.toUnfoldable $ (unGenLanguageDef haskellDef).reservedNames

---------------------------------------------------------
-- Parsers for Atoms
---------------------------------------------------------

-- | Parser for Int. (0 to 2^31-1)
int :: forall m. (Monad m) => ParserT String m Atom
int = AInt <$> integer

-- | Parser for Boolean
bool :: forall m. (Monad m) => ParserT String m Atom
bool = Bool <$> boolean

-- | Parser for Char
character :: forall m. (Monad m) => ParserT String m Atom
character = (Char <<< String.singleton) <$> charLiteral

-- | Parser for variable atoms
variable :: forall m. (Monad m) => ParserT String m Atom
variable = Name <$> name

-- | Parser for atoms
atom :: forall m. (Monad m) => ParserT String m Atom
atom = int <|> variable <|> bool <|> character

---------------------------------------------------------
-- Parsers for Expressions
---------------------------------------------------------

-- | Table for operator parsers and their AST representation. Sorted by precedence.
infixOperators :: forall m. (Monad m) => Array (Array (Tuple3 (ParserT String m String) Op Assoc))
infixOperators =
  [ [ (tuple3 (PC.try $ string "." <* PC.notFollowedBy (char '.')) Composition AssocRight) ]
  , [ (tuple3 (string "^") Power AssocRight) ]
  , [ (tuple3 (string "*") Mul AssocLeft) ]
  , [ (tuple3 (PC.try $ string "+" <* PC.notFollowedBy (char '+')) Add AssocLeft)
    , (tuple3 (string "-") Sub AssocLeft)
    ]
  , [ (tuple3 (string ":") Colon AssocRight)
    , (tuple3 (string "++") Append AssocRight)
    ]
  , [ (tuple3 (string "==") Equ AssocNone)
    , (tuple3 (string "/=") Neq AssocNone)
    , (tuple3 (PC.try $ string "<" <* PC.notFollowedBy (char '=')) Lt AssocNone)
    , (tuple3 (PC.try $ string ">" <* PC.notFollowedBy (char '=')) Gt AssocNone)
    , (tuple3 (string "<=") Leq AssocNone)
    , (tuple3 (string ">=") Geq AssocNone)
    ]
  , [ (tuple3 (string "&&") And AssocRight) ]
  , [ (tuple3 (string "||") Or AssocRight) ]
  , [ (tuple3 (string "$") Dollar AssocRight) ]
  ]

-- | Table of operators (math, boolean, ...)
operatorTable :: forall m. (Monad m) => OperatorTable m String TypeTree
operatorTable = infixTable2
  where
    infixTable2 = maybe [] id (modifyAt 2 (flip snoc infixOperator) infixTable1)
    infixTable1 = maybe [] id (modifyAt 3 (flip snoc unaryMinus) infixTable)

    infixTable :: OperatorTable m String TypeTree
    infixTable = (\x -> (uncurry3 (\p op assoc -> Infix (spaced p *> pure (Binary Nothing (toOpTuple op))) assoc)) <$> x) <$> infixOperators

    unaryMinus :: Operator m String TypeTree
    unaryMinus = Prefix $ spaced minusParse
      where
        minusParse = do
          string "-"
          pure $ \e -> case e of
            Atom _ (AInt ai) -> (Atom Nothing (AInt (-ai)))
            _                -> Unary Nothing (toOpTuple Sub) e

    infixOperator :: Operator m String TypeTree
    infixOperator = Infix (spaced infixParse) AssocLeft
      where
        infixParse = do
          char '`'
          n <- name
          char '`'
          pure $ \e1 e2 -> Binary Nothing (toOpTuple $ InfixFunc n) e1 e2

    -- | Parse an expression between spaces (backtracks)
    spaced :: forall a. ParserT String m a -> ParserT String m a
    spaced p = PC.try $ PC.between skipSpaces skipSpaces p

opParser :: forall m. (Monad m) => ParserT String m Op
opParser = (PC.choice $ (\x -> (uncurry3 (\p op _ -> p *> pure op)) <$> x) $ concat $ (\x -> Array.toUnfoldable <$> x) $ Array.toUnfoldable infixOperators) <|> infixFunc
  where
    infixFunc = do
      char '`'
      n <- name
      char '`'
      pure $ InfixFunc n

-- | Parse a base expression (atoms) or an arbitrary expression inside brackets
base :: IndentParser String TypeTree -> IndentParser String TypeTree
base expr =
      PC.try (tuplesOrBrackets expr)
  <|> PC.try (lambda expr)
  <|> section expr
  <|> PC.try (listComp expr)
  <|> PC.try (arithmeticSequence expr)
  <|> list expr
  <|> charList
  <|> (Atom Nothing <$> atom)

-- | Parse syntax constructs like if_then_else, lambdas or function application
syntax :: IndentParser String TypeTree -> IndentParser String TypeTree
syntax expr =
      PC.try (ifThenElse expr)
  <|> PC.try (letExpr expr)
  <|> applicationOrSingleExpression expr

-- | Parser for function application or single expressions
applicationOrSingleExpression :: IndentParser String TypeTree -> IndentParser String TypeTree
applicationOrSingleExpression expr = do
  e     <- ilexe $ base expr
  mArgs <- PC.optionMaybe (PC.try $ ((PC.try (indent (base expr))) `PC.sepEndBy1` skipWhite))
  case mArgs of
    Nothing   -> pure e
    Just args -> pure $ App Nothing e args

-- | Parse an if_then_else construct - layout sensitive
ifThenElse :: IndentParser String TypeTree -> IndentParser String TypeTree
ifThenElse expr = do
  ilexe $ string "if" *> PC.lookAhead (oneOf [' ', '\t', '\n', '('])
  testExpr <- indent expr
  indent $ string "then"
  thenExpr <- indent expr
  indent $ string "else"
  elseExpr <- indent expr
  pure $ IfExpr Nothing testExpr thenExpr elseExpr

-- | Parser for tuples or bracketed expressions - layout sensitive
tuplesOrBrackets :: IndentParser String TypeTree -> IndentParser String TypeTree
tuplesOrBrackets expr = do
  ilexe $ char '('
  e <- indent expr
  mes <- PC.optionMaybe $ PC.try $ do
    indent $ char ','
    (indent expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  case mes of
    Nothing -> pure e
    Just es -> pure $ NTuple Nothing (Cons e es)

-- | Parser for operator sections - layout sensitive
section :: IndentParser String TypeTree -> IndentParser String TypeTree
section expr = do
  ilexe $ char '('
  me1 <- PC.optionMaybe (indent $ syntax expr)
  op <- toOpTuple <$> opParser
  skipWhite
  me2 <- PC.optionMaybe (indent $ syntax expr)
  indent $ char ')'
  case me1 of
    Nothing ->
      case me2 of
        Nothing -> pure $ PrefixOp Nothing op
        Just e2 -> pure $ SectR Nothing op e2
    Just e1 ->
      case me2 of
        Nothing -> pure $ SectL Nothing e1 op
        Just _ -> fail "Cannot have a section with two expressions!"

-- | Parser for lists - layout sensitive
list :: IndentParser String TypeTree -> IndentParser String TypeTree
list expr = do
  ilexe $ char '['
  exprs <- (indent expr) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ List Nothing exprs

-- | Parser for Arithmetic Sequences - layout sensitive
arithmeticSequence :: IndentParser String TypeTree -> IndentParser String TypeTree
arithmeticSequence expr = do
  ilexe $ char '['
  start <- indent expr
  step  <- PC.optionMaybe $ (indent $ char ',') *> (indent expr)
  indent $ string ".."
  end   <- PC.optionMaybe $ indent expr
  indent $ char ']'
  pure $ ArithmSeq Nothing start step end

-- | Parser for list comprehensions - layout sensitive
listComp :: IndentParser String TypeTree -> IndentParser String TypeTree
listComp expr = do
  ilexe $ char '['
  start <- indent expr
  PC.try $ (char '|') *> PC.notFollowedBy (char '|')
  skipWhite
  quals <- (indent $ qual expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ ListComp Nothing start quals
  where
    -- | Parser for list comprehension qualifiers
    qual :: IndentParser String TypeTree -> IndentParser String TypeQual
    qual expr = (PC.try parseLet) <|> (PC.try parseGen) <|> parseGuard
      where
        parseLet = do
          ilexe $ string "let"
          b <- indent binding
          indent $ char '='
          e <- indent expr
          pure $ Let Nothing b e
        parseGen = do
          b <- ilexe binding
          indent $ string "<-"
          e <- indent expr
          pure $ Gen Nothing b e
        parseGuard = ilexe expr >>= (pure <<< Guard Nothing)

-- | Parser for strings ("example")
charList :: forall m. (Monad m) => ParserT String m TypeTree
charList = do
  char '"'
  strs <- many character'
  char '"'
  pure (List Nothing ((Atom Nothing <<< Char <<< String.singleton) <$> strs))

-- | Parse a lambda expression - layout sensitive
lambda :: IndentParser String TypeTree -> IndentParser String TypeTree
lambda expr = do
  ilexe $ char '\\'
  binds <- many1 $ indent binding
  indent $ string "->"
  body <- indent expr
  pure $ Lambda Nothing binds body

-- Parser for let expressions - layout sensitive
letExpr :: IndentParser String TypeTree -> IndentParser String TypeTree
letExpr expr = do
  ilexe $ string "let"
  binds <- indent $ bindingBlock expr
  indent $ string "in"
  body  <- indent $ withPos expr
  pure $ LetExpr Nothing binds body
  where
    bindingItem :: IndentParser String TypeTree -> IndentParser String (Tuple (Binding MType) TypeTree)
    bindingItem expr = do
      b <- ilexe binding
      indent $ char '='
      e <- indent $ withPos expr
      pure $ Tuple b e

    bindingBlock :: IndentParser String TypeTree -> IndentParser String (List (Tuple (Binding MType) TypeTree))
    bindingBlock expr = curly <|> (PC.try layout) <|> (PC.try iblock)
      where
        curly  = PC.between (ilexe $ char '{') (ilexe $ char '}') iblock
        iblock = (bindingItem expr) `PC.sepBy1` (ilexe $ char ';')
        layout = block1 (PC.try $ bindingItem expr >>= \x -> PC.notFollowedBy (ilexe $ char ';') *> pure x)

-- | Parse an arbitrary expression
expression :: IndentParser String TypeTree
expression = do
  whiteSpace
  fix $ \expr -> buildExprParser operatorTable (syntax expr)

runParserIndent :: forall a. IndentParser String a -> String -> Either ParseError a
runParserIndent p src = fst $ flip runState initialPos $ runParserT src p

parseExpr :: String -> Either ParseError TypeTree
parseExpr = runParserIndent expression

---------------------------------------------------------
-- Parsers for Bindings
---------------------------------------------------------

lit :: forall m. (Monad m) => ParserT String m (Binding MType)
lit = Lit Nothing <$> atom

consLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
consLit bnd = do
  ilexe $ char '('
  b <- indent consLit'
  indent $ char ')'
  pure b
  where
    consLit' :: IndentParser String (Binding MType)
    consLit' = do
      b <- ilexe $ bnd
      indent $ char ':'
      bs <- (PC.try $ indent consLit') <|> (indent bnd)
      pure $ ConsLit Nothing b bs

listLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
listLit bnd = do
  ilexe $ char '['
  bs <- (indent bnd) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ ListLit Nothing bs

tupleLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
tupleLit bnd = do
  ilexe $ char '('
  b <- indent bnd
  indent $ char ','
  bs <- (indent bnd) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  pure $ NTupleLit Nothing (Cons b bs)

constrLit :: FixedIndentParser String (Binding MType)
constrLit bnd = PC.try (prefConstrLit bnd) <|> (infConstrLit bnd)

nullary :: IndentParser String (Binding MType)
nullary = do
  n <- indent typeName
  pure $ ConstrLit Nothing (PrefixCons n 0 Nil)

prefConstrLit :: FixedIndentParser String (Binding MType)
prefConstrLit bnd = do
  ilexe $ char '('
  n <- indent typeName
  as   <- many (indent bnd)
  ilexe $ char ')'
  pure $ ConstrLit Nothing (PrefixCons n (length as) as)

infConstrLit :: FixedIndentParser String (Binding MType)
infConstrLit bnd = do
  ilexe $ char '('
  l <- indent bnd
  o <- indent infixConstructor
  r <- indent bnd
  ilexe $ char ')'
  pure $ ConstrLit Nothing (InfixCons o LEFTASSOC 9 l r)

-- TODO:
-- There is no support for patterns like
--  (Foo 1 2, Bar 3 4)
-- yet; for now, the constructors must be written in parantheses like
--  ((Foo 1 2), (Bar 3 4))
----
-- FIX THIS!

binding :: IndentParser String (Binding MType)
binding = fix $ \bnd ->
      (PC.try $ consLit bnd)
  <|> (PC.try $ constrLit bnd)
  <|> (tupleLit bnd)
  <|> (listLit bnd)
  <|> lit
  <|> nullary

---------------------------------------------------------
-- Parsers for Definitions
---------------------------------------------------------

definition :: IndentParser String Definition
definition = do
  defName <- ilexe name
  binds   <- many $ indent binding
  indent $ char '='
  body    <- indent expression
  pure $ Def defName binds body

definitions :: IndentParser String (List Definition)
definitions = skipWhite *> block definition

parseDefs :: String -> Either ParseError (List Definition)
parseDefs = runParserIndent $ definitions

---------------------------------------------------------
-- Parsers for Types
---------------------------------------------------------
{-
  <TYPE>    --> <TYPE1> [ `->` <TYPE> ]
  <TYPE1>   --> <SIMPLE>
              | <TYPEVAR>
              | `[` <TYPE> `]`
              | <CONS> { <TYPE> }
              | `(` <TYPE> `)`
              | `(` <TYPE> { `,` <TYPE> } `)`
  <SIMPLE>  --> `Int` | `Bool` | `Char`
-}

simpleType :: IndentParser String Type
simpleType =
  TypCon <$> (string "Bool"
             <|> string "Int"
             <|> string "Char")
  <|> TypVar <$> name

typeCons :: IndentParser String Type -> IndentParser String Type
typeCons t = do
  n <- ilexe typeName
  ps <- many (indent $ typeExpr t <|> simpleType)
  pure $ AD $ TTypeCons n ps

typeExpr :: IndentParser String Type -> IndentParser String Type
typeExpr t = PC.between
  (indent (char '('))
  (indent (char ')'))
  (indent t)

types :: IndentParser String Type
types = do
  whiteSpace
  fix $ \t -> PC.chainr1
    (indent (types1 t))
    (indent (string "->") *> pure TypArr)

typeTuple :: IndentParser String Type -> IndentParser String Type
typeTuple t = PC.between
  (ilexe (char '('))
  (PC.try $ indent (char ')'))
  (do ts <- PC.sepBy1 (indent t) (PC.try (indent (char ',')))
      when (length ts <= 1) (fail "Tuple to short.")
      pure (AD (TTuple ts)))

types1 :: IndentParser String Type -> IndentParser String Type
types1 t =
  PC.try simpleType
  <|> AD <<< TList <$> (ilexe (char '[') *> indent t <* indent (char ']'))
  <|> typeCons t
  <|> PC.try (typeExpr t)
  <|> typeTuple t

---------------------------------------------------------
-- Parsers for Type Definitions
---------------------------------------------------------

typeDefinition :: IndentParser String ADTDef
typeDefinition = do
  ilexe $ string "data"
  n <- indent typeName
  tvs <- many $ indent name
  conss <- (do PC.try (indent $ char '=')
               indent dataConstructorDefinition `PC.sepBy` (PC.try $ indent $ char '|'))
           <|> pure Nil
  pure $ ADTDef n tvs conss

dataConstructorDefinition :: IndentParser String (DataCons Type)
dataConstructorDefinition
  = PC.try prefixDataConstructorDefinition
  <|> infixDataConstructorDefinition

prefixDataConstructorDefinition :: IndentParser String (DataCons Type)
prefixDataConstructorDefinition = do
  n <- ilexe typeName
  ps <- many types
  pure $ PrefixCons n (length ps) ps

infixDataConstructorDefinition :: IndentParser String (DataCons Type)
infixDataConstructorDefinition = do
  l <- ilexe types
  o <- indent $ ilexe infixConstructor
  r <- indent $ ilexe types
  pure $ InfixCons o LEFTASSOC 9 l r

infixConstructor :: forall m. (Monad m) => ParserT String m String
infixConstructor = do
  char ':'
  syms <- many symbol
  pure $ String.fromCharArray $ Array.fromFoldable $ Cons ':' syms

module Parser where

import Prelude
import Data.String as String
import Data.Foldable (foldl)
import Data.List (List(..), many, concat, elemIndex, length)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple (Tuple(..), fst)
import Data.Tuple.Nested (Tuple3, uncurry3, tuple3)
import Data.Array (modifyAt, snoc)
import Data.Array (fromFoldable, toUnfoldable) as Array
import Data.Either (Either)

import Control.Alt ((<|>))
import Control.Apply (lift2)
-- import Control.Applicative ((<*), (*>))
import Control.Lazy (fix)
import Control.Monad.State (runState)

import Text.Parsing.Parser (ParseError, ParserT, runParserT, fail)
import Text.Parsing.Parser.Combinators as PC
import Text.Parsing.Parser.Expr (OperatorTable, Assoc(AssocRight, AssocNone, AssocLeft), Operator(Infix, Prefix), buildExprParser)
import Text.Parsing.Parser.String (whiteSpace, char, string, oneOf, noneOf)
import Text.Parsing.Parser.Token (unGenLanguageDef, upper, digit)
import Text.Parsing.Parser.Language (haskellDef)
import Text.Parsing.Parser.Pos (initialPos)

import AST
  ( MType
  , Tree(..)
  , Atom(..)
  , Binding(..)
  , Definition(Def)
  , Op(..)
  , QualTree(..)
  , TypeQual
  , TypeTree
  , toOpTuple
  , ADTDef(..)
  , Associativity(..)
  , DataCons(..)
  , Type(..)
  , AD(..))
import IndentParser (IndentParser, block, withPos, block1, indented', sameLine)

---------------------------------------------------------
-- Utils
---------------------------------------------------------

type FixedIndentParser s a = IndentParser s a -> IndentParser s a

---------------------------------------------------------
-- Helpful combinators
---------------------------------------------------------

-- | @ many1 @ should prabably be inside Text.Parsing.Parser.Combinators
many1 :: forall s m a. (Monad m) => ParserT s m a -> ParserT s m (List a)
many1 p = lift2 Cons p (many p)

--skips whitespaces
skipSpaces :: forall m. (Monad m) => ParserT String m Unit
skipSpaces = void $ many $ oneOf [' ', '\t']

--skips whitespaces and linebreaks
skipWhite :: forall m. (Monad m) => ParserT String m Unit
skipWhite = void $ many $ oneOf ['\n', '\r', '\f', ' ', '\t']

--lexeme parser (skips trailing whitespaces and linebreaks)
ilexe :: forall a m. (Monad m) => ParserT String m a -> ParserT String m a
ilexe p = p >>= \a -> skipWhite *> pure a

-- parses <p> if it is on the same line or indented, does NOT change indentation state
indent :: forall a. IndentParser String a -> IndentParser String a
indent p = ((sameLine <|> indented') PC.<?> "Missing indentation! Did you type a tab-character?") *> ilexe p

---------------------------------------------------------
-- Parsers for Primitives
---------------------------------------------------------

symbol :: forall m. (Monad m) => ParserT String m Char
symbol = oneOf
  [':','!','#','$','%','&','*'
  ,'+','.','/','<','>','=','?'
  ,'@','\\','^','|','-','~','_'
  ,'°']

integer :: forall m. (Monad m) => ParserT String m Int
integer = convert <$> many1 digit
  where
    convert :: List Char -> Int
    convert = foldl (\acc x -> acc * 10 + table x) 0

    table '0' = 0
    table '1' = 1
    table '2' = 2
    table '3' = 3
    table '4' = 4
    table '5' = 5
    table '6' = 6
    table '7' = 7
    table '8' = 8
    table '9' = 9
    table _   = 47

boolean :: forall m. (Monad m) => ParserT String m Boolean
boolean = string "True"  *> pure true
      <|> string "False" *> pure false

charLiteral :: forall m. (Monad m) => ParserT String m Char
charLiteral = do
  char '\''
  c <- character'
  char '\''
  pure c

-- | Parser for characters at the start of variables
lower :: forall m. (Monad m) => ParserT String m Char
lower = oneOf $ String.toCharArray "abcdefghijklmnopqrstuvwxyz"

-- | Parser for all characters after the first in names
anyLetter :: forall m. (Monad m) => ParserT String m Char
anyLetter = char '_' <|> lower <|> upper <|> char '\'' <|> digit

character' :: forall m. (Monad m) => ParserT String m Char
character' =
      (char '\\' *>
        (    (char 'n' *> pure '\n')
         <|> (char 'r' *> pure '\r')
         <|> char '\\'
         <|> char '"'
         <|> char '\''))
  <|> (noneOf ['\\', '\'', '"'])

-- | Parser for variables names
name :: forall m. (Monad m) => ParserT String m String
name = do
  c  <- char '_' <|> lower
  cs <- many anyLetter
  let nm = String.fromCharArray $ Array.fromFoldable $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> pure nm
    Just _  -> fail $ nm <> " is a reserved word!"
  where
    -- | List of reserved key words
    reservedWords :: List String
    reservedWords = Array.toUnfoldable $ (unGenLanguageDef haskellDef).reservedNames

-- | Parser for type names
typeName :: forall m. (Monad m) => ParserT String m String
typeName = do
  c  <- upper
  cs <- many anyLetter
  let nm = String.fromCharArray $ Array.fromFoldable $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> pure nm
    Just _  -> fail $ nm <> " is a reserved word!"
  where
    -- | List of reserved key words
    reservedWords :: List String
    reservedWords = Array.toUnfoldable $ (unGenLanguageDef haskellDef).reservedNames

---------------------------------------------------------
-- Parsers for Atoms
---------------------------------------------------------

-- | Parser for Int. (0 to 2^31-1)
int :: forall m. (Monad m) => ParserT String m Atom
int = AInt <$> integer

-- | Parser for Boolean
bool :: forall m. (Monad m) => ParserT String m Atom
bool = Bool <$> boolean

-- | Parser for Char
character :: forall m. (Monad m) => ParserT String m Atom
character = (Char <<< String.singleton) <$> charLiteral

-- | Parser for variable atoms
variable :: forall m. (Monad m) => ParserT String m Atom
variable = Name <$> name

-- | Parser for atoms
atom :: forall m. (Monad m) => ParserT String m Atom
atom = int <|> variable <|> bool <|> character

---------------------------------------------------------
-- Parsers for Expressions
---------------------------------------------------------

-- | Table for operator parsers and their AST representation. Sorted by precedence.
infixOperators :: forall m. (Monad m) => Array (Array (Tuple3 (ParserT String m String) Op Assoc))
infixOperators =
  [ [ (tuple3 (PC.try $ string "." <* PC.notFollowedBy (char '.')) Composition AssocRight) ]
  , [ (tuple3 (string "^") Power AssocRight) ]
  , [ (tuple3 (string "*") Mul AssocLeft) ]
  , [ (tuple3 (PC.try $ string "+" <* PC.notFollowedBy (char '+')) Add AssocLeft)
    , (tuple3 (string "-") Sub AssocLeft)
    ]
  , [ (tuple3 (string ":") Colon AssocRight)
    , (tuple3 (string "++") Append AssocRight)
    ]
  , [ (tuple3 (string "==") Equ AssocNone)
    , (tuple3 (string "/=") Neq AssocNone)
    , (tuple3 (PC.try $ string "<" <* PC.notFollowedBy (char '=')) Lt AssocNone)
    , (tuple3 (PC.try $ string ">" <* PC.notFollowedBy (char '=')) Gt AssocNone)
    , (tuple3 (string "<=") Leq AssocNone)
    , (tuple3 (string ">=") Geq AssocNone)
    ]
  , [ (tuple3 (string "&&") And AssocRight) ]
  , [ (tuple3 (string "||") Or AssocRight) ]
  , [ (tuple3 (string "$") Dollar AssocRight) ]
  ]

-- | Table of operators (math, boolean, ...)
operatorTable :: forall m. (Monad m) => OperatorTable m String TypeTree
operatorTable = infixTable2
  where
    infixTable2 = maybe [] id (modifyAt 2 (flip snoc infixOperator) infixTable1)
    infixTable1 = maybe [] id (modifyAt 3 (flip snoc unaryMinus) infixTable)

    infixTable :: OperatorTable m String TypeTree
    infixTable = (\x -> (uncurry3 (\p op assoc -> Infix (spaced p *> pure (Binary Nothing (toOpTuple op))) assoc)) <$> x) <$> infixOperators

    unaryMinus :: Operator m String TypeTree
    unaryMinus = Prefix $ spaced minusParse
      where
        minusParse = do
          string "-"
          pure $ \e -> case e of
            Atom _ (AInt ai) -> (Atom Nothing (AInt (-ai)))
            _                -> Unary Nothing (toOpTuple Sub) e

    infixOperator :: Operator m String TypeTree
    infixOperator = Infix (spaced infixParse) AssocLeft
      where
        infixParse = do
          char '`'
          n <- name
          char '`'
          pure $ \e1 e2 -> Binary Nothing (toOpTuple $ InfixFunc n) e1 e2

    -- | Parse an expression between spaces (backtracks)
    spaced :: forall a. ParserT String m a -> ParserT String m a
    spaced p = PC.try $ PC.between skipSpaces skipSpaces p

opParser :: forall m. (Monad m) => ParserT String m Op
opParser = (PC.choice $ (\x -> (uncurry3 (\p op _ -> p *> pure op)) <$> x) $ concat $ (\x -> Array.toUnfoldable <$> x) $ Array.toUnfoldable infixOperators) <|> infixFunc
  where
    infixFunc = do
      char '`'
      n <- name
      char '`'
      pure $ InfixFunc n

-- | Parse a base expression (atoms) or an arbitrary expression inside brackets
base :: IndentParser String TypeTree -> IndentParser String TypeTree
base expr =
      PC.try (tuplesOrBrackets expr)
  <|> PC.try (lambda expr)
  <|> section expr
  <|> PC.try (listComp expr)
  <|> PC.try (arithmeticSequence expr)
  <|> list expr
  <|> charList
  <|> (Atom Nothing <$> atom)

-- | Parse syntax constructs like if_then_else, lambdas or function application
syntax :: IndentParser String TypeTree -> IndentParser String TypeTree
syntax expr =
      PC.try (ifThenElse expr)
  <|> PC.try (letExpr expr)
  <|> applicationOrSingleExpression expr

-- | Parser for function application or single expressions
applicationOrSingleExpression :: IndentParser String TypeTree -> IndentParser String TypeTree
applicationOrSingleExpression expr = do
  e     <- ilexe $ base expr
  mArgs <- PC.optionMaybe (PC.try $ ((PC.try (indent (base expr))) `PC.sepEndBy1` skipWhite))
  case mArgs of
    Nothing   -> pure e
    Just args -> pure $ App Nothing e args

-- | Parse an if_then_else construct - layout sensitive
ifThenElse :: IndentParser String TypeTree -> IndentParser String TypeTree
ifThenElse expr = do
  ilexe $ string "if" *> PC.lookAhead (oneOf [' ', '\t', '\n', '('])
  testExpr <- indent expr
  indent $ string "then"
  thenExpr <- indent expr
  indent $ string "else"
  elseExpr <- indent expr
  pure $ IfExpr Nothing testExpr thenExpr elseExpr

-- | Parser for tuples or bracketed expressions - layout sensitive
tuplesOrBrackets :: IndentParser String TypeTree -> IndentParser String TypeTree
tuplesOrBrackets expr = do
  ilexe $ char '('
  e <- indent expr
  mes <- PC.optionMaybe $ PC.try $ do
    indent $ char ','
    (indent expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  case mes of
    Nothing -> pure e
    Just es -> pure $ NTuple Nothing (Cons e es)

-- | Parser for operator sections - layout sensitive
section :: IndentParser String TypeTree -> IndentParser String TypeTree
section expr = do
  ilexe $ char '('
  me1 <- PC.optionMaybe (indent $ syntax expr)
  op <- toOpTuple <$> opParser
  skipWhite
  me2 <- PC.optionMaybe (indent $ syntax expr)
  indent $ char ')'
  case me1 of
    Nothing ->
      case me2 of
        Nothing -> pure $ PrefixOp Nothing op
        Just e2 -> pure $ SectR Nothing op e2
    Just e1 ->
      case me2 of
        Nothing -> pure $ SectL Nothing e1 op
        Just _ -> fail "Cannot have a section with two expressions!"

-- | Parser for lists - layout sensitive
list :: IndentParser String TypeTree -> IndentParser String TypeTree
list expr = do
  ilexe $ char '['
  exprs <- (indent expr) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ List Nothing exprs

-- | Parser for Arithmetic Sequences - layout sensitive
arithmeticSequence :: IndentParser String TypeTree -> IndentParser String TypeTree
arithmeticSequence expr = do
  ilexe $ char '['
  start <- indent expr
  step  <- PC.optionMaybe $ (indent $ char ',') *> (indent expr)
  indent $ string ".."
  end   <- PC.optionMaybe $ indent expr
  indent $ char ']'
  pure $ ArithmSeq Nothing start step end

-- | Parser for list comprehensions - layout sensitive
listComp :: IndentParser String TypeTree -> IndentParser String TypeTree
listComp expr = do
  ilexe $ char '['
  start <- indent expr
  PC.try $ (char '|') *> PC.notFollowedBy (char '|')
  skipWhite
  quals <- (indent $ qual expr) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ ListComp Nothing start quals
  where
    -- | Parser for list comprehension qualifiers
    qual :: IndentParser String TypeTree -> IndentParser String TypeQual
    qual expr = (PC.try parseLet) <|> (PC.try parseGen) <|> parseGuard
      where
        parseLet = do
          ilexe $ string "let"
          b <- indent binding
          indent $ char '='
          e <- indent expr
          pure $ Let Nothing b e
        parseGen = do
          b <- ilexe binding
          indent $ string "<-"
          e <- indent expr
          pure $ Gen Nothing b e
        parseGuard = ilexe expr >>= (pure <<< Guard Nothing)

-- | Parser for strings ("example")
charList :: forall m. (Monad m) => ParserT String m TypeTree
charList = do
  char '"'
  strs <- many character'
  char '"'
  pure (List Nothing ((Atom Nothing <<< Char <<< String.singleton) <$> strs))

-- | Parse a lambda expression - layout sensitive
lambda :: IndentParser String TypeTree -> IndentParser String TypeTree
lambda expr = do
  ilexe $ char '\\'
  binds <- many1 $ indent binding
  indent $ string "->"
  body <- indent expr
  pure $ Lambda Nothing binds body

-- Parser for let expressions - layout sensitive
letExpr :: IndentParser String TypeTree -> IndentParser String TypeTree
letExpr expr = do
  ilexe $ string "let"
  binds <- indent $ bindingBlock expr
  indent $ string "in"
  body  <- indent $ withPos expr
  pure $ LetExpr Nothing binds body
  where
    bindingItem :: IndentParser String TypeTree -> IndentParser String (Tuple (Binding MType) TypeTree)
    bindingItem expr = do
      b <- ilexe binding
      indent $ char '='
      e <- indent $ withPos expr
      pure $ Tuple b e

    bindingBlock :: IndentParser String TypeTree -> IndentParser String (List (Tuple (Binding MType) TypeTree))
    bindingBlock expr = curly <|> (PC.try layout) <|> (PC.try iblock)
      where
        curly  = PC.between (ilexe $ char '{') (ilexe $ char '}') iblock
        iblock = (bindingItem expr) `PC.sepBy1` (ilexe $ char ';')
        layout = block1 (PC.try $ bindingItem expr >>= \x -> PC.notFollowedBy (ilexe $ char ';') *> pure x)

-- | Parse an arbitrary expression
expression :: IndentParser String TypeTree
expression = do
  whiteSpace
  fix $ \expr -> buildExprParser operatorTable (syntax expr)

runParserIndent :: forall a. IndentParser String a -> String -> Either ParseError a
runParserIndent p src = fst $ flip runState initialPos $ runParserT src p

parseExpr :: String -> Either ParseError TypeTree
parseExpr = runParserIndent expression

---------------------------------------------------------
-- Parsers for Bindings
---------------------------------------------------------

lit :: forall m. (Monad m) => ParserT String m (Binding MType)
lit = Lit Nothing <$> atom

consLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
consLit bnd = do
  ilexe $ char '('
  b <- indent consLit'
  indent $ char ')'
  pure b
  where
    consLit' :: IndentParser String (Binding MType)
    consLit' = do
      b <- ilexe $ bnd
      indent $ char ':'
      bs <- (PC.try $ indent consLit') <|> (indent bnd)
      pure $ ConsLit Nothing b bs

listLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
listLit bnd = do
  ilexe $ char '['
  bs <- (indent bnd) `PC.sepBy` (PC.try $ indent $ char ',')
  indent $ char ']'
  pure $ ListLit Nothing bs

tupleLit :: IndentParser String (Binding MType) -> IndentParser String (Binding MType)
tupleLit bnd = do
  ilexe $ char '('
  b <- indent bnd
  indent $ char ','
  bs <- (indent bnd) `PC.sepBy1` (PC.try $ indent $ char ',')
  indent $ char ')'
  pure $ NTupleLit Nothing (Cons b bs)

constrLit :: FixedIndentParser String (Binding MType)
constrLit bnd = PC.try (prefConstrLit bnd) <|> (infConstrLit bnd)

nullary :: IndentParser String (Binding MType)
nullary = do
  n <- indent typeName
  pure $ ConstrLit Nothing (PrefixCons n 0 Nil)

prefConstrLit :: FixedIndentParser String (Binding MType)
prefConstrLit bnd = do
  ilexe $ char '('
  n <- indent typeName
  as   <- many (indent bnd)
  ilexe $ char ')'
  pure $ ConstrLit Nothing (PrefixCons n (length as) as)

infConstrLit :: FixedIndentParser String (Binding MType)
infConstrLit bnd = do
  ilexe $ char '('
  l <- indent bnd
  o <- indent infixConstructor
  r <- indent bnd
  ilexe $ char ')'
  pure $ ConstrLit Nothing (InfixCons o LEFTASSOC 9 l r)

binding :: IndentParser String (Binding MType)
binding = fix $ \bnd ->
      (PC.try $ consLit bnd)
  <|> (PC.try $ constrLit bnd)
  <|> (tupleLit bnd)
  <|> (listLit bnd)
  <|> lit
  <|> nullary

---------------------------------------------------------
-- Parsers for Definitions
---------------------------------------------------------

definition :: IndentParser String Definition
definition = do
  defName <- ilexe name
  binds   <- many $ indent binding
  indent $ char '='
  body    <- indent expression
  pure $ Def defName binds body

definitions :: IndentParser String (List Definition)
definitions = skipWhite *> block definition

parseDefs :: String -> Either ParseError (List Definition)
parseDefs = runParserIndent $ definitions

---------------------------------------------------------
-- Parsers for Types
---------------------------------------------------------
{-
  <TYPE>    --> <TYPE1> [ `->` <TYPE> ]
  <TYPE1>   --> <SIMPLE>
              | <TYPEVAR>
              | `[` <TYPE> `]`
              | <CONS> { <TYPE> }
              | `(` <TYPE> `)`
              | `(` <TYPE> { `,` <TYPE> } `)`
  <SIMPLE>  --> `Int` | `Bool` | `Char`
-}

simpleType :: IndentParser String Type
simpleType =
  TypCon <$> (string "Bool"
             <|> string "Int"
             <|> string "Char")
  <|> TypVar <$> name

typeCons :: IndentParser String Type -> IndentParser String Type
typeCons t = do
  n <- ilexe typeName
  ps <- many (indent $ typeExpr t <|> simpleType)
  pure $ AD $ TTypeCons n ps

typeExpr :: IndentParser String Type -> IndentParser String Type
typeExpr t = PC.between
  (indent (char '('))
  (indent (char ')'))
  (indent t)

types :: IndentParser String Type
types = do
  whiteSpace
  fix $ \t -> PC.chainr1
    (indent (types1 t))
    (indent (string "->") *> pure TypArr)

typeTuple :: IndentParser String Type -> IndentParser String Type
typeTuple t = PC.between
  (ilexe (char '('))
  (PC.try $ indent (char ')'))
  (do ts <- PC.sepBy1 (indent t) (PC.try (indent (char ',')))
      when (length ts <= 1) (fail "Tuple to short.")
      pure (AD (TTuple ts)))

types1 :: IndentParser String Type -> IndentParser String Type
types1 t =
  PC.try simpleType
  <|> AD <<< TList <$> (ilexe (char '[') *> indent t <* indent (char ']'))
  <|> typeCons t
  <|> PC.try (typeExpr t)
  <|> typeTuple t

---------------------------------------------------------
-- Parsers for Type Definitions
---------------------------------------------------------

typeDefinition :: IndentParser String ADTDef
typeDefinition = do
  ilexe $ string "data"
  n <- indent typeName
  tvs <- many $ indent name
  conss <- (do PC.try (indent $ char '=')
               indent dataConstructorDefinition `PC.sepBy` (PC.try $ indent $ char '|'))
           <|> pure Nil
  pure $ ADTDef n tvs conss

dataConstructorDefinition :: IndentParser String (DataCons Type)
dataConstructorDefinition
  = PC.try prefixDataConstructorDefinition
  <|> infixDataConstructorDefinition

prefixDataConstructorDefinition :: IndentParser String (DataCons Type)
prefixDataConstructorDefinition = do
  n <- ilexe typeName
  ps <- many types
  pure $ PrefixCons n (length ps) ps

infixDataConstructorDefinition :: IndentParser String (DataCons Type)
infixDataConstructorDefinition = do
  l <- ilexe types
  o <- indent $ ilexe infixConstructor
  r <- indent $ ilexe types
  pure $ InfixCons o LEFTASSOC 9 l r

infixConstructor :: forall m. (Monad m) => ParserT String m String
infixConstructor = do
  char ':'
  syms <- many symbol
  pure $ String.fromCharArray $ Array.fromFoldable $ Cons ':' syms