Fixed bug where back actions were disabled in ActionList (#1362)

* Disable impossible deck flipside actions

* Fixed bug where back actions were disabled in actionlist

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.ActionList.Component
  ( FilterInputDescription(..)
  , comp
  , initialState
  , module SlamData.ActionList.Action
  , module SlamData.ActionList.Component.ActionInternal
  , module SlamData.ActionList.Component.State
  , module SlamData.ActionList.Component.Query
  ) where

import SlamData.Prelude

import CSS as CSS

import Data.Array ((..))
import Data.Array as Array
import Data.Foldable as Foldable
import Data.Int as Int
import Data.Lens ((.~))
import Data.String as String

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

import Math as Math

import SlamData.Monad (Slam)
import SlamData.Render.Common as RC
import SlamData.ActionList.Action (Action(..), ActionDescription(..), ActionHighlighted(..), ActionIconSrc(..), ActionName(..), ActionDisabled(..))
import SlamData.ActionList.Component.ActionInternal (ActionInternal(..), ActionNameLine(..), ActionNameWord(..), ButtonMetrics, Dimensions, Presentation(..))
import SlamData.ActionList.Component.State (State, _actions, _boundingDimensions, _boundingElement, _filterString, _previousActions)
import SlamData.ActionList.Component.Query (Query(..))

import Utils as Utils
import Utils.DOM (DOMRect)
import Utils.DOM as DOMUtils
import Utils.CSS as CSSUtils

newtype FilterInputDescription = FilterInputDescription String

type HTML a = H.ComponentHTML (Query a)
type DSL a = H.ComponentDSL (State a) (Query a) Slam

fontSizePx ∷ Number
fontSizePx =
  12.0

lineHeightPx ∷ Number
lineHeightPx =
  13.0

iconSizeRatio ∷ Number
iconSizeRatio =
  0.3

-- Buttons are rendered with mystery centering and padding.
-- This can cause text to overflow.
buttonPaddingHighEstimate ∷ Number
buttonPaddingHighEstimate =
  0.2

isIconOnly ∷ Presentation → Boolean
isIconOnly =
  case _ of
    IconOnly → true
    _ → false

wordify ∷ ActionName → Array ActionNameWord
wordify (ActionName s) =
  ActionNameWord
    ∘ (\word → { word, widthPx: textWidth word })
    <$> Utils.words s

printActionNameWord ∷ ActionNameWord → String
printActionNameWord (ActionNameWord { word }) =
  word

printActionNameLine ∷ ActionNameLine → String
printActionNameLine (ActionNameLine { line }) =
  line

printActionNameWords ∷ Array ActionNameWord → String
printActionNameWords =
  String.joinWith " " ∘ map printActionNameWord

toActionInternal ∷ ∀ a. Action a → ActionInternal a
toActionInternal =
  case _ of
    Do actionName actionIconSrc actionDescription actionHighlighted actionDisabled a →
      DoInternal
        (wordify actionName)
        actionIconSrc
        actionDescription
        actionHighlighted
        actionDisabled
        a
    Drill actionName actionIconSrc actionDescription xs →
      DrillInternal
        (wordify actionName)
        actionIconSrc
        actionDescription
        (toActionInternal <$> xs)

isDo ∷ ∀ a. ActionInternal a → Boolean
isDo =
  case _ of
    DoInternal _ _ _ _ _ _ →
      true
    _ →
      false

isDrill ∷ ∀ a. ActionInternal a → Boolean
isDrill =
  case _ of
    DrillInternal _ _ _ _ →
      true
    _ →
      false

isHighlighted ∷ ∀ a. ActionInternal a → Boolean
isHighlighted =
  case _ of
    DoInternal _ _ _ (ActionHighlighted highlighted) _ _ →
      highlighted
    DrillInternal _ _ _ actions →
      Foldable.any isHighlighted actions
    GoBackInternal → true

isDisabled ∷ ∀ a. ActionInternal a → Boolean
isDisabled =
  case _ of
    DoInternal _ _ _ _ (ActionDisabled disabled) _ →
      disabled
    DrillInternal _ _ _ actions →
      Foldable.any isDisabled actions
    GoBackInternal → false

searchFilters ∷ ∀ a. ActionInternal a → Array String
searchFilters =
  case _ of
    DoInternal words _ _ _ _ _ →
      [ printActionNameWords words ]
    DrillInternal words _ _ actions →
      [ printActionNameWords words ] ⊕ Array.concat (map searchFilters actions)
    GoBackInternal →
      [ "go back" ]

pluckActionDescription ∷ ∀ a. ActionInternal a → String
pluckActionDescription =
  case _ of
    DoInternal _ _ (ActionDescription s) _ _ _ →
      s
    DrillInternal _ _ (ActionDescription s) _ →
      s
    GoBackInternal →
      "Go back"

pluckActionIconSrc ∷ ∀ a. ActionInternal a → String
pluckActionIconSrc =
  case _ of
    DoInternal _ (ActionIconSrc s) _ _ _ _ →
      s
    DrillInternal _ (ActionIconSrc s) _ _ →
      s
    GoBackInternal →
      "/img/go-back.svg"

actionNameWords ∷ ∀ a. ActionInternal a → Array ActionNameWord
actionNameWords =
  case _ of
    DoInternal xs _ _ _ _ _ →
      xs
    DrillInternal xs _ _ _ →
      xs
    GoBackInternal →
      wordify $ ActionName "Go back"

initialState ∷ ∀ a. Array (Action a) → State a
initialState actions =
  { actions: toActionInternal <$> actions
  , previousActions: [ ]
  , filterString: ""
  , boundingElement: Nothing
  , boundingDimensions: Nothing
  }

comp ∷ ∀ a. Eq a ⇒ FilterInputDescription → H.Component (State a) (Query a) Slam
comp filterInputDescription =
  H.lifecycleComponent
    { render: render filterInputDescription
    , initializer: Just $ H.action CalculateBoundingRect
    , finalizer: Nothing
    , eval
    }

render ∷ ∀ a. FilterInputDescription → State a → HTML a
render (FilterInputDescription filterInputDescription) state =
  HH.div
    [ HP.class_ $ HH.className "sd-action-list" ]
    [ HH.form_
        [ HH.div_
            [ HH.div
                [ HP.class_ (HH.className "sd-action-filter-icon") ]
                [ RC.searchFieldIcon ]
            , HH.input
                [ HP.value state.filterString
                , HE.onValueInput (HE.input (\s → UpdateFilter s))
                , ARIA.label filterInputDescription
                , HP.placeholder filterInputDescription
                ]
            , HH.button
                [ HP.buttonType HP.ButtonButton
                , HE.onClick (HE.input_ (UpdateFilter ""))
                , HP.enabled (state.filterString /= "")
                ]
                [ RC.clearFieldIcon "Clear filter" ]
            ]
        ]
    , HH.ul
        [ HP.ref $ H.action ∘ SetBoundingElement ]
        (maybe
           []
           (renderButtons (String.toLower state.filterString) state.actions)
           (actionSize
              (Array.length state.actions)
              =<< state.boundingDimensions))
    ]
  where
  actionSize
    ∷ Int
    → Dimensions
    → Maybe { dimensions ∷ Dimensions, leavesASpace ∷ Boolean }
  actionSize i boundingDimensions = do
    firstTry ← mostSquareFittingRectangle i boundingDimensions
    if firstTry.height ≡ boundingDimensions.height
      then do
        secondTry ← mostSquareFittingRectangle (i + 1) boundingDimensions
        if secondTry.height ≡ boundingDimensions.height
           then pure { dimensions: firstTry, leavesASpace: false }
           else pure { dimensions: secondTry, leavesASpace: true }
        else pure { dimensions: firstTry, leavesASpace: false }

renderButtons
  ∷ ∀ a
  . String
  → Array (ActionInternal a)
  → { dimensions ∷ Dimensions, leavesASpace ∷ Boolean }
  → Array (HTML a)
renderButtons filterString actions buttonDimensions =
  if buttonDimensions.leavesASpace
    then realButtons <> [ renderSpaceFillerButton metrics ]
    else realButtons
  where
  realButtons ∷ Array (HTML a)
  realButtons =
    renderButton filterString presentation metrics <$> actionsWithLines

  actionsWithLines ∷ Array { action ∷ ActionInternal a, lines ∷ Array String }
  actionsWithLines =
    toActionWithLines (buttonDimensions.dimensions.width * 0.95) <$> actions

  toActionWithLines
    ∷ Number
    → ActionInternal a
    → { action ∷ ActionInternal a, lines ∷ Array String }
  toActionWithLines widthPx action =
    { action
    , lines: printActionNameLine <$> (calculateLines widthPx $ actionNameWords action)
    }

  iconDimensions ∷ Dimensions
  iconDimensions =
    { width: buttonDimensions.dimensions.width * iconSizeRatio
    , height: buttonDimensions.dimensions.height * iconSizeRatio
    }

  metrics ∷ ButtonMetrics
  metrics =
    { dimensions:
        buttonDimensions.dimensions
    , iconDimensions:
        iconDimensions
    , iconMarginPx:
        buttonDimensions.dimensions.height * 0.05
    , iconOnlyLeftPx:
        (buttonDimensions.dimensions.width / 2.0)
          - (iconDimensions.width / 2.0)
    , iconOnlyTopPx:
        (buttonDimensions.dimensions.height / 2.0)
          - (iconDimensions.height / 2.0) - 1.0
    }

  maxNumberOfLines ∷ Int
  maxNumberOfLines =
    fromMaybe 0 $ Foldable.maximum $ Array.length ∘ _.lines <$> actionsWithLines

  maxTextHeightPx ∷ Number
  maxTextHeightPx =
    Int.toNumber maxNumberOfLines * fontSizePx

  buttonPaddingEstimatePx ∷ Number
  buttonPaddingEstimatePx =
    buttonDimensions.dimensions.height * buttonPaddingHighEstimate

  textDoesNotFitWithIcon ∷ Boolean
  textDoesNotFitWithIcon =
    maxTextHeightPx
      + iconDimensions.height
      + metrics.iconMarginPx
      + buttonPaddingEstimatePx
      > buttonDimensions.dimensions.height

  textDoesNotFitOnItsOwn ∷ Boolean
  textDoesNotFitOnItsOwn =
    maxTextHeightPx > buttonDimensions.dimensions.height
      ∨ buttonDimensions.dimensions.width < 40.0

  -- Allows text which fits vertically but not horizontally.
  -- Styling truncates overflowing lines with ellipses.
  --
  -- E.g. where there is only room for two lines:
  -- "Show Chart" would be presented without an icon as
  --
  -- Sh...
  -- Ch...
  --
  -- But "Build pie chart" would be presented with only an icon.
  --
  -- The reasoning behind this is that presentation should be
  -- unform per action list but that the entire list shouldn't be
  -- reduced to only icons just because "Troubleshoot" would be
  -- truncated to "Troublesh...".
  presentation ∷ Presentation
  presentation =
    if textDoesNotFitOnItsOwn ∨ maxNumberOfLines ≡ 0
      then
        IconOnly
      else
        if textDoesNotFitWithIcon
          then
            TextOnly
          else
            IconAndText

decimalCrop ∷ Int → Number → Number
decimalCrop i n =
  (Math.floor $ n * multiplier) / multiplier
  where
  multiplier = Math.pow 10.0 $ Int.toNumber i

-- Firefox doesn't seem to be able to handle pixel metrics with decimal
-- precisons higher than one. Without applying this function actionlists
-- of certain widths render with empty spaces and overflowing actions.
firefoxify ∷ Number → Number
firefoxify n =
  if Utils.isFirefox
     then decimalCrop 1 n
     else n

renderSpaceFillerButton ∷ ∀ a. ButtonMetrics → HTML a
renderSpaceFillerButton metrics =
  HH.li
    [ HCSS.style
        $ CSS.width (CSS.px $ firefoxify metrics.dimensions.width)
        *> CSS.height (CSS.px $ firefoxify metrics.dimensions.height)
    ]
    [ HH.button
        [ HP.classes
            [ HH.className "sd-button"
            , HH.className "sd-button-warning"
            ]
        , HP.disabled true
        , HP.buttonType HP.ButtonButton
        ]
        []
    ]

renderButton
  ∷ ∀ a
  . String
  → Presentation
  → ButtonMetrics
  → { action ∷ ActionInternal a, lines ∷ Array String }
  → HTML a
renderButton filterString presentation metrics { action, lines } =
  HH.li
    [ HCSS.style
        $ CSS.width (CSS.px $ firefoxify metrics.dimensions.width)
        *> CSS.height (CSS.px $ firefoxify metrics.dimensions.height)
    ]
    [ HH.button
        attrs
        $ case presentation of
            IconOnly →
              [ renderIcon ]
            TextOnly →
              [ renderName ]
            IconAndText →
              [ renderIcon, renderName ]
    ]
  where
  renderIcon ∷ HTML a
  renderIcon =
    HH.img
      [ HP.src $ pluckActionIconSrc action
      , HCSS.style
          $ CSS.width (CSS.px metrics.iconDimensions.width)
          *> CSS.height (CSS.px metrics.iconDimensions.height)
          *> CSS.marginBottom (CSS.px metrics.iconMarginPx)
          -- Stops icon only presentations from being cut off in short wide
          -- buttons.
          *> (if (isIconOnly presentation)
                then
                  CSS.position CSS.absolute
                    *> CSS.left (CSS.px metrics.iconOnlyLeftPx)
                    *> CSS.top (CSS.px metrics.iconOnlyTopPx)
                else
                  CSS.position CSS.relative)
      ]

  renderName ∷ HTML a
  renderName =
    HH.p
      [ HCSS.style
          $ CSS.fontSize (CSS.px $ fontSizePx)
          *> CSSUtils.lineHeight (show lineHeightPx <> "px")
      ]
      $ Array.intercalate
          [ HH.br_ ]
          $ Array.singleton ∘ HH.text <$> lines

  enabled ∷ Boolean
  enabled =
    case action of
      GoBackInternal →
        true
      _ →
        Foldable.any
          (String.contains (String.Pattern filterString) ∘ String.toLower)
          (searchFilters action)

  attrs =
    [ HP.title $ pluckActionDescription action
    , HP.disabled $ (not enabled) || (isDisabled action)
    , HP.buttonType HP.ButtonButton
    , ARIA.label $ pluckActionDescription action
    , HP.classes classes
    , HE.onClick (HE.input_ $ Selected action)
    , HCSS.style $ CSS.position CSS.relative
    ]

  classes ∷ Array HH.ClassName
  classes =
    if isHighlighted action && enabled
      then
        [ HH.className "sd-button" ]
      else
        [ HH.className "sd-button"
        , HH.className "sd-button-warning"
        ]

factors ∷ Int → Array Int
factors n = do
  factor ← 1 .. n
  guard $ n `mod` factor ≡ 0
  pure factor

updateActions ∷ ∀ a. Eq a ⇒ Array (ActionInternal a) → State a → State a
updateActions newActions state =
  case activeDrill of
    Nothing →
      state
        { actions = newActions }
    Just drill →
      state
        { previousActions = newActions
        , actions = fromMaybe [] $ pluckDrillActions =<< newActiveDrill
        }
  where
  activeDrill ∷ Maybe (ActionInternal a)
  activeDrill =
    Foldable.find
      (maybe false (eq state.actions) ∘ pluckDrillActions)
      state.previousActions

  newActiveDrill =
    Foldable.find (eq activeDrill ∘ Just) newActions

  pluckDrillActions =
    case _ of
      DrillInternal _ _ _ xs → Just xs
      _ → Nothing

domRectToDimensions ∷ DOMRect → Dimensions
domRectToDimensions domRect =
  { width: domRect.width, height: domRect.height }

getBoundingDOMRect ∷ ∀ a. DSL a (Maybe DOMRect)
getBoundingDOMRect =
  traverse (H.fromEff ∘ DOMUtils.getOffsetClientRect)
    =<< H.gets _.boundingElement

eval ∷ ∀ a. Eq a ⇒ Query a ~> DSL a
eval =
  case _ of
    UpdateFilter str next →
      H.modify (_filterString .~ str) $> next
    Selected action next → do
      st ← H.get
      case action of
        DoInternal _ _ _ _ _ _ → pure unit
        DrillInternal _ _ _ actions →
          H.modify
            $ (_actions .~ (GoBackInternal `Array.cons` actions))
            ∘ (_previousActions .~ st.actions)
        GoBackInternal →
          H.modify
            $ (_actions .~ st.previousActions)
            ∘ (_previousActions .~ [ ])
      pure next
    UpdateActions actions next →
      H.modify (updateActions $ toActionInternal <$> actions)
        $> next
    CalculateBoundingRect next →
      calculateBoundingRect $> next
    SetBoundingRect dimensions next →
      H.modify (_boundingDimensions .~ maybeNotZero dimensions) $> next
    GetBoundingRect continue →
      continue <$> H.gets _.boundingDimensions
    SetBoundingElement element next →
      H.modify (_boundingElement .~ element) $> next

maybeNotZero ∷ Dimensions → Maybe Dimensions
maybeNotZero dimensions =
  if dimensions.width ≡ 0.0 ∨ dimensions.height ≡ 0.0
    then Nothing
    else Just dimensions

calculateBoundingRect ∷ ∀ a. DSL a Unit
calculateBoundingRect =
  H.modify
    ∘ (_boundingDimensions .~ _)
    ∘ flip bind maybeNotZero
    ∘ map domRectToDimensions
    =<< getBoundingDOMRect

floor ∷ Dimensions → Dimensions
floor dimensions =
  { width: Math.floor dimensions.width
  , height: Math.floor dimensions.height
}

calculateLines ∷ Number → Array ActionNameWord → Array ActionNameLine
calculateLines width words =
  foldl go [] words
  where
  go ∷ Array ActionNameLine → ActionNameWord → Array ActionNameLine
  go acc (ActionNameWord { word, widthPx: wordWidthPx }) =
    case Array.uncons acc of
      Nothing →
        [ ActionNameLine { line: word, widthPx: wordWidthPx } ]
      Just { head: ActionNameLine { line, widthPx: lineWidthPx }, tail } →
        if (lineWidthPx + spaceWidth + wordWidthPx) <= width
          then
            Array.snoc
              tail
              $ ActionNameLine
                  { line: line <> " " <> word
                  , widthPx: lineWidthPx + spaceWidth + wordWidthPx
                  }
          else
            Array.snoc
              acc
              $ ActionNameLine { line: word, widthPx: wordWidthPx }

spaceWidth ∷ Number
spaceWidth =
  textWidth " "

textWidth ∷ String → Number
textWidth =
  flip
    DOMUtils.getTextWidthPure
    $ "normal " <> show fontSizePx <> "px Ubuntu"

mostSquareFittingRectangle ∷ Int → Dimensions → Maybe Dimensions
mostSquareFittingRectangle i boundingDimensions =
  Foldable.maximumBy
    (\x y → karat x `compare` karat y)
    solutions
  where
  solutions ∷ Array Dimensions
  solutions =
    solution <$> factors i

  goldenRatio ∷ Number
  goldenRatio =
    1.61803398875

  karat ∷ Dimensions → Number
  karat dimensions =
    -(Math.abs $ goldenRatio - (dimensions.width / dimensions.height))

  solution ∷ Int → Dimensions
  solution factor =
    { width: boundingDimensions.width / (Int.toNumber $ numberOfRows factor)
    , height: boundingDimensions.height / (Int.toNumber $ numberOfColumns factor)
    }

  numberOfRows ∷ Int → Int
  numberOfRows factor =
    if boundingDimensions.width > boundingDimensions.height
       then factor
       else i / factor

  numberOfColumns ∷ Int → Int
  numberOfColumns factor =
    if boundingDimensions.width > boundingDimensions.height
       then i / factor
       else factor

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.ActionList.Component
  ( FilterInputDescription(..)
  , comp
  , initialState
  , module SlamData.ActionList.Action
  , module SlamData.ActionList.Component.ActionInternal
  , module SlamData.ActionList.Component.State
  , module SlamData.ActionList.Component.Query
  ) where

import SlamData.Prelude

import CSS as CSS

import Data.Array ((..))
import Data.Array as Array
import Data.Foldable as Foldable
import Data.Int as Int
import Data.Lens ((.~))
import Data.String as String

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

import Math as Math

import SlamData.Monad (Slam)
import SlamData.Render.Common as RC
import SlamData.ActionList.Action (Action(..), ActionDescription(..), ActionHighlighted(..), ActionIconSrc(..), ActionName(..), ActionDisabled(..))
import SlamData.ActionList.Component.ActionInternal (ActionInternal(..), ActionNameLine(..), ActionNameWord(..), ButtonMetrics, Dimensions, Presentation(..))
import SlamData.ActionList.Component.State (State, _actions, _boundingDimensions, _boundingElement, _filterString, _previousActions)
import SlamData.ActionList.Component.Query (Query(..))

import Utils as Utils
import Utils.DOM (DOMRect)
import Utils.DOM as DOMUtils
import Utils.CSS as CSSUtils

newtype FilterInputDescription = FilterInputDescription String

type HTML a = H.ComponentHTML (Query a)
type DSL a = H.ComponentDSL (State a) (Query a) Slam

fontSizePx ∷ Number
fontSizePx =
  12.0

lineHeightPx ∷ Number
lineHeightPx =
  13.0

iconSizeRatio ∷ Number
iconSizeRatio =
  0.3

-- Buttons are rendered with mystery centering and padding.
-- This can cause text to overflow.
buttonPaddingHighEstimate ∷ Number
buttonPaddingHighEstimate =
  0.2

isIconOnly ∷ Presentation → Boolean
isIconOnly =
  case _ of
    IconOnly → true
    _ → false

wordify ∷ ActionName → Array ActionNameWord
wordify (ActionName s) =
  ActionNameWord
    ∘ (\word → { word, widthPx: textWidth word })
    <$> Utils.words s

printActionNameWord ∷ ActionNameWord → String
printActionNameWord (ActionNameWord { word }) =
  word

printActionNameLine ∷ ActionNameLine → String
printActionNameLine (ActionNameLine { line }) =
  line

printActionNameWords ∷ Array ActionNameWord → String
printActionNameWords =
  String.joinWith " " ∘ map printActionNameWord

toActionInternal ∷ ∀ a. Action a → ActionInternal a
toActionInternal =
  case _ of
    Do actionName actionIconSrc actionDescription actionHighlighted actionDisabled a →
      DoInternal
        (wordify actionName)
        actionIconSrc
        actionDescription
        actionHighlighted
        actionDisabled
        a
    Drill actionName actionIconSrc actionDescription xs →
      DrillInternal
        (wordify actionName)
        actionIconSrc
        actionDescription
        (toActionInternal <$> xs)

isDo ∷ ∀ a. ActionInternal a → Boolean
isDo =
  case _ of
    DoInternal _ _ _ _ _ _ →
      true
    _ →
      false

isDrill ∷ ∀ a. ActionInternal a → Boolean
isDrill =
  case _ of
    DrillInternal _ _ _ _ →
      true
    _ →
      false

isHighlighted ∷ ∀ a. ActionInternal a → Boolean
isHighlighted =
  case _ of
    DoInternal _ _ _ (ActionHighlighted highlighted) _ _ →
      highlighted
    DrillInternal _ _ _ actions →
      Foldable.any isHighlighted actions
    GoBackInternal → true

isDisabled ∷ ∀ a. ActionInternal a → Boolean
isDisabled =
  case _ of
    DoInternal _ _ _ _ (ActionDisabled disabled) _ →
      disabled
    DrillInternal _ _ _ actions →
      Foldable.any isDisabled actions
    GoBackInternal → true

searchFilters ∷ ∀ a. ActionInternal a → Array String
searchFilters =
  case _ of
    DoInternal words _ _ _ _ _ →
      [ printActionNameWords words ]
    DrillInternal words _ _ actions →
      [ printActionNameWords words ] ⊕ Array.concat (map searchFilters actions)
    GoBackInternal →
      [ "go back" ]

pluckActionDescription ∷ ∀ a. ActionInternal a → String
pluckActionDescription =
  case _ of
    DoInternal _ _ (ActionDescription s) _ _ _ →
      s
    DrillInternal _ _ (ActionDescription s) _ →
      s
    GoBackInternal →
      "Go back"

pluckActionIconSrc ∷ ∀ a. ActionInternal a → String
pluckActionIconSrc =
  case _ of
    DoInternal _ (ActionIconSrc s) _ _ _ _ →
      s
    DrillInternal _ (ActionIconSrc s) _ _ →
      s
    GoBackInternal →
      "/img/go-back.svg"

actionNameWords ∷ ∀ a. ActionInternal a → Array ActionNameWord
actionNameWords =
  case _ of
    DoInternal xs _ _ _ _ _ →
      xs
    DrillInternal xs _ _ _ →
      xs
    GoBackInternal →
      wordify $ ActionName "Go back"

initialState ∷ ∀ a. Array (Action a) → State a
initialState actions =
  { actions: toActionInternal <$> actions
  , previousActions: [ ]
  , filterString: ""
  , boundingElement: Nothing
  , boundingDimensions: Nothing
  }

comp ∷ ∀ a. Eq a ⇒ FilterInputDescription → H.Component (State a) (Query a) Slam
comp filterInputDescription =
  H.lifecycleComponent
    { render: render filterInputDescription
    , initializer: Just $ H.action CalculateBoundingRect
    , finalizer: Nothing
    , eval
    }

render ∷ ∀ a. FilterInputDescription → State a → HTML a
render (FilterInputDescription filterInputDescription) state =
  HH.div
    [ HP.class_ $ HH.className "sd-action-list" ]
    [ HH.form_
        [ HH.div_
            [ HH.div
                [ HP.class_ (HH.className "sd-action-filter-icon") ]
                [ RC.searchFieldIcon ]
            , HH.input
                [ HP.value state.filterString
                , HE.onValueInput (HE.input (\s → UpdateFilter s))
                , ARIA.label filterInputDescription
                , HP.placeholder filterInputDescription
                ]
            , HH.button
                [ HP.buttonType HP.ButtonButton
                , HE.onClick (HE.input_ (UpdateFilter ""))
                , HP.enabled (state.filterString /= "")
                ]
                [ RC.clearFieldIcon "Clear filter" ]
            ]
        ]
    , HH.ul
        [ HP.ref $ H.action ∘ SetBoundingElement ]
        (maybe
           []
           (renderButtons (String.toLower state.filterString) state.actions)
           (actionSize
              (Array.length state.actions)
              =<< state.boundingDimensions))
    ]
  where
  actionSize
    ∷ Int
    → Dimensions
    → Maybe { dimensions ∷ Dimensions, leavesASpace ∷ Boolean }
  actionSize i boundingDimensions = do
    firstTry ← mostSquareFittingRectangle i boundingDimensions
    if firstTry.height ≡ boundingDimensions.height
      then do
        secondTry ← mostSquareFittingRectangle (i + 1) boundingDimensions
        if secondTry.height ≡ boundingDimensions.height
           then pure { dimensions: firstTry, leavesASpace: false }
           else pure { dimensions: secondTry, leavesASpace: true }
        else pure { dimensions: firstTry, leavesASpace: false }

renderButtons
  ∷ ∀ a
  . String
  → Array (ActionInternal a)
  → { dimensions ∷ Dimensions, leavesASpace ∷ Boolean }
  → Array (HTML a)
renderButtons filterString actions buttonDimensions =
  if buttonDimensions.leavesASpace
    then realButtons <> [ renderSpaceFillerButton metrics ]
    else realButtons
  where
  realButtons ∷ Array (HTML a)
  realButtons =
    renderButton filterString presentation metrics <$> actionsWithLines

  actionsWithLines ∷ Array { action ∷ ActionInternal a, lines ∷ Array String }
  actionsWithLines =
    toActionWithLines (buttonDimensions.dimensions.width * 0.95) <$> actions

  toActionWithLines
    ∷ Number
    → ActionInternal a
    → { action ∷ ActionInternal a, lines ∷ Array String }
  toActionWithLines widthPx action =
    { action
    , lines: printActionNameLine <$> (calculateLines widthPx $ actionNameWords action)
    }

  iconDimensions ∷ Dimensions
  iconDimensions =
    { width: buttonDimensions.dimensions.width * iconSizeRatio
    , height: buttonDimensions.dimensions.height * iconSizeRatio
    }

  metrics ∷ ButtonMetrics
  metrics =
    { dimensions:
        buttonDimensions.dimensions
    , iconDimensions:
        iconDimensions
    , iconMarginPx:
        buttonDimensions.dimensions.height * 0.05
    , iconOnlyLeftPx:
        (buttonDimensions.dimensions.width / 2.0)
          - (iconDimensions.width / 2.0)
    , iconOnlyTopPx:
        (buttonDimensions.dimensions.height / 2.0)
          - (iconDimensions.height / 2.0) - 1.0
    }

  maxNumberOfLines ∷ Int
  maxNumberOfLines =
    fromMaybe 0 $ Foldable.maximum $ Array.length ∘ _.lines <$> actionsWithLines

  maxTextHeightPx ∷ Number
  maxTextHeightPx =
    Int.toNumber maxNumberOfLines * fontSizePx

  buttonPaddingEstimatePx ∷ Number
  buttonPaddingEstimatePx =
    buttonDimensions.dimensions.height * buttonPaddingHighEstimate

  textDoesNotFitWithIcon ∷ Boolean
  textDoesNotFitWithIcon =
    maxTextHeightPx
      + iconDimensions.height
      + metrics.iconMarginPx
      + buttonPaddingEstimatePx
      > buttonDimensions.dimensions.height

  textDoesNotFitOnItsOwn ∷ Boolean
  textDoesNotFitOnItsOwn =
    maxTextHeightPx > buttonDimensions.dimensions.height
      ∨ buttonDimensions.dimensions.width < 40.0

  -- Allows text which fits vertically but not horizontally.
  -- Styling truncates overflowing lines with ellipses.
  --
  -- E.g. where there is only room for two lines:
  -- "Show Chart" would be presented without an icon as
  --
  -- Sh...
  -- Ch...
  --
  -- But "Build pie chart" would be presented with only an icon.
  --
  -- The reasoning behind this is that presentation should be
  -- unform per action list but that the entire list shouldn't be
  -- reduced to only icons just because "Troubleshoot" would be
  -- truncated to "Troublesh...".
  presentation ∷ Presentation
  presentation =
    if textDoesNotFitOnItsOwn ∨ maxNumberOfLines ≡ 0
      then
        IconOnly
      else
        if textDoesNotFitWithIcon
          then
            TextOnly
          else
            IconAndText

decimalCrop ∷ Int → Number → Number
decimalCrop i n =
  (Math.floor $ n * multiplier) / multiplier
  where
  multiplier = Math.pow 10.0 $ Int.toNumber i

-- Firefox doesn't seem to be able to handle pixel metrics with decimal
-- precisons higher than one. Without applying this function actionlists
-- of certain widths render with empty spaces and overflowing actions.
firefoxify ∷ Number → Number
firefoxify n =
  if Utils.isFirefox
     then decimalCrop 1 n
     else n

renderSpaceFillerButton ∷ ∀ a. ButtonMetrics → HTML a
renderSpaceFillerButton metrics =
  HH.li
    [ HCSS.style
        $ CSS.width (CSS.px $ firefoxify metrics.dimensions.width)
        *> CSS.height (CSS.px $ firefoxify metrics.dimensions.height)
    ]
    [ HH.button
        [ HP.classes
            [ HH.className "sd-button"
            , HH.className "sd-button-warning"
            ]
        , HP.disabled true
        , HP.buttonType HP.ButtonButton
        ]
        []
    ]

renderButton
  ∷ ∀ a
  . String
  → Presentation
  → ButtonMetrics
  → { action ∷ ActionInternal a, lines ∷ Array String }
  → HTML a
renderButton filterString presentation metrics { action, lines } =
  HH.li
    [ HCSS.style
        $ CSS.width (CSS.px $ firefoxify metrics.dimensions.width)
        *> CSS.height (CSS.px $ firefoxify metrics.dimensions.height)
    ]
    [ HH.button
        attrs
        $ case presentation of
            IconOnly →
              [ renderIcon ]
            TextOnly →
              [ renderName ]
            IconAndText →
              [ renderIcon, renderName ]
    ]
  where
  renderIcon ∷ HTML a
  renderIcon =
    HH.img
      [ HP.src $ pluckActionIconSrc action
      , HCSS.style
          $ CSS.width (CSS.px metrics.iconDimensions.width)
          *> CSS.height (CSS.px metrics.iconDimensions.height)
          *> CSS.marginBottom (CSS.px metrics.iconMarginPx)
          -- Stops icon only presentations from being cut off in short wide
          -- buttons.
          *> (if (isIconOnly presentation)
                then
                  CSS.position CSS.absolute
                    *> CSS.left (CSS.px metrics.iconOnlyLeftPx)
                    *> CSS.top (CSS.px metrics.iconOnlyTopPx)
                else
                  CSS.position CSS.relative)
      ]

  renderName ∷ HTML a
  renderName =
    HH.p
      [ HCSS.style
          $ CSS.fontSize (CSS.px $ fontSizePx)
          *> CSSUtils.lineHeight (show lineHeightPx <> "px")
      ]
      $ Array.intercalate
          [ HH.br_ ]
          $ Array.singleton ∘ HH.text <$> lines

  enabled ∷ Boolean
  enabled =
    case action of
      GoBackInternal →
        true
      _ →
        Foldable.any
          (String.contains (String.Pattern filterString) ∘ String.toLower)
          (searchFilters action)

  attrs =
    [ HP.title $ pluckActionDescription action
    , HP.disabled $ (not enabled) || (isDisabled action)
    , HP.buttonType HP.ButtonButton
    , ARIA.label $ pluckActionDescription action
    , HP.classes classes
    , HE.onClick (HE.input_ $ Selected action)
    , HCSS.style $ CSS.position CSS.relative
    ]

  classes ∷ Array HH.ClassName
  classes =
    if isHighlighted action && enabled
      then
        [ HH.className "sd-button" ]
      else
        [ HH.className "sd-button"
        , HH.className "sd-button-warning"
        ]

factors ∷ Int → Array Int
factors n = do
  factor ← 1 .. n
  guard $ n `mod` factor ≡ 0
  pure factor

updateActions ∷ ∀ a. Eq a ⇒ Array (ActionInternal a) → State a → State a
updateActions newActions state =
  case activeDrill of
    Nothing →
      state
        { actions = newActions }
    Just drill →
      state
        { previousActions = newActions
        , actions = fromMaybe [] $ pluckDrillActions =<< newActiveDrill
        }
  where
  activeDrill ∷ Maybe (ActionInternal a)
  activeDrill =
    Foldable.find
      (maybe false (eq state.actions) ∘ pluckDrillActions)
      state.previousActions

  newActiveDrill =
    Foldable.find (eq activeDrill ∘ Just) newActions

  pluckDrillActions =
    case _ of
      DrillInternal _ _ _ xs → Just xs
      _ → Nothing

domRectToDimensions ∷ DOMRect → Dimensions
domRectToDimensions domRect =
  { width: domRect.width, height: domRect.height }

getBoundingDOMRect ∷ ∀ a. DSL a (Maybe DOMRect)
getBoundingDOMRect =
  traverse (H.fromEff ∘ DOMUtils.getOffsetClientRect)
    =<< H.gets _.boundingElement

eval ∷ ∀ a. Eq a ⇒ Query a ~> DSL a
eval =
  case _ of
    UpdateFilter str next →
      H.modify (_filterString .~ str) $> next
    Selected action next → do
      st ← H.get
      case action of
        DoInternal _ _ _ _ _ _ → pure unit
        DrillInternal _ _ _ actions →
          H.modify
            $ (_actions .~ (GoBackInternal `Array.cons` actions))
            ∘ (_previousActions .~ st.actions)
        GoBackInternal →
          H.modify
            $ (_actions .~ st.previousActions)
            ∘ (_previousActions .~ [ ])
      pure next
    UpdateActions actions next →
      H.modify (updateActions $ toActionInternal <$> actions)
        $> next
    CalculateBoundingRect next →
      calculateBoundingRect $> next
    SetBoundingRect dimensions next →
      H.modify (_boundingDimensions .~ maybeNotZero dimensions) $> next
    GetBoundingRect continue →
      continue <$> H.gets _.boundingDimensions
    SetBoundingElement element next →
      H.modify (_boundingElement .~ element) $> next

maybeNotZero ∷ Dimensions → Maybe Dimensions
maybeNotZero dimensions =
  if dimensions.width ≡ 0.0 ∨ dimensions.height ≡ 0.0
    then Nothing
    else Just dimensions

calculateBoundingRect ∷ ∀ a. DSL a Unit
calculateBoundingRect =
  H.modify
    ∘ (_boundingDimensions .~ _)
    ∘ flip bind maybeNotZero
    ∘ map domRectToDimensions
    =<< getBoundingDOMRect

floor ∷ Dimensions → Dimensions
floor dimensions =
  { width: Math.floor dimensions.width
  , height: Math.floor dimensions.height
}

calculateLines ∷ Number → Array ActionNameWord → Array ActionNameLine
calculateLines width words =
  foldl go [] words
  where
  go ∷ Array ActionNameLine → ActionNameWord → Array ActionNameLine
  go acc (ActionNameWord { word, widthPx: wordWidthPx }) =
    case Array.uncons acc of
      Nothing →
        [ ActionNameLine { line: word, widthPx: wordWidthPx } ]
      Just { head: ActionNameLine { line, widthPx: lineWidthPx }, tail } →
        if (lineWidthPx + spaceWidth + wordWidthPx) <= width
          then
            Array.snoc
              tail
              $ ActionNameLine
                  { line: line <> " " <> word
                  , widthPx: lineWidthPx + spaceWidth + wordWidthPx
                  }
          else
            Array.snoc
              acc
              $ ActionNameLine { line: word, widthPx: wordWidthPx }

spaceWidth ∷ Number
spaceWidth =
  textWidth " "

textWidth ∷ String → Number
textWidth =
  flip
    DOMUtils.getTextWidthPure
    $ "normal " <> show fontSizePx <> "px Ubuntu"

mostSquareFittingRectangle ∷ Int → Dimensions → Maybe Dimensions
mostSquareFittingRectangle i boundingDimensions =
  Foldable.maximumBy
    (\x y → karat x `compare` karat y)
    solutions
  where
  solutions ∷ Array Dimensions
  solutions =
    solution <$> factors i

  goldenRatio ∷ Number
  goldenRatio =
    1.61803398875

  karat ∷ Dimensions → Number
  karat dimensions =
    -(Math.abs $ goldenRatio - (dimensions.width / dimensions.height))

  solution ∷ Int → Dimensions
  solution factor =
    { width: boundingDimensions.width / (Int.toNumber $ numberOfRows factor)
    , height: boundingDimensions.height / (Int.toNumber $ numberOfColumns factor)
    }

  numberOfRows ∷ Int → Int
  numberOfRows factor =
    if boundingDimensions.width > boundingDimensions.height
       then factor
       else i / factor

  numberOfColumns ∷ Int → Int
  numberOfColumns factor =
    if boundingDimensions.width > boundingDimensions.height
       then i / factor
       else factor


Handle undefined

Handle undefined

module Data.Nullable
  ( Nullable()
  , toMaybe
  , toNullable
  ) where

import Data.Maybe
import Data.Function

foreign import data Nullable :: * -> *

foreign import null
  "var $$null = null" :: forall a. Nullable a

foreign import nullable
  "function nullable(a, r, f) {\
  \  return a === null || typeof a === 'undefined' ? r : f(a);\
  \}" :: forall a r. Fn3 (Nullable a) r (a -> r) r

foreign import notNull
  "function notNull(x) {\
  \  return x;\
  \}" :: forall a. a -> Nullable a

toNullable :: forall a. Maybe a -> Nullable a
toNullable = maybe null notNull

toMaybe :: forall a. Nullable a -> Maybe a
toMaybe n = runFn3 nullable n Nothing Just

instance showNullable :: (Show a) => Show (Nullable a) where
  show n = case toMaybe n of
             Nothing -> "null"
             Just a -> show a

instance eqNullable :: (Eq a) => Eq (Nullable a) where
  (==) = (==) `on` toMaybe
  (/=) = (/=) `on` toMaybe

instance ordNullable :: (Ord a) => Ord (Nullable a) where
  compare = compare `on` toMaybe

module Data.Nullable
  ( Nullable()
  , toMaybe
  , toNullable
  ) where

import Data.Maybe
import Data.Function

foreign import data Nullable :: * -> *

foreign import null
  "var $$null = null" :: forall a. Nullable a

foreign import nullable
  "function nullable(a, r, f) {\
  \  return a === null ? r : f(a);\
  \}" :: forall a r. Fn3 (Nullable a) r (a -> r) r

foreign import notNull
  "function notNull(x) {\
  \  return x;\
  \}" :: forall a. a -> Nullable a

toNullable :: forall a. Maybe a -> Nullable a
toNullable = maybe null notNull

toMaybe :: forall a. Nullable a -> Maybe a
toMaybe n = runFn3 nullable n Nothing Just

instance showNullable :: (Show a) => Show (Nullable a) where
  show n = case toMaybe n of
             Nothing -> "null"
             Just a -> show a

instance eqNullable :: (Eq a) => Eq (Nullable a) where
  (==) = (==) `on` toMaybe
  (/=) = (/=) `on` toMaybe

instance ordNullable :: (Ord a) => Ord (Nullable a) where
  compare = compare `on` toMaybe


Fix type checker test case

Fix type checker test case

module Test.TypeChecker where

import AST (AD(TList, TTuple), Atom(AInt, Name, Char), Binding(Lit, ConsLit, ListLit, NTupleLit), Definition(Def), Expr(Atom, List, SectR, App, Binary, PrefixOp, Lambda, NTuple, LetExpr, SectL), Op(Power, Colon, Add, Append), TVar, Type(TypCon, TypVar, AD, TypArr), TypeError(InfiniteType, UnificationFail, UnknownError))
import TypeChecker (Subst, Infer, TypeEnv, Scheme(Forall), inferGroup, inferType, inferDef, prettyPrintType, emptyTyenv, runInfer, typeProgramn, eqScheme)
import Parser (expression, definition, runParserIndent)

import Prelude (Unit, bind, ($), show, (==), (<>))
import Data.Either (Either(..))
import Data.List (List(..), (:))
import Data.Array (toUnfoldable) as Array
import Data.Tuple (Tuple(..))
import Test.Parser (parsedPrelude)

import Text.Parsing.Parser (ParseError)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)

toList :: forall a. Array a -> List a
toList = Array.toUnfoldable

testInfer:: forall a  eff. String -> a -> (TypeEnv -> a -> Infer (Tuple Subst Type))
 -> Either TypeError Scheme -> Eff (console :: CONSOLE | eff ) Unit
testInfer name input f expected
  = test name expected $ runInfer $ f emptyTyenv input

testProgramm:: forall eff. String -> List Definition -> Expr
 -> Either TypeError Scheme -> Eff (console :: CONSOLE | eff ) Unit
testProgramm name defs exp expected
 = test name expected $ typeProgramn defs exp

-- test  name -> expected -> actuall -> Eff ...
test:: forall eff. String -> Either TypeError Scheme -> Either TypeError Scheme
 -> Eff (console :: CONSOLE | eff ) Unit
test name expected actuall = if eqTypErrScheme expected actuall
  then log $ "Typing success ("  <> name <> ")"
  else log $ "\n \n Typing fail (" <> name <> ") :  expected result: \n"
    <> show expected <> "\n actuall result: \n" <> show actuall <> "\n \n"
     <> "Pretty Print expected: \n" <> prettyPrint expected
      <> "\n Pretty Print actuall: \n" <> prettyPrint actuall <> "\n \n"

eqTypErrScheme:: Either TypeError Scheme -> Either TypeError Scheme -> Boolean
eqTypErrScheme (Left a) (Left a') = (a == a')
eqTypErrScheme (Right a) (Right a') = eqScheme a a'
eqTypErrScheme _ _ = false

aint :: Int -> Expr
aint i = Atom $ AInt i

aname :: String -> Expr
aname s = Atom $ Name s

tvar :: String -> Type
tvar = TypVar

out::forall eff. String -> Eff (console :: CONSOLE | eff ) Unit
out s = log s

parseExp:: String -> Either ParseError Expr
parseExp = runParserIndent expression

parseDef:: String -> Either ParseError Definition
parseDef = runParserIndent definition

typeStr:: String -> Either TypeError Scheme
typeStr expS = case runParserIndent expression expS of
  Right exp -> runInfer $ inferType emptyTyenv exp
  Left _ -> Left $ UnknownError "Parse Error"

typeStrPre:: String -> Either TypeError Scheme
typeStrPre expS = case runParserIndent expression expS of
  Right exp -> typeProgramn parsedPrelude exp
  Left _ -> Left $ UnknownError "Parse Error"

typeExp:: Expr -> Either TypeError Scheme
typeExp exp = runInfer $ inferType emptyTyenv exp

typeDef:: Definition -> Either TypeError Scheme
typeDef def = runInfer $ inferDef emptyTyenv def

prettyPrint:: Either TypeError Scheme -> String
prettyPrint a@(Left _) = show a
prettyPrint (Right (Forall _ t)) = prettyPrintType t

printTypeExp::forall eff. Expr -> Eff (console :: CONSOLE | eff ) Unit
printTypeExp e = out $ prettyPrint $ typeExp e

printTypeStr::forall eff. String -> Eff (console :: CONSOLE | eff ) Unit
printTypeStr s = out $ prettyPrint $ typeStr s

-- default 1
d1 :: Either TypeError Scheme
d1 = Right (Forall Nil $ tvar "a")

runTests :: forall eff. Eff (console :: CONSOLE | eff) Unit
runTests = do
  log "Running Typing Tests"

  testInfer "SectL" (SectL (aint 3) Power)
    inferType(Right (Forall Nil $ TypArr (TypCon "Int") (TypCon "Int")))
  testInfer "SectR" (SectR Power (aint 3))
    inferType(Right (Forall (Nil) (TypArr (TypCon "Int") (TypCon "Int"))))
  testInfer "Lambda1" (Lambda (toList $ [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c",Lit $ Name "d"]) (App (aname "a") (toList [aname "b", aname "c", aname "d"])))
    inferType(Right (Forall (toList ["b", "c", "d", "e"]) (TypArr (TypArr (tvar "b") (TypArr (tvar "c") (TypArr (tvar "d") (tvar "e")))) (TypArr ( tvar "b")  ((TypArr (tvar "c") (TypArr (tvar "d") (tvar "e"))))))))
  testInfer "Lambda2" (Lambda (toList [Lit $ Name "a", Lit $ Name "b"]) (App (aname "a") (toList [aname "b"])))
    inferType(Right (Forall ("t_3" : "t_4" : Nil) (TypArr (TypArr (TypVar "t_3") (TypVar "t_4")) (TypArr (TypVar "t_3") (TypVar "t_4")))))
  testInfer "List1" (List (toList [aint 1, aint 2, aint 3, aint 4, aint 5])) inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "List2" (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
    inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "List3" (List $ toList [PrefixOp Add, aint 4])
    inferType(Left ((UnificationFail (TypCon "Int") (TypArr (TypCon "Int") (TypArr (TypCon "Int") (TypCon "Int"))))))
  testInfer "Nil List" (List Nil)
    inferType (Right (Forall ("t_0" : Nil) (AD (TList (TypVar "t_0")))))
  testInfer "Append" (Binary Append
    (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
    (List Nil))
    inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "Colon" (Binary Colon (aint 3) (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4),Atom $ Char "Hallo"]))
    inferType(Left ((UnificationFail (TypCon "Char") (TypCon "Int"))))
  testInfer "NTuple" (NTuple (toList [Binary Add (aint 1) (aint 2), aint 3]))
    inferType(Right (Forall (Nil) (AD (TTuple (Cons ((TypCon "Int")) (Cons ((TypCon "Int")) (Nil)))))))
  testInfer "SectR Colon" (SectR Colon $ List $ toList [aint 3])
    inferType(Right (Forall (Nil) (TypArr (TypCon "Int") (AD (TList (TypCon "Int"))))))
  testInfer "Def ~map" (Def "map" (toList [Lit $ Name "f", Lit $ Name "xs"]) (App (aname "map") (toList [aname "f",aname"xs"])))
    inferDef (Right (Forall ("t_2" : "t_4" : "t_5" : Nil) (TypArr (TypVar "t_2") (TypArr (TypVar "t_4") (TypVar "t_5")))))
  testInfer "Lambda Wildcard" (Lambda (toList [Lit (Name "_"), Lit (Name "_")]) (aint 5))
    inferType (Right (Forall ("t_1" : "t_3" : Nil) (TypArr (TypVar "t_1") (TypArr (TypVar "t_3") (TypCon "Int")))))
  testInfer "Lambda ConsBinding" (Lambda (toList [ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (aname "x"))
    inferType (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInfer "singel map" (Def "map" (toList [Lit $ Name "f", ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (App  (PrefixOp Colon) (toList [App (aname "f") $ toList [(aname"x")], App (aname "map") (toList [aname"f", aname"xs"])])))
    inferDef (Right (Forall ("t_11" : "t_5" : Nil) (TypArr (TypArr (TypVar "t_5") (TypVar "t_11")) (TypArr (AD (TList (TypVar "t_5"))) (AD (TList (TypVar "t_11")))))))
  testInfer "foldr" (Def "foldr" (toList [Lit $ Name "f", Lit $ Name "ini", ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (App (aname "f") (toList [aname "x",App (aname "foldr") (toList [aname "f", aname "ini" ,aname "xs"  ] )])))
    inferDef (Right (Forall ("t_5" : "t_4" : "t_7" : Nil) (TypArr (TypArr (TypVar "t_7") (TypArr (TypVar "t_4") (TypVar "t_4"))) (TypArr (TypVar "t_5") (TypArr (AD (TList (TypVar "t_7"))) (TypVar "t_4"))))))
  testInfer "let Expr" (LetExpr (Cons (Tuple (Lit $ Name "x") (aint 3)) Nil) (Lambda (toList [Lit (Name "_"), Lit (Name "_")]) (aname "x")))
    inferType (Right (Forall ("t_2" : "t_4" : Nil) (TypArr (TypVar "t_2") (TypArr (TypVar "t_4") (TypCon "Int")))))
  testInfer "ConsLit Binding 1" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "x"))
    inferDef (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInfer "ConsLit Binding 2" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "xs"))
    inferDef (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInfer "ConsLit Binding 3" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "xss"))
    inferDef (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (AD (TList (TypVar "t_2"))))))
  testInfer "Binding Tuple 1" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])]) (aname "a"))
    inferDef (Right (Forall ("t_2" : "t_3" : Nil) (TypArr (AD (TTuple $ Cons ((TypVar "t_2")) (Cons ((TypVar "t_3")) (Nil)))) (TypVar "t_2"))))
  testInfer "Binding Tuple 2" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])]) (aname "b"))
    inferDef (Right (Forall ("t_2" : "t_3" : Nil) (TypArr (AD (TTuple (Cons ((TypVar "t_2")) (Cons ((TypVar "t_3")) (Nil))))) (TypVar "t_3"))))
  testInfer "Binding Tuple 3" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c"])]) (App (aname "a") (toList [aname "b", aname "c"])))
    inferDef (Right (Forall ("t_3" : "t_4" : "t_5" : Nil) (TypArr (AD (TTuple (Cons ((TypArr (TypVar "t_3") (TypArr (TypVar "t_4") (TypVar "t_5")))) (Cons ((TypVar "t_3")) (Cons ((TypVar "t_4")) (Nil)))))) (TypVar "t_5"))))
  testInfer "ListLit Binding" (Def "list" (toList [ListLit (toList [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c"])]) (App (aname "a") (toList [aname "b", aname "c"])))
    inferDef (Left ((InfiniteType "a" (TypArr (TypVar "a") (TypVar "b")))))
  testInfer "NTupleLit Binding LetExp" (LetExpr (Cons (Tuple (NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])) (NTuple (toList [(Lambda (toList [Lit $ Name "f"]) (aname "f")), (Atom $ Char "Hello")]))) Nil) (App (aname "a") (toList [aname "b"])))
    inferType (Right (Forall (Nil) (TypCon "Char")))
  testInfer "Lambda App" (App (Lambda (Cons (Lit (Name "f")) (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "a")) (Cons (Atom (Name "b")) (Nil))))) (Cons (PrefixOp Add) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))))
    inferType (Right (Forall (Nil) (TypCon "Int")))
  testInfer "zipWith - Group" (toList [Def "zipWith" (toList [Lit $ Name "f", ConsLit (Lit $ Name "x") (Lit $ Name "xs"), ConsLit (Lit $ Name "y") (Lit $ Name "ys")])
      (App (PrefixOp Colon) (toList [App (aname "f") (toList [aname "x",aname "y"]), App (aname "zipWith") (toList [aname "f",aname"xs",aname "ys"])])),
      Def "zipWith" (toList [Lit $ Name "_",ListLit Nil,Lit $ Name "_"]) (List Nil),
      Def "zipWith" (toList [Lit $ Name "_",Lit $ Name "_",ListLit Nil]) (List Nil)])
      inferGroup (Right (Forall ("t_23" : "t_33" : "t_34" : Nil) (TypArr (TypArr (TypVar "t_23") (TypArr (TypVar "t_33") (TypVar "t_34"))) (TypArr (AD (TList (TypVar "t_23"))) (TypArr (AD (TList (TypVar "t_33"))) (AD (TList (TypVar "t_34"))))))))

  testInfer "real foldr - Group" (toList [(Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ListLit (Nil)) (Nil)))) (Atom (Name "ini"))),
      (Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "x")) (Cons (App (Atom (Name "foldr")) (Cons (Atom (Name "f")) (Cons (Atom (Name "ini")) (Cons (Atom (Name "xs")) (Nil))))) (Nil)))))])
      inferGroup ((Right (Forall ("t_4" : "t_7" : Nil) (TypArr (TypArr (TypVar "t_7") (TypArr (TypVar "t_4") (TypVar "t_4"))) (TypArr (TypVar "t_4") (TypArr (AD (TList (TypVar "t_7"))) (TypVar "t_4")))))))

  testInfer "scanl - Group" (toList [Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ListLit (Nil)) (Nil)))) (List (Cons (Atom (Name "b")) (Nil))),
                                     Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (Binary Colon (Atom (Name "b")) (App (Atom (Name "scanl")) (Cons (Atom (Name "f")) (Cons (App (Atom (Name "f")) (Cons (Atom (Name "b")) (Cons (Atom (Name "x")) (Nil)))) (Cons (Atom (Name "xs")) (Nil))))))])
   inferGroup (Right (Forall ("t_39" : "t_48" : Nil) (TypArr (TypArr (TypVar "t_48") (TypArr (TypVar "t_39") (TypVar "t_48"))) (TypArr (TypVar "t_48") (TypArr (AD (TList (TypVar "t_39"))) (AD (TList (TypVar "t_48"))))))))

  testProgramm "Prelude with exp" parsedPrelude
    ((App (Atom (Name "sum")) (Cons (App (Atom (Name "map")) (Cons (SectR Power (Atom (AInt 2))) (Cons (List (Cons (Atom (AInt 1)) (Cons (Atom (AInt 2)) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))))) (Nil)))) (Nil))))
    (Right (Forall (Nil) (TypCon "Int")))

module Test.TypeChecker where

import AST (AD(TList, TTuple), Atom(AInt, Name, Char), Binding(Lit, ConsLit, ListLit, NTupleLit), Definition(Def), Expr(Atom, List, SectR, App, Binary, PrefixOp, Lambda, NTuple, LetExpr, SectL), Op(Power, Colon, Add, Append), TVar, Type(TypCon, TypVar, AD, TypArr), TypeError(InfiniteType, UnificationFail, UnknownError))
import TypeChecker (Subst, Infer, TypeEnv, Scheme(Forall), inferGroup, inferType, inferDef, prettyPrintType, emptyTyenv, runInfer, typeProgramn, eqScheme)
import Parser (expression, definition, runParserIndent)

import Prelude (Unit, bind, ($), show, (==), (<>))
import Data.Either (Either(..))
import Data.List (List(..), (:))
import Data.Array (toUnfoldable) as Array
import Data.Tuple (Tuple(..))
import Test.Parser (parsedPrelude)

import Text.Parsing.Parser (ParseError)

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)

toList :: forall a. Array a -> List a
toList = Array.toUnfoldable

testInfer:: forall a  eff. String -> a -> (TypeEnv -> a -> Infer (Tuple Subst Type))
 -> Either TypeError Scheme -> Eff (console :: CONSOLE | eff ) Unit
testInfer name input f expected
  = test name expected $ runInfer $ f emptyTyenv input

testProgramm:: forall eff. String -> List Definition -> Expr
 -> Either TypeError Scheme -> Eff (console :: CONSOLE | eff ) Unit
testProgramm name defs exp expected
 = test name expected $ typeProgramn defs exp

-- test  name -> expected -> actuall -> Eff ...
test:: forall eff. String -> Either TypeError Scheme -> Either TypeError Scheme
 -> Eff (console :: CONSOLE | eff ) Unit
test name expected actuall = if eqTypErrScheme expected actuall
  then log $ "Typing success ("  <> name <> ")"
  else log $ "\n \n Typing fail (" <> name <> ") :  expected result: \n"
    <> show expected <> "\n actuall result: \n" <> show actuall <> "\n \n"
     <> "Pretty Print expected: \n" <> prettyPrint expected
      <> "\n Pretty Print actuall: \n" <> prettyPrint actuall <> "\n \n"

eqTypErrScheme:: Either TypeError Scheme -> Either TypeError Scheme -> Boolean
eqTypErrScheme (Left a) (Left a') = (a == a')
eqTypErrScheme (Right a) (Right a') = eqScheme a a'
eqTypErrScheme _ _ = false

aint :: Int -> Expr
aint i = Atom $ AInt i

aname :: String -> Expr
aname s = Atom $ Name s

tvar :: String -> Type
tvar = TypVar

out::forall eff. String -> Eff (console :: CONSOLE | eff ) Unit
out s = log s

parseExp:: String -> Either ParseError Expr
parseExp = runParserIndent expression

parseDef:: String -> Either ParseError Definition
parseDef = runParserIndent definition

typeStr:: String -> Either TypeError Scheme
typeStr expS = case runParserIndent expression expS of
  Right exp -> runInfer $ inferType emptyTyenv exp
  Left _ -> Left $ UnknownError "Parse Error"

typeStrPre:: String -> Either TypeError Scheme
typeStrPre expS = case runParserIndent expression expS of
  Right exp -> typeProgramn parsedPrelude exp
  Left _ -> Left $ UnknownError "Parse Error"

typeExp:: Expr -> Either TypeError Scheme
typeExp exp = runInfer $ inferType emptyTyenv exp

typeDef:: Definition -> Either TypeError Scheme
typeDef def = runInfer $ inferDef emptyTyenv def

prettyPrint:: Either TypeError Scheme -> String
prettyPrint a@(Left _) = show a
prettyPrint (Right (Forall _ t)) = prettyPrintType t

printTypeExp::forall eff. Expr -> Eff (console :: CONSOLE | eff ) Unit
printTypeExp e = out $ prettyPrint $ typeExp e

printTypeStr::forall eff. String -> Eff (console :: CONSOLE | eff ) Unit
printTypeStr s = out $ prettyPrint $ typeStr s

-- default 1
d1 :: Either TypeError Scheme
d1 = Right (Forall Nil $ tvar "a")

runTests :: forall eff. Eff (console :: CONSOLE | eff) Unit
runTests = do
  log "Running Typing Tests"

  testInfer "SectL" (SectL (aint 3) Power)
    inferType(Right (Forall Nil $ TypArr (TypCon "Int") (TypCon "Int")))
  testInfer "SectR" (SectR Power (aint 3))
    inferType(Right (Forall (Nil) (TypArr (TypCon "Int") (TypCon "Int"))))
  testInfer "Lambda1" (Lambda (toList $ [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c",Lit $ Name "d"]) (App (aname "a") (toList [aname "b", aname "c", aname "d"])))
    inferType(Right (Forall (toList ["b", "c", "d", "e"]) (TypArr (TypArr (tvar "b") (TypArr (tvar "c") (TypArr (tvar "d") (tvar "e")))) (TypArr ( tvar "b")  ((TypArr (tvar "c") (TypArr (tvar "d") (tvar "e"))))))))
  testInfer "Lambda2" (Lambda (toList [Lit $ Name "a", Lit $ Name "b"]) (App (aname "a") (toList [aname "b"])))
    inferType(Right (Forall ("t_3" : "t_4" : Nil) (TypArr (TypArr (TypVar "t_3") (TypVar "t_4")) (TypArr (TypVar "t_3") (TypVar "t_4")))))
  testInfer "List1" (List (toList [aint 1, aint 2, aint 3, aint 4, aint 5])) inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "List2" (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
    inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "List3" (List $ toList [PrefixOp Add, aint 4])
    inferType(Left ((UnificationFail (TypCon "Int") (TypArr (TypCon "Int") (TypArr (TypCon "Int") (TypCon "Int"))))))
  testInfer "Nil List" (List Nil)
    inferType (Right (Forall ("t_0" : Nil) (AD (TList (TypVar "t_0")))))
  testInfer "Append" (Binary Append
    (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4)])
    (List Nil))
    inferType(Right (Forall (Nil) (AD (TList (TypCon "Int")))))
  testInfer "Colon" (Binary Colon (aint 3) (List $ toList [Binary Add (aint 1) (aint 2), Binary Add (aint 3) (aint 4),Atom $ Char "Hallo"]))
    inferType(Left ((UnificationFail (TypCon "Char") (TypCon "Int"))))
  testInfer "NTuple" (NTuple (toList [Binary Add (aint 1) (aint 2), aint 3]))
    inferType(Right (Forall (Nil) (AD (TTuple (Cons ((TypCon "Int")) (Cons ((TypCon "Int")) (Nil)))))))
  testInfer "SectR Colon" (SectR Colon $ List $ toList [aint 3])
    inferType(Right (Forall (Nil) (TypArr (TypCon "Int") (AD (TList (TypCon "Int"))))))
  testInfer "Def ~map" (Def "map" (toList [Lit $ Name "f", Lit $ Name "xs"]) (App (aname "map") (toList [aname "f",aname"xs"])))
    inferDef (Right (Forall ("t_2" : "t_4" : "t_5" : Nil) (TypArr (TypVar "t_2") (TypArr (TypVar "t_4") (TypVar "t_5")))))
  testInfer "Lambda Wildcard" (Lambda (toList [Lit (Name "_"), Lit (Name "_")]) (aint 5))
    inferType (Right (Forall ("t_1" : "t_3" : Nil) (TypArr (TypVar "t_1") (TypArr (TypVar "t_3") (TypCon "Int")))))
  testInfer "Lambda ConsBinding" (Lambda (toList [ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (aname "x"))
    inferType (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInfer "singel map" (Def "map" (toList [Lit $ Name "f", ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (App  (PrefixOp Colon) (toList [App (aname "f") $ toList [(aname"x")], App (aname "map") (toList [aname"f", aname"xs"])])))
    inferDef (Right (Forall ("t_11" : "t_5" : Nil) (TypArr (TypArr (TypVar "t_5") (TypVar "t_11")) (TypArr (AD (TList (TypVar "t_5"))) (AD (TList (TypVar "t_11")))))))
  testInfer "foldr" (Def "foldr" (toList [Lit $ Name "f", Lit $ Name "ini", ConsLit (Lit $ Name "x") (Lit $ Name "xs")]) (App (aname "f") (toList [aname "x",App (aname "foldr") (toList [aname "f", aname "ini" ,aname "xs"  ] )])))
    inferDef (Right (Forall ("t_5" : "t_4" : "t_7" : Nil) (TypArr (TypArr (TypVar "t_7") (TypArr (TypVar "t_4") (TypVar "t_4"))) (TypArr (TypVar "t_5") (TypArr (AD (TList (TypVar "t_7"))) (TypVar "t_4"))))))
  testInfer "let Expr" (LetExpr (Cons (Tuple (Lit $ Name "x") (aint 3)) Nil) (Lambda (toList [Lit (Name "_"), Lit (Name "_")]) (aname "x")))
    inferType (Right (Forall ("t_2" : "t_4" : Nil) (TypArr (TypVar "t_2") (TypArr (TypVar "t_4") (TypCon "Int")))))
  testInfer "ConsLit Binding 1" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "x"))
    inferDef (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInfer "ConsLit Binding 2" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "xs"))
    inferDef (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (TypVar "t_2"))))
  testInfer "ConsLit Binding 3" (Def "list" (toList [ConsLit (Lit $ Name "x") (ConsLit (Lit $ Name "xs")(Lit $ Name "xss"))]) (aname "xss"))
    inferDef (Right (Forall ("t_2" : Nil) (TypArr (AD (TList (TypVar "t_2"))) (AD (TList (TypVar "t_2"))))))
  testInfer "Binding Tuple 1" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])]) (aname "a"))
    inferDef (Right (Forall ("t_2" : "t_3" : Nil) (TypArr (AD (TTuple $ Cons ((TypVar "t_2")) (Cons ((TypVar "t_3")) (Nil)))) (TypVar "t_2"))))
  testInfer "Binding Tuple 2" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])]) (aname "b"))
    inferDef (Right (Forall ("t_2" : "t_3" : Nil) (TypArr (AD (TTuple (Cons ((TypVar "t_2")) (Cons ((TypVar "t_3")) (Nil))))) (TypVar "t_3"))))
  testInfer "Binding Tuple 3" (Def "tuple" (toList [NTupleLit (toList [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c"])]) (App (aname "a") (toList [aname "b", aname "c"])))
    inferDef (Right (Forall ("t_3" : "t_4" : "t_5" : Nil) (TypArr (AD (TTuple (Cons ((TypArr (TypVar "t_3") (TypArr (TypVar "t_4") (TypVar "t_5")))) (Cons ((TypVar "t_3")) (Cons ((TypVar "t_4")) (Nil)))))) (TypVar "t_5"))))
  testInfer "ListLit Binding" (Def "list" (toList [ListLit (toList [Lit $ Name "a",Lit $ Name "b",Lit $ Name "c"])]) (App (aname "a") (toList [aname "b", aname "c"])))
    inferDef (Left ((InfiniteType "t_3" (TypArr (TypVar "t_3") (TypVar "t_6")))))
  testInfer "NTupleLit Binding LetExp" (LetExpr (Cons (Tuple (NTupleLit (toList [Lit $ Name "a",Lit $ Name "b"])) (NTuple (toList [(Lambda (toList [Lit $ Name "f"]) (aname "f")), (Atom $ Char "Hello")]))) Nil) (App (aname "a") (toList [aname "b"])))
    inferType (Right (Forall (Nil) (TypCon "Char")))
  testInfer "Lambda App" (App (Lambda (Cons (Lit (Name "f")) (Cons (Lit (Name "a")) (Cons (Lit (Name "b")) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "a")) (Cons (Atom (Name "b")) (Nil))))) (Cons (PrefixOp Add) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))))
    inferType (Right (Forall (Nil) (TypCon "Int")))
  testInfer "zipWith - Group" (toList [Def "zipWith" (toList [Lit $ Name "f", ConsLit (Lit $ Name "x") (Lit $ Name "xs"), ConsLit (Lit $ Name "y") (Lit $ Name "ys")])
      (App (PrefixOp Colon) (toList [App (aname "f") (toList [aname "x",aname "y"]), App (aname "zipWith") (toList [aname "f",aname"xs",aname "ys"])])),
      Def "zipWith" (toList [Lit $ Name "_",ListLit Nil,Lit $ Name "_"]) (List Nil),
      Def "zipWith" (toList [Lit $ Name "_",Lit $ Name "_",ListLit Nil]) (List Nil)])
      inferGroup (Right (Forall ("t_23" : "t_33" : "t_34" : Nil) (TypArr (TypArr (TypVar "t_23") (TypArr (TypVar "t_33") (TypVar "t_34"))) (TypArr (AD (TList (TypVar "t_23"))) (TypArr (AD (TList (TypVar "t_33"))) (AD (TList (TypVar "t_34"))))))))

  testInfer "real foldr - Group" (toList [(Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ListLit (Nil)) (Nil)))) (Atom (Name "ini"))),
      (Def "foldr" (Cons (Lit (Name "f")) (Cons (Lit (Name "ini")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (App (Atom (Name "f")) (Cons (Atom (Name "x")) (Cons (App (Atom (Name "foldr")) (Cons (Atom (Name "f")) (Cons (Atom (Name "ini")) (Cons (Atom (Name "xs")) (Nil))))) (Nil)))))])
      inferGroup ((Right (Forall ("t_4" : "t_7" : Nil) (TypArr (TypArr (TypVar "t_7") (TypArr (TypVar "t_4") (TypVar "t_4"))) (TypArr (TypVar "t_4") (TypArr (AD (TList (TypVar "t_7"))) (TypVar "t_4")))))))

  testInfer "scanl - Group" (toList [Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ListLit (Nil)) (Nil)))) (List (Cons (Atom (Name "b")) (Nil))),
                                     Def "scanl" (Cons (Lit (Name "f")) (Cons (Lit (Name "b")) (Cons (ConsLit (Lit (Name "x")) (Lit (Name "xs"))) (Nil)))) (Binary Colon (Atom (Name "b")) (App (Atom (Name "scanl")) (Cons (Atom (Name "f")) (Cons (App (Atom (Name "f")) (Cons (Atom (Name "b")) (Cons (Atom (Name "x")) (Nil)))) (Cons (Atom (Name "xs")) (Nil))))))])
   inferGroup (Right (Forall ("t_39" : "t_48" : Nil) (TypArr (TypArr (TypVar "t_48") (TypArr (TypVar "t_39") (TypVar "t_48"))) (TypArr (TypVar "t_48") (TypArr (AD (TList (TypVar "t_39"))) (AD (TList (TypVar "t_48"))))))))

  testProgramm "Prelude with exp" parsedPrelude
    ((App (Atom (Name "sum")) (Cons (App (Atom (Name "map")) (Cons (SectR Power (Atom (AInt 2))) (Cons (List (Cons (Atom (AInt 1)) (Cons (Atom (AInt 2)) (Cons (Atom (AInt 3)) (Cons (Atom (AInt 4)) (Nil)))))) (Nil)))) (Nil))))
    (Right (Forall (Nil) (TypCon "Int")))


Improve docs

Improve docs

-- | This module provides a low-level wrapper for the Node Stream API.

module Node.Stream
  ( Stream()
  , Read()
  , Readable()
  , Write()
  , Writable()
  , Duplex()
  , setEncoding
  , onData
  , onEnd
  , onClose
  , onError
  , resume
  , pause
  , isPaused
  , pipe
  , write
  , writeString
  , cork
  , uncork
  , setDefaultEncoding
  , end
  ) where

import Prelude

import Node.Encoding
import Node.Buffer (Buffer())
import Node.Buffer as Buffer

import Control.Monad.Eff
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)

-- | A stream.
-- |
-- | The type arguments track, in order:
-- |
-- | - Whether reading and/or writing from/to the stream are allowed.
-- | - Effects associated with reading/writing from/to this stream.
foreign import data Stream :: # * -> # ! -> *

-- | A phantom type associated with _readable streams_.
data Read

-- | A readable stream.
type Readable r = Stream (read :: Read | r)

-- | A phantom type associated with _writable streams_.
data Write

-- | A writable stream.
type Writable r = Stream (write :: Write | r)

-- | A duplex (readable _and_ writable stream)
type Duplex = Stream (read :: Read, write :: Write)

foreign import setEncodingImpl :: forall w eff. Readable w eff -> String -> Eff eff Unit

-- | Set the encoding used to read chunks as strings from the stream. This
-- | function is useful when you are passing a readable stream to some other
-- | JavaScript library, which already expects an encoding to be set. It
-- | has no effect on the behaviour of the `onDataString` function (because
-- | that function ensures that the encoding is always supplied explicitly).
setEncoding :: forall w eff. Readable w eff -> Encoding -> Eff eff Unit
setEncoding r enc = setEncodingImpl r (show enc)

foreign import onDataImpl :: forall w eff a. Readable w eff -> (a -> Eff eff Unit) -> Eff eff Unit

-- | Listen for `data` events, returning data in a Buffer.
onData :: forall w eff. Readable w eff -> (Buffer -> Eff eff Unit) -> Eff eff Unit
onData = onDataImpl

-- | Listen for `data` events, returning data in a String, which will be
-- | decoded using the given encoding.
onDataString :: forall w eff. Readable w eff -> Encoding -> (String -> Eff eff Unit) -> Eff eff Unit
onDataString r enc cb = onData r $ \buf -> do
  str <- unsafeInterleaveEff (Buffer.toString enc buf)
  cb str

-- | Listen for `end` events.
foreign import onEnd :: forall w eff. Readable w eff -> Eff eff Unit -> Eff eff Unit

-- | Listen for `close` events.
foreign import onClose :: forall w eff. Readable w eff -> Eff eff Unit -> Eff eff Unit

-- | Listen for `error` events.
foreign import onError :: forall w eff. Readable w eff -> Eff eff Unit -> Eff eff Unit

-- | Resume reading from the stream.
foreign import resume :: forall w eff. Readable w eff -> Eff eff Unit

-- | Pause reading from the stream.
foreign import pause :: forall w eff. Readable w eff -> Eff eff Unit

-- | Check whether or not a stream is paused for reading.
foreign import isPaused :: forall w eff. Readable w eff -> Eff eff Boolean

-- | Read chunks from a readable stream and write them to a writable stream.
foreign import pipe :: forall r w eff. Readable w eff -> Writable r eff -> Eff eff (Writable r eff)

-- | Write a Buffer to a writable stream.
foreign import write :: forall r eff. Writable r eff -> Buffer -> Eff eff Unit -> Eff eff Boolean

foreign import writeStringImpl :: forall r eff. Writable r eff -> String -> String -> Eff eff Unit -> Eff eff Boolean

-- | Write a string in the specified encoding to a writable stream.
writeString :: forall r eff. Writable r eff -> Encoding -> String -> Eff eff Unit -> Eff eff Boolean
writeString w enc = writeStringImpl w (show enc)

-- | Force buffering of writes.
foreign import cork :: forall r eff. Writable r eff -> Eff eff Unit

-- | Flush buffered data.
foreign import uncork :: forall r eff. Writable r eff -> Eff eff Unit

foreign import setDefaultEncodingImpl :: forall r eff. Writable r eff -> String -> Eff eff Unit

-- | Set the default encoding used to write chunks to the stream. This function
-- | is useful when you are passing a writable stream to some other JavaScript
-- | library, which already expects a default encoding to be set. It has no
-- | effect on the behaviour of the `writeString` function (because that
-- | function ensures that the encoding is always supplied explicitly).
setDefaultEncoding :: forall r eff. Writable r eff -> Encoding -> Eff eff Unit
setDefaultEncoding r enc = setDefaultEncodingImpl r (show enc)

-- | End writing data to the stream.
foreign import end :: forall r eff. Writable r eff -> Eff eff Unit -> Eff eff Unit

-- | This module provides a low-level wrapper for the Node Stream API.

module Node.Stream
  ( Stream()
  , Read()
  , Readable()
  , Write()
  , Writable()
  , Duplex()
  , setEncoding
  , onData
  , onEnd
  , onClose
  , onError
  , resume
  , pause
  , isPaused
  , pipe
  , write
  , writeString
  , cork
  , uncork
  , setDefaultEncoding
  , end
  ) where

import Prelude

import Node.Encoding
import Node.Buffer (Buffer())
import Node.Buffer as Buffer

import Control.Monad.Eff
import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)

-- | A stream.
-- |
-- | The type arguments track, in order:
-- |
-- | - Whether reading and/or writing from/to the stream are allowed.
-- | - Effects associated with reading/writing from/to this stream.
foreign import data Stream :: # * -> # ! -> *

-- | A phantom type associated with _readable streams_.
data Read

-- | A readable stream.
type Readable r = Stream (read :: Read | r)

-- | A phantom type associated with _writable streams_.
data Write

-- | A writable stream.
type Writable r = Stream (write :: Write | r)

-- | A duplex (readable _and_ writable stream)
type Duplex = Stream (read :: Read, write :: Write)

foreign import setEncodingImpl :: forall w eff. Readable w eff -> String -> Eff eff Unit

-- | Set the encoding used to read chunks as strings from the stream.
setEncoding :: forall w eff. Readable w eff -> Encoding -> Eff eff Unit
setEncoding r enc = setEncodingImpl r (show enc)

foreign import onDataImpl :: forall w eff a. Readable w eff -> (a -> Eff eff Unit) -> Eff eff Unit

-- | Listen for `data` events, returning data in a Buffer.
onData :: forall w eff. Readable w eff -> (Buffer -> Eff eff Unit) -> Eff eff Unit
onData = onDataImpl

-- | Listen for `data` events, returning data in a String, decoded with the
-- | given encoding.
onDataString :: forall w eff. Readable w eff -> Encoding -> (String -> Eff eff Unit) -> Eff eff Unit
onDataString r enc cb = onData r $ \buf -> do
  str <- unsafeInterleaveEff (Buffer.toString enc buf)
  cb str

-- | Listen for `end` events.
foreign import onEnd :: forall w eff. Readable w eff -> Eff eff Unit -> Eff eff Unit

-- | Listen for `close` events.
foreign import onClose :: forall w eff. Readable w eff -> Eff eff Unit -> Eff eff Unit

-- | Listen for `error` events.
foreign import onError :: forall w eff. Readable w eff -> Eff eff Unit -> Eff eff Unit

-- | Resume reading from the stream.
foreign import resume :: forall w eff. Readable w eff -> Eff eff Unit

-- | Pause reading from the stream.
foreign import pause :: forall w eff. Readable w eff -> Eff eff Unit

-- | Check whether or not a stream is paused for reading.
foreign import isPaused :: forall w eff. Readable w eff -> Eff eff Boolean

-- | Read chunks from a readable stream and write them to a writable stream.
foreign import pipe :: forall r w eff. Readable w eff -> Writable r eff -> Eff eff (Writable r eff)

-- | Write a Buffer to a writable stream.
foreign import write :: forall r eff. Writable r eff -> Buffer -> Eff eff Unit -> Eff eff Boolean

foreign import writeStringImpl :: forall r eff. Writable r eff -> String -> String -> Eff eff Unit -> Eff eff Boolean

-- | Write a string in the specified encoding to a writable stream.
writeString :: forall r eff. Writable r eff -> Encoding -> String -> Eff eff Unit -> Eff eff Boolean
writeString w enc = writeStringImpl w (show enc)

-- | Force buffering of writes.
foreign import cork :: forall r eff. Writable r eff -> Eff eff Unit

-- | Flush buffered data.
foreign import uncork :: forall r eff. Writable r eff -> Eff eff Unit

foreign import setDefaultEncodingImpl :: forall r eff. Writable r eff -> String -> Eff eff Unit

-- | Set the default encoding used to write chunks to the stream. This
setDefaultEncoding :: forall r eff. Writable r eff -> Encoding -> Eff eff Unit
setDefaultEncoding r enc = setDefaultEncodingImpl r (show enc)

-- | End writing data to the stream.
foreign import end :: forall r eff. Writable r eff -> Eff eff Unit -> Eff eff Unit