Move with Home, End, Left arrow, Right arrow when focusing on back / next buttons

-- | A tiny EDSL for creating presentations

module Slides
  ( runSlides
  , mkSlides
  , ui
  , Move()
  , Slides()
  , Slide()
  , Element()
  , (<+>)
  , appendPlus
  , slide
  , empty
  , title
  , text
  , image
  , link
  , valign
  , halign
  , ulist
  , group
  , center
  , withClass
  , withId
  , bold
  , italics
  , underline
  , linethrough
  ) where

import Prelude
import Data.Generic (class Generic, gShow)
import Data.List.Zipper as Z
import Control.Comonad (extract)
import Data.Array ((:), uncons, singleton)
import Data.List (List(..), length)
import Data.Functor (($>))
import Data.Foldable (foldr)
import Data.Maybe (Maybe(..), fromMaybe)
import Control.Monad.Eff (Eff)

import Halogen.HTML (className) as H
import Halogen.HTML.Properties (id_, class_) as H

import Halogen (ComponentDSL, Natural, ComponentHTML, Component, HalogenEffects, component, modify, runUI)
import Halogen.Util (awaitBody, runHalogenAff)
import Halogen.Query (action)
import Halogen.HTML.Indexed (HTML(Element), className, span, li_, ul_, img, text, p, a, h2_, span_, div, button) as Html
import Halogen.HTML.Events.Indexed as Events
import Halogen.HTML.Events.Handler as Events
import Halogen.HTML.Properties.Indexed (class_, src, href) as Html

-------------
-- Running --
-------------

-- | run a component for a presentation
runSlides :: Slides -> Eff (HalogenEffects ()) Unit
runSlides slides = runHalogenAff do
  body <- awaitBody
  runUI ui slides body

-- | Halogen UI component for a presentation
ui :: forall g. Component Slides Move g
ui = component { render, eval }
  where

  render :: Slides -> ComponentHTML Move
  render (Slides state) =
    Html.span []
      [ Html.button [ keyboardEvent, Events.onClick (Events.input_ Back) ] [ Html.text "Back" ]
      , Html.button [ keyboardEvent, Events.onClick (Events.input_ Next) ] [ Html.text "Next" ]
      , Html.span
          [ Html.class_ $ Html.className "counter" ]
          [ Html.text $ show (position state + 1) <> " / " <> show (zipLength state) ]
      , renderSlides (extract state)
      ]

  eval :: Natural Move (ComponentDSL Slides Move g)
  eval move = do
    modify (\(Slides slides) -> Slides $ moveSlides move slides)
    pure (getNext move)

  keyMapping = case _ of
    35.0 -> Events.preventDefault $> map action (Just End) -- End key
    36.0 -> Events.preventDefault $> map action (Just Start) -- Home key
    37.0 -> Events.preventDefault $> map action (Just Back) -- Left Arrow key
    39.0 -> Events.preventDefault $> map action (Just Next) -- Right Arrow key
    _ -> pure Nothing

  keyboardEvent = Events.onKeyPress \e -> keyMapping e.keyCode

data Move a
  = Back a
  | Next a
  | Start a
  | End a

getNext :: forall a. Move a -> a
getNext = case _ of
  Back a -> a
  Next a -> a
  Start a -> a
  End a -> a

moveSlides :: forall a. Move a -> SlidesInternal -> SlidesInternal
moveSlides (Back _) slides =
  fromMaybe slides (Z.up slides)

moveSlides (Next _) slides =
  fromMaybe slides (Z.down slides)

moveSlides (Start _) slides =
  Z.beginning slides

moveSlides (End _) slides =
  Z.end slides

position :: forall a. Z.Zipper a -> Int
position (Z.Zipper b _ _) = length b

zipLength :: forall a. Z.Zipper a -> Int
zipLength (Z.Zipper b _ a) = 1 + length b + length a

-----------
-- Model --
-----------

-- | Slides state for a component
data Slides = Slides SlidesInternal

type SlidesInternal
  = Z.Zipper Slide

-- | A single slide
data Slide
  = Slide Element

-- | A data type defining the AST
data Element
  = Empty
  | Title  String
  | Text   String
  | Image  String
  | Link   String Element
  | HAlign (Array Element)
  | VAlign (Array Element)
  | UList  (Array Element)
  | Group  (Array Element)
  | Class String Element
  | Id    String Element

derive instance genericElement :: Generic Element

-- | A Show instance for testing
instance showElement :: Show Element where
  show = gShow

instance semigroupElement :: Semigroup Element where
  append e1 e2 = Group [e1, e2]

-- | Append two elements with some padding in between
appendPlus :: Element -> Element -> Element
appendPlus e1 e2 = e1 <> Class "padapp" Empty <> e2

-- | Append two elements with some padding in between
infixr 5 appendPlus as <+>

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

-- | Create slides component from an array of slides
mkSlides :: Array Slide -> Slides
mkSlides sl = case uncons sl of
  Just {head, tail} ->
    Slides $ Z.Zipper Nil head (foldr Cons Nil tail)

  Nothing ->
    Slides $ Z.Zipper Nil empty Nil

-- | Create a slide from a title and an element
slide :: String -> Element -> Slide
slide ttl el = Slide (valign [title ttl, el])

-- | An empty slide
empty :: Slide
empty = Slide Empty

-- | A title
title :: String -> Element
title ttl = halign [valign [text ""], Title ttl, valign [text ""]]

-- | Turn an element into a link to url
link :: String -> Element -> Element
link = Link

-- | A text element
text :: String -> Element
text = Text

-- | An image element
image :: String -> Element
image = Image

-- | Group elements as a unit
group :: Array Element -> Element
group = Group

-- | Horizontally align elements in array
halign :: Array Element -> Element
halign = HAlign

-- | Vertically align elements in array
valign :: Array Element -> Element
valign = VAlign

-- | An unordered list of element from an array of elements
ulist :: Array Element -> Element
ulist = UList

-- | Add an Html class to an element
withClass :: String -> Element -> Element
withClass = Class

-- | Add an Html id to an element
withId :: String -> Element -> Element
withId = Id

-- | Position an element at the center of its parent
center :: Element -> Element
center = withClass "center" <<< group <<< singleton

-- | Format text with bold in this element
bold :: Element -> Element
bold = withClass "boldEl" <<< group <<< singleton

-- | Format text with italics in this element
italics :: Element -> Element
italics = withClass "italicsEl" <<< group <<< singleton

-- | Format text with underline in this element
underline :: Element -> Element
underline = withClass "underlineEl" <<< group <<< singleton

-- | Format text with linethrough in this element
linethrough :: Element -> Element
linethrough = withClass "linethroughEl" <<< group <<< singleton

---------------
-- Rendering --
---------------

renderSlides :: forall p i. Slide -> Html.HTML p i
renderSlides (Slide el) =
  Html.div (giveClass "slide") [renderE el]

renderE :: forall p i. Element -> Html.HTML p i
renderE element =
  case element of
    Empty ->
      Html.span_ []

    Title tl ->
      Html.span (giveClass "title") [ Html.h2_ [ Html.text tl ] ]

    Link l el ->
      Html.a [ Html.href l ] [ renderE el ]

    Text str ->
      Html.p marwidStyle [ Html.text str ]

    Image url ->
      Html.img (marwidStyle <> [ Html.src url ])

    VAlign els ->
      Html.span colFlexStyle (applyRest block $ map renderE els)

    HAlign els ->
      Html.span rowFlexStyle (map renderE els)

    UList els ->
      Html.span [] [ Html.ul_ $ map (Html.li_ <<< singleton <<< renderE) els ]

    Group els ->
      Html.span [] $ map renderE els

    Class c e ->
      case renderE e of
        Html.Element nm tn props els ->
          Html.Element nm tn (props <> [ H.class_ $ H.className c ]) els
        el ->
          el

    Id i e ->
      case renderE e of
        Html.Element nm tn props els ->
          Html.Element nm tn (props <> giveId i) els
        el ->
          el

giveClasses = map (Html.class_ <<< Html.className)
giveClass = singleton <<< Html.class_ <<< Html.className
giveId    = singleton <<< H.id_

marwidStyle  = giveClass "marwid"
rowFlexStyle = giveClass "rowflex"
colFlexStyle = giveClass "colflex"

block x = Html.span (giveClass "block") [ x ]

applyRest :: forall a. (a -> a) -> Array a -> Array a
applyRest f xs =
  case uncons xs of
    Nothing -> xs
    Just list -> list.head : map f list.tail

-- | A tiny EDSL for creating presentations

module Slides
  ( runSlides
  , mkSlides
  , ui
  , Move()
  , Slides()
  , Slide()
  , Element()
  , (<+>)
  , appendPlus
  , slide
  , empty
  , title
  , text
  , image
  , link
  , valign
  , halign
  , ulist
  , group
  , center
  , withClass
  , withId
  , bold
  , italics
  , underline
  , linethrough
  ) where

import Prelude
import Data.Generic (class Generic, gShow)
import Data.List.Zipper as Z
import Control.Comonad (extract)
import Data.Array ((:), uncons, singleton)
import Data.List (List(..), length)
import Data.Foldable (foldr)
import Data.Maybe (Maybe(..), fromMaybe)
import Control.Monad.Eff (Eff)

import Halogen.HTML (className) as H
import Halogen.HTML.Properties (id_, class_) as H

import Halogen (ComponentDSL, Natural, ComponentHTML, Component, HalogenEffects, component, modify, runUI)
import Halogen.Util (awaitBody, runHalogenAff)
import Halogen.HTML.Indexed (HTML(Element), className, span, li_, ul_, img, text, p, a, h2_, span_, div, button) as Html
import Halogen.HTML.Events.Indexed as Events
import Halogen.HTML.Properties.Indexed (class_, src, href) as Html

-------------
-- Running --
-------------

-- | run a component for a presentation
runSlides :: Slides -> Eff (HalogenEffects ()) Unit
runSlides slides = runHalogenAff do
  body <- awaitBody
  runUI ui slides body

-- | Halogen UI component for a presentation
ui :: forall g. Component Slides Move g
ui = component { render, eval }
  where

  render :: Slides -> ComponentHTML Move
  render (Slides state) =
    Html.span []
      [ Html.button [ Events.onClick (Events.input_ Back) ] [ Html.text "Back" ]
      , Html.button [ Events.onClick (Events.input_ Next) ] [ Html.text "Next" ]
      , Html.span
          [ Html.class_ $ Html.className "counter" ]
          [ Html.text $ show (position state + 1) <> " / " <> show (zipLength state) ]
      , renderSlides (extract state)
      ]

  eval :: Natural Move (ComponentDSL Slides Move g)
  eval move = do
    modify (\(Slides slides) -> Slides $ moveSlides move slides)
    pure (getNext move)

data Move a
  = Back a
  | Next a
  | Start a
  | End a

getNext :: forall a. Move a -> a
getNext = case _ of
  Back a -> a
  Next a -> a
  Start a -> a
  End a -> a

moveSlides :: forall a. Move a -> SlidesInternal -> SlidesInternal
moveSlides (Back _) slides =
  fromMaybe slides (Z.up slides)

moveSlides (Next _) slides =
  fromMaybe slides (Z.down slides)

moveSlides (Start _) slides =
  Z.beginning slides

moveSlides (End _) slides =
  Z.end slides

position :: forall a. Z.Zipper a -> Int
position (Z.Zipper b _ _) = length b

zipLength :: forall a. Z.Zipper a -> Int
zipLength (Z.Zipper b _ a) = 1 + length b + length a

-----------
-- Model --
-----------

-- | Slides state for a component
data Slides = Slides SlidesInternal

type SlidesInternal
  = Z.Zipper Slide

-- | A single slide
data Slide
  = Slide Element

-- | A data type defining the AST
data Element
  = Empty
  | Title  String
  | Text   String
  | Image  String
  | Link   String Element
  | HAlign (Array Element)
  | VAlign (Array Element)
  | UList  (Array Element)
  | Group  (Array Element)
  | Class String Element
  | Id    String Element

derive instance genericElement :: Generic Element

-- | A Show instance for testing
instance showElement :: Show Element where
  show = gShow

instance semigroupElement :: Semigroup Element where
  append e1 e2 = Group [e1, e2]

-- | Append two elements with some padding in between
appendPlus :: Element -> Element -> Element
appendPlus e1 e2 = e1 <> Class "padapp" Empty <> e2

-- | Append two elements with some padding in between
infixr 5 appendPlus as <+>

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

-- | Create slides component from an array of slides
mkSlides :: Array Slide -> Slides
mkSlides sl = case uncons sl of
  Just {head, tail} ->
    Slides $ Z.Zipper Nil head (foldr Cons Nil tail)

  Nothing ->
    Slides $ Z.Zipper Nil empty Nil

-- | Create a slide from a title and an element
slide :: String -> Element -> Slide
slide ttl el = Slide (valign [title ttl, el])

-- | An empty slide
empty :: Slide
empty = Slide Empty

-- | A title
title :: String -> Element
title ttl = halign [valign [text ""], Title ttl, valign [text ""]]

-- | Turn an element into a link to url
link :: String -> Element -> Element
link = Link

-- | A text element
text :: String -> Element
text = Text

-- | An image element
image :: String -> Element
image = Image

-- | Group elements as a unit
group :: Array Element -> Element
group = Group

-- | Horizontally align elements in array
halign :: Array Element -> Element
halign = HAlign

-- | Vertically align elements in array
valign :: Array Element -> Element
valign = VAlign

-- | An unordered list of element from an array of elements
ulist :: Array Element -> Element
ulist = UList

-- | Add an Html class to an element
withClass :: String -> Element -> Element
withClass = Class

-- | Add an Html id to an element
withId :: String -> Element -> Element
withId = Id

-- | Position an element at the center of its parent
center :: Element -> Element
center = withClass "center" <<< group <<< singleton

-- | Format text with bold in this element
bold :: Element -> Element
bold = withClass "boldEl" <<< group <<< singleton

-- | Format text with italics in this element
italics :: Element -> Element
italics = withClass "italicsEl" <<< group <<< singleton

-- | Format text with underline in this element
underline :: Element -> Element
underline = withClass "underlineEl" <<< group <<< singleton

-- | Format text with linethrough in this element
linethrough :: Element -> Element
linethrough = withClass "linethroughEl" <<< group <<< singleton

---------------
-- Rendering --
---------------

renderSlides :: forall p i. Slide -> Html.HTML p i
renderSlides (Slide el) =
  Html.div (giveClass "slide") [renderE el]

renderE :: forall p i. Element -> Html.HTML p i
renderE element =
  case element of
    Empty ->
      Html.span_ []

    Title tl ->
      Html.span (giveClass "title") [ Html.h2_ [ Html.text tl ] ]

    Link l el ->
      Html.a [ Html.href l ] [ renderE el ]

    Text str ->
      Html.p marwidStyle [ Html.text str ]

    Image url ->
      Html.img (marwidStyle <> [ Html.src url ])

    VAlign els ->
      Html.span colFlexStyle (applyRest block $ map renderE els)

    HAlign els ->
      Html.span rowFlexStyle (map renderE els)

    UList els ->
      Html.span [] [ Html.ul_ $ map (Html.li_ <<< singleton <<< renderE) els ]

    Group els ->
      Html.span [] $ map renderE els

    Class c e ->
      case renderE e of
        Html.Element nm tn props els ->
          Html.Element nm tn (props <> [ H.class_ $ H.className c ]) els
        el ->
          el

    Id i e ->
      case renderE e of
        Html.Element nm tn props els ->
          Html.Element nm tn (props <> giveId i) els
        el ->
          el

giveClasses = map (Html.class_ <<< Html.className)
giveClass = singleton <<< Html.class_ <<< Html.className
giveId    = singleton <<< H.id_

marwidStyle  = giveClass "marwid"
rowFlexStyle = giveClass "rowflex"
colFlexStyle = giveClass "colflex"

block x = Html.span (giveClass "block") [ x ]

applyRest :: forall a. (a -> a) -> Array a -> Array a
applyRest f xs =
  case uncons xs of
    Nothing -> xs
    Just list -> list.head : map f list.tail


simplify initialization

simplify initialization

module Main where

import Prelude hiding (div)
import Control.Monad.Eff (Eff)
import Pux (CoreEffects, EffModel, start)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (button, div, br)
import Text.Smolder.Markup (text, (#!))

data Event = Next | Previous | Restart

type State = Int

initialState :: State
initialState = 1

foldp :: ∀ fx. Event -> State -> EffModel State Event fx
foldp Next s = { state: s + 1, effects: [] }
foldp Previous s  = { state: if s <= 1 then 1 else s - 1, effects: [] }
foldp Restart s = { state: initialState, effects: [] }

view :: State -> HTML Event
view slide =
  div do
    div $ text $ "Slide " <> (show slide)
    br
    button #! onClick (const Previous) $ text "Previous"
    button #! onClick (const Next) $ text "Next"
    button #! onClick (const Restart) $ text "Restart"

main :: ∀ fx. Eff (CoreEffects fx) Unit
main = do
  app <- start
    { initialState
    , view
    , foldp
    , inputs: []
    }
  renderToDOM "#app" app.markup app.input

module Main where

import Prelude hiding (div)
import Control.Monad.Eff (Eff)
import Pux (CoreEffects, EffModel, start)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (button, div, br)
import Text.Smolder.Markup (text, (#!))

data Event = Next | Previous | Restart

type State = Int

initial :: State
initial = 1

foldp :: ∀ fx. Event -> State -> EffModel State Event fx
foldp Next s = { state: s + 1, effects: [] }
foldp Previous s  = { state: if s <= 1 then 1 else s - 1, effects: [] }
foldp Restart s = { state: initial, effects: [] }

view :: State -> HTML Event
view slide =
  div do
    div $ text $ "Slide " <> (show slide)
    br
    button #! onClick (const Previous) $ text "Previous"
    button #! onClick (const Next) $ text "Next"
    button #! onClick (const Restart) $ text "Restart"

main :: ∀ fx. Eff (CoreEffects fx) Unit
main = do
  app <- start
    { initialState: initial
    , view
    , foldp
    , inputs: []
    }
  renderToDOM "#app" app.markup app.input


get rid of ADT 'Expression' -> use of Json directly (same meaning)

module Ifrit.Drivers.MongoDB
  ( class Ingest
  , ingest
  ) where

import Prelude
import Data.Argonaut.Core(Json)
import Data.Argonaut.Encode(encodeJson, (:=))
import Data.StrMap(fromFoldable) as M
import Data.List(fromFoldable) as L
import Data.Tuple(Tuple(..))
import Ifrit.Core(Stage(..), Reduce(..), Map(..), Terminal(..))

-- CLASSES

class Ingest stage where
  ingest :: stage -> Json

-- UTILITIES

object :: Array (Tuple String Json) -> Json
object = M.fromFoldable >>> encodeJson

singleton :: String -> Json -> Json
singleton k x = object [Tuple k x]

list :: Array Json -> Json
list = L.fromFoldable >>> encodeJson

selector :: Terminal -> Json
selector (Field f) = encodeJson ("$$this." <> f)
selector (ConstantString c) = encodeJson c
selector (ConstantBoolean c) = encodeJson c
selector (ConstantNumber c) = encodeJson c

-- INSTANCES :: ingest

instance ingestStage :: Ingest Stage where
  ingest (Map m) =
    singleton "$project" $ encodeJson (map ingest m)

instance ingestMapOperator :: Ingest Map where
  ingest (Project t) =
    ingest t
  ingest (Inject src (Avg target)) =
    let
      src' = ingest src
      sum = list
        [ encodeJson "$$value"
        , selector target
        ]
      reduce = object
        [ "input" := src'
        , "initialValue" := (encodeJson 0.0)
        , "in" := (singleton "$add" sum)
        ]
      divide = list
        [ singleton "$reduce" reduce
        , singleton "$size" src'
        ]
    in
      singleton "$divide" divide

instance ingestReduce :: Ingest Reduce where
  ingest (Avg t) =
    singleton "$avg" $ ingest t

instance ingestTerminal :: Ingest Terminal where
  ingest (Field f) =
    encodeJson $ "$" <> f
  ingest (ConstantString c) =
    encodeJson  c
  ingest (ConstantBoolean c) =
    encodeJson c
  ingest (ConstantNumber c) =
    encodeJson c

instance ingestArray :: Ingest a => Ingest (Array a) where
  ingest =
    L.fromFoldable >>> map ingest >>> encodeJson

module Ifrit.Drivers.MongoDB
  ( class Ingest
  , Expression(..)
  , ingest
  ) where

import Prelude
import Data.Argonaut.Core(Json, stringify)
import Data.Argonaut.Encode(class EncodeJson, encodeJson)
import Data.StrMap(StrMap)
import Data.StrMap(fromFoldable) as M
import Data.List(List)
import Data.List(fromFoldable) as L
import Data.Tuple(Tuple(..))
import Ifrit.Core(Stage(..), Reduce(..), Map(..), Terminal(..))

-- CLASSES

class Ingest stage where
  ingest :: stage -> Expression

-- TYPES

data Expression
  = ValueString String
  | ValueBoolean Boolean
  | ValueNumber Number
  | Object (StrMap Expression)
  | List (List Expression)

str :: String -> Expression
str s = ValueString s

bool :: Boolean -> Expression
bool b = ValueBoolean b

number :: Number -> Expression
number n = ValueNumber n

object :: Array (Tuple String Expression) -> Expression
object xs = Object $ M.fromFoldable xs

singleton :: String -> Expression -> Expression
singleton k x = Object $ M.fromFoldable [Tuple k x]

list :: Array Expression -> Expression
list xs = List $ L.fromFoldable xs

infix 7 Tuple as :-

-- UTILITIES

selector :: Terminal -> Expression
selector (Field f) = str ("$$this." <> f)
selector (ConstantString c) = str c
selector (ConstantBoolean c) = bool c
selector (ConstantNumber c) = number c

-- INSTANCES :: ingest

instance ingestStage :: Ingest Stage where
  ingest (Map m) =
    singleton "$project" $ Object (map ingest m)

instance ingestMapOperator :: Ingest Map where
  ingest (Project t) =
    ingest t
  ingest (Inject src (Avg target)) =
    let
      src' = ingest src
      sum = list
        [ str "$$value"
        , selector target
        ]
      reduce = object
        [ "input" :- src'
        , "initialValue" :- (number 0.0)
        , "in" :- (singleton "$add" sum)
        ]
      divide = list
        [ singleton "$reduce" reduce
        , singleton "$size" src'
        ]
    in
      singleton "$divide" divide

instance ingestReduce :: Ingest Reduce where
  ingest (Avg t) =
    singleton "$avg" $ ingest t

instance ingestTerminal :: Ingest Terminal where
  ingest (Field f) =
    ValueString $ "$" <> f
  ingest (ConstantString c) =
    ValueString c
  ingest (ConstantBoolean c) =
    ValueBoolean c
  ingest (ConstantNumber c) =
    ValueNumber c

instance ingestArray :: Ingest a => Ingest (Array a) where
  ingest =
    L.fromFoldable >>> map ingest >>> List

-- INSTANCE :: ENCODEJSON

instance encodeJsonExpression :: (EncodeJson String, EncodeJson Int, EncodeJson (StrMap Json), EncodeJson (List Json))
  => EncodeJson Expression where
  encodeJson (ValueString s) =
    encodeJson s
  encodeJson (ValueBoolean b) =
    encodeJson b
  encodeJson (ValueNumber n) =
    encodeJson n
  encodeJson (Object m) =
    encodeJson $ encodeJson <$> m
  encodeJson (List xs) =
    encodeJson $ encodeJson <$> xs

-- INSTANCE :: SHOW

instance showExpression :: EncodeJson Expression => Show Expression where
  show = encodeJson >>> stringify


Fix the type signature for addEventListener

The function addEventListener defines an effect that returns nothing.
Reflecting that in the type signature.

module Control.Monad.Eff.DOM where

import Data.Maybe
import Data.Foreign
import Data.Function

import Control.Monad.Eff

foreign import data DOM :: !

foreign import data Node :: *

--
-- Creating Nodes
--

foreign import body
  "function body() {\
  \  return document.body;\
  \}" :: forall eff. Eff (dom :: DOM | eff) Node

foreign import createElement
  "function createElement(name) {\
  \  return function() {\
  \    return document.createElement(name);\
  \  };\
  \}" :: forall eff. String -> Eff (dom :: DOM | eff) Node

--
-- Selector Functions
--

foreign import querySelectorImpl
  "function querySelectorImpl(r, f, s) {\
  \  return function() {\
  \    var result = document.querySelector(s);\
  \    return result ? f(result) : r;\
  \  };\
  \}" :: forall eff r. Fn3 r (Node -> r) String (Eff (dom :: DOM | eff) r)

querySelector :: forall eff. String -> Eff (dom :: DOM | eff) (Maybe Node)
querySelector s = runFn3 querySelectorImpl Nothing Just s

--
-- Append
--

foreign import appendChild
  "function appendChild(child) {\
  \  return function(node) {\
  \    return function() {\
  \      node.appendChild(child);\
  \      return node;\
  \    };\
  \  };\
  \}" :: forall eff. Node -> Node -> Eff (dom :: DOM | eff) Node

--
-- Styles
--

foreign import addClass
  "function addClass(className) {\
  \  return function(node) {\
  \    return function() {\
  \      node.classList.add(className);\
  \      return node;\
  \    };\
  \  };\
  \}" :: forall eff. String -> Node -> Eff (dom :: DOM | eff) Node

--
-- Properties
--

foreign import setText
  "function setText(text) {\
  \  return function(node) {\
  \    return function() {\
  \      node.textContent = text;\
  \      return node;\
  \    };\
  \  };\
  \}" :: forall eff. String -> Node -> Eff (dom :: DOM | eff) Node

foreign import getValue
  "function getValue(node) {\
  \  return function() {\
  \    return node.value;\
  \  };\
  \}" :: forall eff. Node -> Eff (dom :: DOM | eff) Foreign

foreign import setValue
  "function setValue(value) {\
  \  return function(node) {\
  \    return function() {\
  \      node.value = value;\
  \      return node;\
  \    };\
  \  };\
  \}" :: forall a eff. a -> Node -> Eff (dom :: DOM | eff) Node

foreign import setInnerHTML
  "function setInnerHTML(html) {\
  \  return function(node) {\
  \    return function() {\
  \      node.innerHTML = html;\
  \      return node;\
  \    };\
  \  };\
  \}" :: forall eff. String -> Node -> Eff (dom :: DOM | eff) Node

--
-- Events
--

foreign import addEventListener
  "function addEventListener(name) {\
  \  return function(handler) {\
  \    return function(node) {\
  \      return function() {\
  \        node.addEventListener(name, function(e) {\
  \          handler();\
  \          e.preventDefault();\
  \        });\
  \      };\
  \    };\
  \  };\
  \}" :: forall eff. String -> Eff (dom :: DOM | eff) Unit -> Node -> Eff (dom :: DOM | eff) Unit

module Control.Monad.Eff.DOM where

import Data.Maybe
import Data.Foreign
import Data.Function

import Control.Monad.Eff

foreign import data DOM :: !

foreign import data Node :: *

--
-- Creating Nodes
--

foreign import body
  "function body() {\
  \  return document.body;\
  \}" :: forall eff. Eff (dom :: DOM | eff) Node

foreign import createElement
  "function createElement(name) {\
  \  return function() {\
  \    return document.createElement(name);\
  \  };\
  \}" :: forall eff. String -> Eff (dom :: DOM | eff) Node

--
-- Selector Functions
--

foreign import querySelectorImpl
  "function querySelectorImpl(r, f, s) {\
  \  return function() {\
  \    var result = document.querySelector(s);\
  \    return result ? f(result) : r;\
  \  };\
  \}" :: forall eff r. Fn3 r (Node -> r) String (Eff (dom :: DOM | eff) r)

querySelector :: forall eff. String -> Eff (dom :: DOM | eff) (Maybe Node)
querySelector s = runFn3 querySelectorImpl Nothing Just s

--
-- Append
--

foreign import appendChild
  "function appendChild(child) {\
  \  return function(node) {\
  \    return function() {\
  \      node.appendChild(child);\
  \      return node;\
  \    };\
  \  };\
  \}" :: forall eff. Node -> Node -> Eff (dom :: DOM | eff) Node

--
-- Styles
--

foreign import addClass
  "function addClass(className) {\
  \  return function(node) {\
  \    return function() {\
  \      node.classList.add(className);\
  \      return node;\
  \    };\
  \  };\
  \}" :: forall eff. String -> Node -> Eff (dom :: DOM | eff) Node

--
-- Properties
--

foreign import setText
  "function setText(text) {\
  \  return function(node) {\
  \    return function() {\
  \      node.textContent = text;\
  \      return node;\
  \    };\
  \  };\
  \}" :: forall eff. String -> Node -> Eff (dom :: DOM | eff) Node

foreign import getValue
  "function getValue(node) {\
  \  return function() {\
  \    return node.value;\
  \  };\
  \}" :: forall eff. Node -> Eff (dom :: DOM | eff) Foreign

foreign import setValue
  "function setValue(value) {\
  \  return function(node) {\
  \    return function() {\
  \      node.value = value;\
  \      return node;\
  \    };\
  \  };\
  \}" :: forall a eff. a -> Node -> Eff (dom :: DOM | eff) Node

foreign import setInnerHTML
  "function setInnerHTML(html) {\
  \  return function(node) {\
  \    return function() {\
  \      node.innerHTML = html;\
  \      return node;\
  \    };\
  \  };\
  \}" :: forall eff. String -> Node -> Eff (dom :: DOM | eff) Node

--
-- Events
--

foreign import addEventListener
  "function addEventListener(name) {\
  \  return function(handler) {\
  \    return function(node) {\
  \      return function() {\
  \        node.addEventListener(name, function(e) {\
  \          handler();\
  \          e.preventDefault();\
  \        });\
  \      };\
  \    };\
  \  };\
  \}" :: forall eff. String -> Eff (dom :: DOM | eff) Unit -> Node -> Eff (dom :: DOM | eff) Node


calculate fleet's actual cost

calculate fleet's actual cost

module KanColle.Expedition.New.Types
  ( module KanColle.Expedition.New.SType
  , module KanColle.Expedition.New.Item
  , FleetCompo
  , MinFleetCompo
  , FleetMaxCost
  , Info
  , ItemInfo
  , MaxCost(..)
  , mkMC
  , CostModel
  ) where

import Prelude
import Data.Maybe
import KanColle.Expedition.New.SType
import KanColle.Expedition.New.Item
import Data.Map as M
import Data.Tuple
import Data.Traversable
import Data.Int

-- Nothing: ship type not specified
-- Just <stype>: must be of ship type <stype>
type MinFleetCompo = Array (Maybe SType)
type FleetCompo = Array SType
type FleetMaxCost = Array MaxCost

type Info =
  { id :: Int
  , timeInMin :: Int
  , fuelCostPercent :: Number
  , ammoCostPercent :: Number
  , item1 :: Maybe ItemInfo
  , item2 :: Maybe ItemInfo
  }

type ItemInfo =
  { item :: Item
  , maxCount :: Int
  }

newtype MaxCost = MCost
  { fuel :: Int
  , ammo :: Int
  }

newtype ActualCost = ACost
  { fuel :: Int
  , ammo :: Int
  }

newtype FleetActualCost = FACost
  { fuel :: Int
  , ammo :: Int
  }

mkMC :: Int -> Int -> MaxCost
mkMC fuel ammo = MCost {fuel: fuel, ammo: ammo}

-- | `CostModel` calculates the total maximum cost
-- | given a ship type and how many ships are present.
-- | This cost model is designed for just one fleet so
-- | the input number should only be one of `[0,1,2,3,4,5,6]`.
-- | Note that for a cost model `f`, it's not guaranteed
-- | that `f stype a + f stype b` and `f stype (a+b)` give
-- | the same answer.
type CostModel = SType -> Int -> Maybe (Array MaxCost)

calcFleetMaxCost :: CostModel -> FleetCompo -> Maybe FleetMaxCost
calcFleetMaxCost cm fcAr = fold <$> sequence compos
  where
    fc :: M.Map SType Int
    fc = M.fromFoldableWith (+) (map (\x -> Tuple x 1) fcAr)
    compos = map (\(Tuple sty cnt) -> cm sty cnt) (M.toList fc)

calcActualCost :: MaxCost -> Info -> ActualCost
calcActualCost (MCost mc) info = ACost
    { fuel: floor (info.fuelCostPercent * toNumber mc.fuel)
    , ammo: floor (info.ammoCostPercent * toNumber mc.ammo)
    }

calcFleetActualCost :: FleetMaxCost -> Info -> FleetActualCost
calcFleetActualCost fmc info = FACost (foldl merge z fmc)
  where
    z = {fuel: 0, ammo: 0}
    merge acc mc = case calcActualCost mc info of
      (ACost actual) ->
        {fuel: acc.fuel+actual.fuel, ammo: acc.ammo+actual.ammo}

module KanColle.Expedition.New.Types
  ( module KanColle.Expedition.New.SType
  , module KanColle.Expedition.New.Item
  , FleetCompo
  , MinFleetCompo
  , FleetMaxCost
  , Info
  , ItemInfo
  , MaxCost(..)
  , mkMC
  , CostModel
  ) where

import Prelude
import Data.Maybe
import KanColle.Expedition.New.SType
import KanColle.Expedition.New.Item
import Data.Map as M
import Data.Tuple
import Data.Traversable
import Data.Int

-- Nothing: ship type not specified
-- Just <stype>: must be of ship type <stype>
type MinFleetCompo = Array (Maybe SType)
type FleetCompo = Array SType
type FleetMaxCost = Array MaxCost

type Info =
  { id :: Int
  , timeInMin :: Int
  , fuelCostPercent :: Number
  , ammoCostPercent :: Number
  , item1 :: Maybe ItemInfo
  , item2 :: Maybe ItemInfo
  }

type ItemInfo =
  { item :: Item
  , maxCount :: Int
  }

newtype MaxCost = MCost
  { fuel :: Int
  , ammo :: Int
  }

newtype ActualCost = ACost
  { fuel :: Int
  , ammo :: Int
  }

mkMC :: Int -> Int -> MaxCost
mkMC fuel ammo = MCost {fuel: fuel, ammo: ammo}

-- | `CostModel` calculates the total maximum cost
-- | given a ship type and how many ships are present.
-- | This cost model is designed for just one fleet so
-- | the input number should only be one of `[0,1,2,3,4,5,6]`.
-- | Note that for a cost model `f`, it's not guaranteed
-- | that `f stype a + f stype b` and `f stype (a+b)` give
-- | the same answer.
type CostModel = SType -> Int -> Maybe (Array MaxCost)

calcFleetMaxCost :: CostModel -> FleetCompo -> Maybe FleetMaxCost
calcFleetMaxCost cm fcAr = fold <$> sequence compos
  where
    fc :: M.Map SType Int
    fc = M.fromFoldableWith (+) (map (\x -> Tuple x 1) fcAr)
    compos = map (\(Tuple sty cnt) -> cm sty cnt) (M.toList fc)

calcActualCost :: MaxCost -> Info -> ActualCost
calcActualCost (MCost mc) info = ACost
    { fuel: floor (info.fuelCostPercent * toNumber mc.fuel)
    , ammo: floor (info.ammoCostPercent * toNumber mc.ammo)
    }


Fix a typo in documentation.

Fix a typo in documentation.

module Data.Functor
  ( class Functor, map, (<$>)
  , mapFlipped, (<#>)
  , void
  , voidRight, (<$)
  , voidLeft, ($>)
  , flap, (<@>)
  ) where

import Data.Function (const, compose)
import Data.Unit (Unit, unit)

-- | A `Functor` is a type constructor which supports a mapping operation
-- | `(<$>)`.
-- |
-- | `(<$>)` can be used to turn functions `a -> b` into functions
-- | `f a -> f b` whose argument and return types use the type constructor `f`
-- | to represent some computational context.
-- |
-- | Instances must satisfy the following laws:
-- |
-- | - Identity: `(<$>) id = id`
-- | - Composition: `(<$>) (f <<< g) = (f <$>) <<< (g <$>)`
class Functor f where
  map :: forall a b. (a -> b) -> f a -> f b

infixl 4 map as <$>

-- | `mapFlipped` is `map` with its arguments reversed. For example:
-- |
-- | ```purescript
-- | [1, 2, 3] <#> \n -> n * n
-- | ```
mapFlipped :: forall f a b. Functor f => f a -> (a -> b) -> f b
mapFlipped fa f = f <$> fa

infixl 1 mapFlipped as <#>

instance functorFn :: Functor ((->) r) where
  map = compose

instance functorArray :: Functor Array where
  map = arrayMap

foreign import arrayMap :: forall a b. (a -> b) -> Array a -> Array b

-- | The `void` function is used to ignore the type wrapped by a
-- | [`Functor`](#functor), replacing it with `Unit` and keeping only the type
-- | information provided by the type constructor itself.
-- |
-- | `void` is often useful when using `do` notation to change the return type
-- | of a monadic computation:
-- |
-- | ```purescript
-- | main = forE 1 10 \n -> void do
-- |   print n
-- |   print (n * n)
-- | ```
void :: forall f a. Functor f => f a -> f Unit
void = map (const unit)

-- | Ignore the return value of a computation, using the specified return value
-- | instead.
voidRight :: forall f a b. Functor f => a -> f b -> f a
voidRight x = map (const x)

infixl 4 voidRight as <$

-- | A version of `voidRight` with its arguments flipped.
voidLeft :: forall f a b. Functor f => f a -> b -> f b
voidLeft f x = const x <$> f

infixl 4 voidLeft as $>

-- | Apply a value in a computational context to a value in no context.
-- |
-- | Generalizes `flip`.
-- |
-- | ```purescript
-- | longEnough :: String -> Bool
-- | hasSymbol :: String -> Bool
-- | hasDigit :: String -> Bool
-- | password :: String
-- |
-- | validate :: String -> List Bool
-- | validate = flap [longEnough, hasSymbol, hasDigit]
-- | ```
-- |
-- | ```purescript
-- | flap (-) 3 4 == 1
-- | threeve <$> Just 1 <@> 'a' <*> Just true == Just (threeve 1 'a' true)
-- | ```
flap :: forall f a b. Functor f => f (a -> b) -> a -> f b
flap ff x = map (\f -> f x) ff

infixl 4 flap as <@>

module Data.Functor
  ( class Functor, map, (<$>)
  , mapFlipped, (<#>)
  , void
  , voidRight, (<$)
  , voidLeft, ($>)
  , flap, (<@>)
  ) where

import Data.Function (const, compose)
import Data.Unit (Unit, unit)

-- | A `Functor` is a type constructor which supports a mapping operation
-- | `(<$>)`.
-- |
-- | `(<$>)` can be used to turn functions `a -> b` into functions
-- | `f a -> f b` whose argument and return types use the type constructor `f`
-- | to represent some computational context.
-- |
-- | Instances must satisfy the following laws:
-- |
-- | - Identity: `(<$>) id = id`
-- | - Composition: `(<$>) (f <<< g) = (f <$>) <<< (g <$>)`
class Functor f where
  map :: forall a b. (a -> b) -> f a -> f b

infixl 4 map as <$>

-- | `mapFlipped` is `map` with its arguments reversed. For example:
-- |
-- | ```purescript
-- | [1, 2, 3] <#> \n -> n * n
-- | ```
mapFlipped :: forall f a b. Functor f => f a -> (a -> b) -> f b
mapFlipped fa f = f <$> fa

infixl 1 mapFlipped as <#>

instance functorFn :: Functor ((->) r) where
  map = compose

instance functorArray :: Functor Array where
  map = arrayMap

foreign import arrayMap :: forall a b. (a -> b) -> Array a -> Array b

-- | The `void` function is used to ignore the type wrapped by a
-- | [`Functor`](#functor), replacing it with `Unit` and keeping only the type
-- | information provided by the type constructor itself.
-- |
-- | `void` is often useful when using `do` notation to change the return type
-- | of a monadic computation:
-- |
-- | ```purescript
-- | main = forE 1 10 \n -> void do
-- |   print n
-- |   print (n * n)
-- | ```
void :: forall f a. Functor f => f a -> f Unit
void = map (const unit)

-- | Ignore the return value of a computation, using the specified return value
-- | instead.
voidRight :: forall f a b. Functor f => a -> f b -> f a
voidRight x = map (const x)

infixl 4 voidRight as <$

-- | A version of `voidLast` with its arguments flipped.
voidLeft :: forall f a b. Functor f => f a -> b -> f b
voidLeft f x = const x <$> f

infixl 4 voidLeft as $>

-- | Apply a value in a computational context to a value in no context.
-- |
-- | Generalizes `flip`.
-- |
-- | ```purescript
-- | longEnough :: String -> Bool
-- | hasSymbol :: String -> Bool
-- | hasDigit :: String -> Bool
-- | password :: String
-- |
-- | validate :: String -> List Bool
-- | validate = flap [longEnough, hasSymbol, hasDigit]
-- | ```
-- |
-- | ```purescript
-- | flap (-) 3 4 == 1
-- | threeve <$> Just 1 <@> 'a' <*> Just true == Just (threeve 1 'a' true)
-- | ```
flap :: forall f a b. Functor f => f (a -> b) -> a -> f b
flap ff x = map (\f -> f x) ff

infixl 4 flap as <@>


don't mix tabs and spaces

don't mix tabs and spaces

module Models.State where

import Data.Maybe

import Models.Channel
import Models.Input
import Models.Message
import Models.User

type State =
    { messages :: [ Message ]
    --, editText :: String
    , user :: Maybe User
    , channels :: [ Channel ]
    , selectedChannel :: Maybe Channel
    --, selectedInputType :: InputType
    }

emptyState :: State
emptyState =
    { messages: []
    , user: Nothing
    , channels: []
    , selectedChannel: Nothing
    }


s/psc-bundle/purs bundle/

s/psc-bundle/purs bundle/

-- | Global objects exposed by Node.js. See also the [Node.js API
-- | documentation](https://nodejs.org/api/globals.html).
module Node.Globals where

import Effect (Effect)

-- | The name of the directory that the currently executing script resides in.
-- |
-- | Note that this will probably not give you a very useful answer unless you
-- | have bundled up your PureScript code using `purs bundle`!
foreign import __dirname :: String

-- | The absolute path of the code file being executed.
-- |
-- | Note that this will probably not give you a very useful answer unless you
-- | have bundled up your PureScript code using `purs bundle`!
foreign import __filename :: String

-- | Just calls `require`. You might also consider using the FFI instead. This
-- | function is, in general, horribly unsafe, and may perform side effects.
foreign import unsafeRequire :: forall a. String -> a

-- | `require.resolve()`. Use the internal `require` machinery to look up the
-- | location of a module, but rather than loading the module, just return the
-- | resolved filename.
foreign import requireResolve :: String -> Effect String

-- | Global objects exposed by Node.js. See also the [Node.js API
-- | documentation](https://nodejs.org/api/globals.html).
module Node.Globals where

import Effect (Effect)

-- | The name of the directory that the currently executing script resides in.
-- |
-- | Note that this will probably not give you a very useful answer unless you
-- | have bundled up your PureScript code using `psc-bundle`!
foreign import __dirname :: String

-- | The absolute path of the code file being executed.
-- |
-- | Note that this will probably not give you a very useful answer unless you
-- | have bundled up your PureScript code using `psc-bundle`!
foreign import __filename :: String

-- | Just calls `require`. You might also consider using the FFI instead. This
-- | function is, in general, horribly unsafe, and may perform side effects.
foreign import unsafeRequire :: forall a. String -> a

-- | `require.resolve()`. Use the internal `require` machinery to look up the
-- | location of a module, but rather than loading the module, just return the
-- | resolved filename.
foreign import requireResolve :: String -> Effect String


Add StringLiteral and Word parsers

Add StringLiteral and Word parsers

module Docopt.Parser.Lexer where

import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import Control.Monad.State (State(), evalState, get)
import Control.Monad.Trans
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Token as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import qualified Data.List as L
import qualified Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray, fromChar)
import Data.List (List(..), (:), fromList, many)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Docopt.Parser.Base
import Docopt.Parser.State
import Data.Tuple

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | LAngle
  | RAngle
  | Dash
  | VBar
  | Colon
  | Comma
  | Equal
  | TripleDot
  | LOpt String
  | SOpt Char (List Char) String
  | ShoutName String
  | AngleName String
  | Name String
  | Word String
  | StringLiteral String
  | Garbage Char

prettyPrintToken :: Token -> String
prettyPrintToken LParen            = show '('
prettyPrintToken RParen            = show ')'
prettyPrintToken LSquare           = show '['
prettyPrintToken RSquare           = show ']'
prettyPrintToken LAngle            = show '<'
prettyPrintToken RAngle            = show '>'
prettyPrintToken Dash              = show '-'
prettyPrintToken VBar              = show '|'
prettyPrintToken Colon             = show ':'
prettyPrintToken Comma             = show ','
prettyPrintToken Equal             = show '='
prettyPrintToken TripleDot         = show "..."
prettyPrintToken (Garbage   c)     = "Garbage "   ++ show c
prettyPrintToken (Name      n)     = "Name "      ++ show n
prettyPrintToken (ShoutName n)     = "ShoutName " ++ show n
prettyPrintToken (AngleName n)     = "AngleName " ++ show n
prettyPrintToken (StringLiteral s) = "StrLit " ++ show s
prettyPrintToken (Word w)          = "Word " ++ show w
prettyPrintToken (LOpt n)          = "LOpt --" ++ n
prettyPrintToken (SOpt n s a)      =
  "SOpt -"
    ++ (fromChar n)
    ++ (fromCharArray $ fromList s)
    ++ a

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

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

instance eqToken :: Eq Token where
  eq LParen            LParen             = true
  eq RParen            RParen             = true
  eq LSquare           LSquare            = true
  eq RSquare           RSquare            = true
  eq LAngle            LAngle             = true
  eq RAngle            RAngle             = true
  eq VBar              VBar               = true
  eq Colon             Colon              = true
  eq Comma             Comma              = true
  eq Dash              Dash               = true
  eq Equal             Equal              = true
  eq TripleDot         TripleDot          = true
  eq (LOpt n)          (LOpt n')          = (n == n')
  eq (SOpt n s a)      (SOpt n' s' a')    = (n == n') && (s' == s') && (a == a')
  eq (StringLiteral s) (StringLiteral s') = s == s'
  eq (AngleName n)     (AngleName n')     = n == n'
  eq (ShoutName n)     (ShoutName n')     = n == n'
  eq (Word w)          (Word w')          = w == w'
  eq (Name n)          (Name n')          = n == n'
  eq (Garbage c)       (Garbage c')       = c == c'
  eq _ _                                  = false

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

parseTokens :: P.Parser String (L.List PositionedToken)
parseTokens = do
  P.skipSpaces
  L.many parsePositionedToken
  <* P.eof

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

parseToken :: P.Parser String Token
parseToken = P.choice
  [ P.try $ P.char   '('   *> pure LParen
  , P.try $ P.char   ')'   *> pure RParen
  , P.try $ P.char   '['   *> pure LSquare
  , P.try $ P.char   ']'   *> pure RSquare
  , P.try $ P.char   '|'   *> pure VBar
  , P.try $ P.char   ':'   *> pure Colon
  , P.try $ P.char   ','   *> pure Comma
  , P.try $ parseLongOption
  , P.try $ (parseShortOption <* spaceOrEOF)
  , P.try $ AngleName <$> parseAngleName
  , P.try $ P.char   '<'   *> pure LAngle
  , P.try $ P.char   '>'   *> pure RAngle
  , P.try $ P.char   '-'   *> pure Dash
  , P.try $ P.char   '='   *> pure Equal
  , P.try $ P.string "..." *> pure TripleDot
  , P.try $ parseStringLiteral
  , P.try $ ShoutName <$> (parseShoutName <* P.notFollowedBy foo)
  , P.try $ Word      <$> (parseWord      <* P.notFollowedBy foo)
  , P.try $ Name      <$> (parseName      <* P.notFollowedBy foo)
  , P.try $ Garbage   <$> P.anyChar
  ] <* P.skipSpaces

 where

  foo :: P.Parser String Unit
  foo = do
    regex "[a-zA-Z]"
    pure unit

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

  spaceOrEOF :: P.Parser String Unit
  spaceOrEOF = P.choice [ whitespace, P.eof ]

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

  parseName :: P.Parser String String
  parseName = fromCharArray <$> do
    A.cons
      <$> identStart
      <*> A.many identLetter

  parseWord :: P.Parser String String
  parseWord = fromCharArray <$> do
    A.cons
      <$> identStart
      <*> (A.many $ P.choice [
        identLetter
      , P.oneOf [ '.', '-', '_' ]
      ])

  parseAngleName :: P.Parser String String
  parseAngleName =
    P.char '<' *> parseName <* P.char '>'

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

  parseShortOption :: P.Parser String Token
  parseShortOption =
    P.char '-' *> do
      SOpt
        <$> lowerAlphaNum
        <*> (many lowerAlphaNum)
        <*> (fromCharArray <$> (A.many upperAlphaNum))

  parseLongOption :: P.Parser String Token
  parseLongOption =
    P.string "--" *> do
      LOpt <$> parseName

  identStart :: P.Parser String Char
  identStart = alpha

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

  flag :: P.Parser String Char
  flag = lowerAlphaNum

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

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

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

anyToken = token $ Just

eof = P.notFollowedBy anyToken

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

langle :: TokenParser Unit
langle = match LAngle

rangle :: TokenParser Unit
rangle = match RAngle

dash :: TokenParser Unit
dash = match Dash

vbar :: TokenParser Unit
vbar = match VBar

comma :: TokenParser Unit
comma = match Comma

colon :: TokenParser Unit
colon = match Colon

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

equal :: TokenParser Unit
equal = match Equal

lopt :: TokenParser String
lopt = token go P.<?> "long-option"
  where
    go (LOpt n) = Just n
    go _        = Nothing

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

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

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

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

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

module Docopt.Parser.Lexer where

import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import Control.Monad.State (State(), evalState, get)
import Control.Monad.Trans
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Token as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import qualified Data.List as L
import qualified Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray, fromChar)
import Data.List (List(..), (:), fromList, many)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Docopt.Parser.Base
import Docopt.Parser.State
import Data.Tuple

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | LAngle
  | RAngle
  | Dash
  | VBar
  | Colon
  | Comma
  | Equal
  | TripleDot
  | LOpt String
  | SOpt Char (List Char) String
  | ShoutName String
  | AngleName String
  | Name      String
  | Garbage   Char

prettyPrintToken :: Token -> String
prettyPrintToken LParen        = show '('
prettyPrintToken RParen        = show ')'
prettyPrintToken LSquare       = show '['
prettyPrintToken RSquare       = show ']'
prettyPrintToken LAngle        = show '<'
prettyPrintToken RAngle        = show '>'
prettyPrintToken Dash          = show '-'
prettyPrintToken VBar          = show '|'
prettyPrintToken Colon         = show ':'
prettyPrintToken Comma         = show ','
prettyPrintToken Equal         = show '='
prettyPrintToken TripleDot     = show "..."
prettyPrintToken (Garbage   c) = "Garbage "   ++ show c
prettyPrintToken (Name      n) = "Name "      ++ show n
prettyPrintToken (ShoutName n) = "ShoutName " ++ show n
prettyPrintToken (AngleName n) = "AngleName " ++ show n
prettyPrintToken (LOpt n)      = show $ "--" ++ n
prettyPrintToken (SOpt n s a)  =
  show $ "-"
    ++ (fromChar n)
    ++ (fromCharArray $ fromList s)
    ++ a

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

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

instance eqToken :: Eq Token where
  eq LParen        LParen           = true
  eq RParen        RParen           = true
  eq LSquare       LSquare          = true
  eq RSquare       RSquare          = true
  eq LAngle        LAngle           = true
  eq RAngle        RAngle           = true
  eq VBar          VBar             = true
  eq Colon         Colon            = true
  eq Comma         Comma            = true
  eq Dash          Dash             = true
  eq Equal         Equal            = true
  eq TripleDot     TripleDot        = true
  eq (AngleName n) (AngleName n')   = n == n'
  eq (ShoutName n) (ShoutName n')   = n == n'
  eq (Garbage c)   (Garbage c')     = c == c'
  eq (Name n)      (Name n')        = n == n'
  eq (LOpt n)      (LOpt n')        = (n == n')
  eq (SOpt n ns a) (SOpt n' ns' a') = (n == n') && (ns' == ns') && (a == a')
  eq _ _                            = false

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

parseTokens :: P.Parser String (L.List PositionedToken)
parseTokens = do
  P.skipSpaces
  L.many parsePositionedToken
  <* P.eof

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

parseToken :: P.Parser String Token
parseToken = P.choice
  [ P.try $ P.char   '('   *> pure LParen
  , P.try $ P.char   ')'   *> pure RParen
  , P.try $ P.char   '['   *> pure LSquare
  , P.try $ P.char   ']'   *> pure RSquare
  , P.try $ P.char   '|'   *> pure VBar
  , P.try $ P.char   ':'   *> pure Colon
  , P.try $ P.char   ','   *> pure Comma
  , P.try $ parseLongOption
  , P.try $ parseShortOption
  , P.try $ AngleName <$> parseAngleName
  , P.try $ P.char   '<'   *> pure LAngle
  , P.try $ P.char   '>'   *> pure RAngle
  , P.try $ P.char   '-'   *> pure Dash
  , P.try $ P.char   '='   *> pure Equal
  , P.try $ P.string "..." *> pure TripleDot
  , P.try $ ShoutName <$> parseShoutName
  , P.try $ Name      <$> parseName
  , P.try $ Garbage   <$> P.anyChar
  ] <* P.skipSpaces

 where

  parseName :: P.Parser String String
  parseName = fromCharArray <$> do
    A.cons
      <$> identStart
      <*> A.many identLetter

  parseAngleName :: P.Parser String String
  parseAngleName =
    P.char '<' *> parseName <* P.char '>'

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

  parseShortOption :: P.Parser String Token
  parseShortOption =
    P.char '-' *> do
      SOpt
        <$> lowerAlphaNum
        <*> (many lowerAlphaNum)
        <*> (fromCharArray <$> (A.many upperAlphaNum))

  parseLongOption :: P.Parser String Token
  parseLongOption =
    P.string "--" *> do
      LOpt <$> parseName

  identStart :: P.Parser String Char
  identStart = alpha

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

  flag :: P.Parser String Char
  flag = lowerAlphaNum

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

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

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

anyToken = token $ Just

eof = P.notFollowedBy anyToken

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

langle :: TokenParser Unit
langle = match LAngle

rangle :: TokenParser Unit
rangle = match RAngle

dash :: TokenParser Unit
dash = match Dash

vbar :: TokenParser Unit
vbar = match VBar

comma :: TokenParser Unit
comma = match Comma

colon :: TokenParser Unit
colon = match Colon

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

equal :: TokenParser Unit
equal = match Equal

lopt :: TokenParser String
lopt = token go P.<?> "long-option"
  where
    go (LOpt n) = Just n
    go _        = Nothing

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

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

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

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

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


make port configurable for rebuild

make port configurable for rebuild

module PscIde where

import PscIde.Command
import Control.Alt ((<|>))
import Control.Bind (join)
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (Error)
import Data.Argonaut (class DecodeJson, class EncodeJson, encodeJson)
import Data.Either (Either)
import Data.Maybe (Maybe(..))
import Prelude (Unit, pure, (<$>), (>>>), show)

foreign import data NET :: !

foreign import send :: forall eff.
  String -> -- ^ Command
  Int ->  -- ^ Port
  (String -> Eff (net :: NET | eff) Unit) -> -- ^ Callback
  (Error -> Eff (net :: NET | eff) Unit) -> -- ^ Error Callback
  Eff (net :: NET | eff) Unit

type Cmd a = forall eff. Aff (net :: NET | eff) (Result a)
type CmdR a b = forall eff. Aff (net :: NET | eff) (Result (Either a b))

sendCommandG :: forall i oe o. (EncodeJson i, DecodeJson oe, DecodeJson o) =>
                Int -> i -> (String -> Result (Either oe o)) -> CmdR oe o
sendCommandG port command unwrapper =
  makeAff (\err succ ->
            send (show (encodeJson command)) port (unwrapper >>> succ) err)

sendCommandR :: forall i oe o. (EncodeJson i, DecodeJson oe, DecodeJson o) => Int -> i -> CmdR oe o
sendCommandR port command = sendCommandG port command unwrapResponse

sendCommand :: forall i o. (EncodeJson i, DecodeJson o) => i -> Cmd o
sendCommand command =
  makeAff (\err succ ->
            send (show (encodeJson command)) 4242 (unwrapResponse >>> join >>> succ) err)

cwd :: Cmd Message
cwd = sendCommand Cwd

listLoadedModules :: Cmd ModuleList
listLoadedModules = sendCommand (Ls LoadedModules)

listAvailableModules :: Cmd ModuleList
listAvailableModules = sendCommand (Ls AvailableModules)

listImports :: String -> Cmd ImportList
listImports fp = sendCommand (Ls (Imports fp))

load ::
  Array String ->
  Array String ->
  Cmd Message
load ms ds = sendCommand (Load ms ds)

quit :: Cmd Message
quit = sendCommand Quit

pursuitCompletion :: String -> Cmd (Array PursuitCompletion)
pursuitCompletion q = sendCommand (Pursuit Ident q)

complete ::
  Array Filter ->
  Maybe Matcher ->
  Cmd (Array Completion)
complete fs m = sendCommand (Complete fs m)

type' ::
  String ->
  Array Filter ->
  Cmd (Array Completion)
type' s fs = sendCommand (Type s fs)

suggestTypos ::
  String ->
  Int ->
  Cmd (Array Completion)
suggestTypos q m = (_ <|> pure []) <$> complete [] (Just (Distance q m))

addClause :: String -> Boolean -> Cmd (Array String)
addClause line annotations = sendCommand (AddClause line annotations)

caseSplit :: String -> Int -> Int -> Boolean -> String -> Cmd (Array String)
caseSplit line begin end annotations typ =
  sendCommand (CaseSplit line begin end annotations typ)

implicitImport :: String -> (Maybe String) -> (Array Filter) -> String -> Cmd (ImportResult)
implicitImport infile outfile filters mod = sendCommand (ImportCmd infile outfile filters (AddImplicitImport mod))

explicitImport :: String -> (Maybe String) -> (Array Filter) -> String -> Cmd (ImportResult)
explicitImport infile outfile filters ident = sendCommand (ImportCmd infile outfile filters (AddImport ident))

rebuild :: Int -> String -> CmdR RebuildResult RebuildResult
rebuild port file = sendCommandR port (RebuildCmd file)

module PscIde where

import PscIde.Command
import Control.Alt ((<|>))
import Control.Bind (join)
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (Error)
import Data.Argonaut (class DecodeJson, class EncodeJson, encodeJson)
import Data.Either (Either)
import Data.Maybe (Maybe(..))
import Prelude (Unit, pure, (<$>), (>>>), show)

foreign import data NET :: !

foreign import send :: forall eff.
  String -> -- ^ Command
  Int ->  -- ^ Port
  (String -> Eff (net :: NET | eff) Unit) -> -- ^ Callback
  (Error -> Eff (net :: NET | eff) Unit) -> -- ^ Error Callback
  Eff (net :: NET | eff) Unit

type Cmd a = forall eff. Aff (net :: NET | eff) (Result a)
type CmdR a b = forall eff. Aff (net :: NET | eff) (Result (Either a b))

sendCommandR :: forall i oe o. (EncodeJson i, DecodeJson oe, DecodeJson o) => i -> CmdR oe o
sendCommandR c = makeAff (\err succ -> send (show (encodeJson c)) 4242 (unwrapResponse >>> succ) err)

sendCommand :: forall i o. (EncodeJson i, DecodeJson o) => i -> Cmd o
sendCommand c = makeAff (\err succ -> send (show (encodeJson c)) 4242 (unwrapResponse >>> join >>> succ) err)

cwd :: Cmd Message
cwd = sendCommand Cwd

listLoadedModules :: Cmd ModuleList
listLoadedModules = sendCommand (Ls LoadedModules)

listAvailableModules :: Cmd ModuleList
listAvailableModules = sendCommand (Ls AvailableModules)

listImports :: String -> Cmd ImportList
listImports fp = sendCommand (Ls (Imports fp))

load ::
  Array String ->
  Array String ->
  Cmd Message
load ms ds = sendCommand (Load ms ds)

quit :: Cmd Message
quit = sendCommand Quit

pursuitCompletion :: String -> Cmd (Array PursuitCompletion)
pursuitCompletion q = sendCommand (Pursuit Ident q)

complete ::
  Array Filter ->
  Maybe Matcher ->
  Cmd (Array Completion)
complete fs m = sendCommand (Complete fs m)

type' ::
  String ->
  Array Filter ->
  Cmd (Array Completion)
type' s fs = sendCommand (Type s fs)

suggestTypos ::
  String ->
  Int ->
  Cmd (Array Completion)
suggestTypos q m = (_ <|> pure []) <$> complete [] (Just (Distance q m))

addClause :: String -> Boolean -> Cmd (Array String)
addClause line annotations = sendCommand (AddClause line annotations)

caseSplit :: String -> Int -> Int -> Boolean -> String -> Cmd (Array String)
caseSplit line begin end annotations typ =
  sendCommand (CaseSplit line begin end annotations typ)

implicitImport :: String -> (Maybe String) -> (Array Filter) -> String -> Cmd (ImportResult)
implicitImport infile outfile filters mod = sendCommand (ImportCmd infile outfile filters (AddImplicitImport mod))

explicitImport :: String -> (Maybe String) -> (Array Filter) -> String -> Cmd (ImportResult)
explicitImport infile outfile filters ident = sendCommand (ImportCmd infile outfile filters (AddImport ident))

rebuild :: String -> CmdR RebuildResult RebuildResult
rebuild file = sendCommandR (RebuildCmd file)


Pre-lex, lex and parse usage

Pre-lex, lex and parse usage

module Docopt.Parser.Docopt where

import Prelude
import Control.MonadPlus (guard)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import Data.List (List(..), many, toList, fromList, (:), length, filter)
import qualified Data.Array as A
import Data.String (toCharArray, fromCharArray)
import qualified Data.String as Str
import Data.Either
import Docopt.Parser.Base
import qualified Docopt.Parser.Lexer as Lexer
import qualified Docopt.Parser.Usage as Usage

data Section
  = Preamble String
  | Usage String
  | Options String

unSection :: Section -> String
unSection (Preamble s) = s
unSection (Usage    s) = s
unSection (Options  s) = s

data Source = Source String (List String)

instance showDocopt :: Show Source where
  show (Source x xs) = "Source " ++ show x ++ show xs

instance showSection :: Show Section where
  show (Preamble x) = "Preamble: " ++ show x
  show (Usage    x) = "Usage: "    ++ show x
  show (Options  x) = "Options: "  ++ show x

-- | Pre-parse the docopt string and break it into sections.
prelex :: P.Parser String Source
prelex = do

  P.manyTill P.anyChar (P.lookAhead anySectionHeader)
  sections <- many parseSection
  usage <- case findUsages sections of
    Nil               -> P.fail "No usage section found!"
    Cons _ (Cons _ _) -> P.fail "More than one usage section found!"
    Cons x Nil        -> pure x

  return $ Source
    (unSection usage)
    (map unSection $ findOptions sections)

  where
    findUsages           = filter isUsage
    isUsage (Usage _)    = true
    isUsage _            = false
    findOptions          = filter isOption
    isOption (Options _) = true
    isOption _           = false

    anySectionHeader :: P.Parser String String
    anySectionHeader = usageSectionHeader <|> optionsSectionHeader

    usageSectionHeader :: P.Parser String String
    usageSectionHeader = sectionHeader "usage"

    optionsSectionHeader :: P.Parser String String
    optionsSectionHeader = sectionHeader "options"

    sectionHeader :: String -> P.Parser String String
    sectionHeader s = (do
      col <- getCol
      guard (col == 1)
      string' s <* (P.try $ P.char ':')
      ) P.<?> "section header"

    emptyLine :: P.Parser String Unit
    emptyLine = (do
      col <- getCol
      guard (col == 1)
      many space *> eol
      ) P.<?> "empty line"

    extractSectionSource :: P.Parser String String
    extractSectionSource = do
      many space *> eol
      many $ P.try emptyLine

      -- The section block extends until the first empty line is
      -- encountered OR until a new section is found OR the EOF
      -- is encountered.

      source <- fromCharArray <<< fromList <$> P.manyTill
        P.anyChar
        (P.try $ P.lookAhead do
              emptyLine
          <|> void anySectionHeader
          <|> P.eof)

      P.eof <|> (void $ P.try $ do
        emptyLine
        P.manyTill P.anyChar $ P.try do
          P.eof <|> (void $ P.lookAhead anySectionHeader))

      pure source

    parseSection :: P.Parser String Section
    parseSection = P.choice
      [ Usage   <$> (usageSectionHeader   *> extractSectionSource)
      , Options <$> (optionsSectionHeader *> extractSectionSource)
      ]

docopt :: String -> Either P.ParseError Unit
docopt input = do
  Source usageSrc _ <- P.runParser input prelex
  usageToks         <- P.runParser usageSrc Lexer.parseTokens
  usage             <- Lexer.runTokenParser usageToks Usage.parseUsage
  debug usage

module Docopt.Parser.Docopt where

import Prelude
import Control.MonadPlus (guard)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import Data.List (List(..), many, toList, fromList, (:), length, filter)
import qualified Data.Array as A
import Data.String (toCharArray, fromCharArray)
import qualified Data.String as Str
import Data.Either
import Docopt.Parser.Base
import qualified Docopt.Parser.Lexer as Lexer
import qualified Docopt.Parser.Usage as Usage

data Section
  = Preamble String
  | Usage String
  | Options String

unSection :: Section -> String
unSection (Preamble s) = s
unSection (Usage    s) = s
unSection (Options  s) = s

data Source = Source String (List String)

instance showDocopt :: Show Source where
  show (Source x xs) = "Source " ++ show x ++ show xs

instance showSection :: Show Section where
  show (Preamble x) = "Preamble: " ++ show x
  show (Usage    x) = "Usage: "    ++ show x
  show (Options  x) = "Options: "  ++ show x

-- | Pre-parse the docopt string and break it into sections.
prelex :: P.Parser String Unit
prelex = do

  P.manyTill P.anyChar (P.lookAhead anySectionHeader)
  sections <- many parseSection
  debug sections

  where
    anySectionHeader :: P.Parser String String
    anySectionHeader = usageSectionHeader <|> optionsSectionHeader

    usageSectionHeader :: P.Parser String String
    usageSectionHeader = sectionHeader "usage"

    optionsSectionHeader :: P.Parser String String
    optionsSectionHeader = sectionHeader "options"

    sectionHeader :: String -> P.Parser String String
    sectionHeader s = (do
      col <- getCol
      guard (col == 1)
      string' s <* (P.try $ P.char ':')
      ) P.<?> "section header"

    emptyLine :: P.Parser String Unit
    emptyLine = (do
      col <- getCol
      guard (col == 1)
      many space *> eol
      ) P.<?> "empty line"

    extractSectionSource :: P.Parser String String
    extractSectionSource = do
      many space *> eol
      many $ P.try emptyLine

      -- The section block extends until the first empty line is
      -- encountered OR until a new section is found OR the EOF
      -- is encountered.

      source <- fromCharArray <<< fromList <$> P.manyTill
        P.anyChar
        (P.try $ P.lookAhead do
              emptyLine
          <|> void anySectionHeader
          <|> P.eof)

      P.eof <|> (void $ P.try $ do
        emptyLine
        P.manyTill P.anyChar $ P.try do
          P.eof <|> (void $ P.lookAhead anySectionHeader))

      pure source

    parseSection :: P.Parser String Section
    parseSection = P.choice
      [ Usage   <$> (usageSectionHeader   *> extractSectionSource)
      , Options <$> (optionsSectionHeader *> extractSectionSource)
      ]

docopt :: String -> Either P.ParseError Unit
docopt input = do
  P.runParser input prelex
  return unit


demo app cleanup

demo app cleanup

module DemoApp.Fedger where

import Prelude                       (Unit, bind, (++), unit, return)
import Control.Monad.Eff             (Eff)
import Data.List                     (..)
import Control.Monad.Eff.Console     (CONSOLE(), log)
import API.Fedger                    (..)
import API.Fedger.Messages.Queries   (..)
import API.Fedger.Messages.Responses (..)
import API.Fedger.Messages.Partials  (..)
import Optic.Lens.Simple             (Lens, (^.), lens)

-- | -----------------------  Lenses ----------------------------------

vertices_ :: Lens DiscoveryData (List Vertice)
vertices_ = lens _.vertices (_ { vertices = _ })

edges_ :: Lens DiscoveryData (List Edge)
edges_ = lens _.edges (_ { edges = _ })

-- | -----------------------   Callbacks ------------------------------
companySnapshotCB :: forall e. CompanySnapshotResponse -> Eff (console :: CONSOLE | e) Unit
companySnapshotCB = \(CompanySnapshotResponse r) -> do
                                                    log ("Company: "       ++ r.name          ++ "\r\n" ++
                                                         "Funding Level: " ++ r.fundingLevel  ++ "\r\n" ++
                                                         "Slug: "          ++ r.slug          ++ "\r\n" ++
                                                         "Twitter: "       ++ r.urlTwitter    ++ "\r\n" ++
                                                         "Crunchbase: "    ++ r.urlCrunchbase ++ "\r\n")

fundingDetailsCB :: forall e. FundingDetailsResponse -> Eff (console :: CONSOLE | e) Unit
fundingDetailsCB = \(FundingDetailsResponse r) -> do
                                                  let inv = Investor {
                                                                      "type" : "1",
                                                                      "name" : "2",
                                                                      "slug" : "3",
                                                                      "domain" : "4"
                                                                    }
                                                  let _round = Round {
                                                                        "date"  : 1,
                                                                        "amount"  : 2,
                                                                        "currency" : "EUR",
                                                                        "round" : "Seed",
                                                                        "investors" : Cons inv Nil
                                                                      }
                                                  let test = FundingDetailsResponse { "name" : "1",
                                                                                "domain" : "2" ,
                                                                                "amount_total" : 3,
                                                                                "currency" : "4",
                                                                                "rounds"  : Cons _round Nil
                                                                                }
                                                  -- logRaw r.rounds
                                                  logRaw test

logoCB :: forall e. LogoResponse -> Eff(console :: CONSOLE | e) Unit
logoCB = \(LogoResponse r) -> do
                              log ("logo: " ++ r.binary)

logAnyResponse :: forall a e. a -> Eff (console :: CONSOLE | e) Unit
logAnyResponse = \anyResponse -> do
                                 logRaw anyResponse

logDiscovery :: forall e. DiscoveryResponse -> Eff (console :: CONSOLE | e) Unit
logDiscovery = \(DiscoveryResponse r) -> do
                                        let vs = (r.data ^. vertices_)
                                        let es = (r.data ^. edges_)
                                        log "VERTICES"
                                        logRaw vs -- show vertices
                                        log "EDGES"
                                        logRaw es -- show edges
                                        return unit

logDiscoveryCompanies :: forall e. DiscoveryCompaniesResponse -> Eff (console :: CONSOLE | e) Unit
logDiscoveryCompanies = \(DiscoveryCompaniesResponse r) -> do
                                                          logRaw r.data
                                                          return unit

logDiscoveryVertices :: forall e. DiscoveryVerticesResponse -> Eff (console :: CONSOLE | e) Unit
logDiscoveryVertices = \(DiscoveryVerticesResponse r) -> do
                                                        logRaw r.data -- show vertices
                                                        return unit

logInvestors :: forall e. InvestorsResponse -> Eff (console :: CONSOLE | e) Unit
logInvestors = \(InvestorsResponse r) -> do
                                        --let inv = Just (Investor { "type" : "1", "name" : "2", "slug" : "3", "domain" : "4" })
                                        --logRaw inv
                                        --logRaw $ (head r.investors) :: (Maybe Investor)
                                        logRaw r
                                        return unit

-- | ------------------------ End of Callbacks -----------------------

main ::  forall e. Eff (console :: CONSOLE, fedgerM :: FedgerM | e) Unit
main = do
      let myApiKey = "YOUR_API_KEY_HERE"
      --let discoveryQuery = DiscoveryQuery { s : "oracle", crossDomain : true, apikey : myApiKey }
      --let discoveryCompaniesQuery = DiscoveryCompaniesQuery { s : "oracle", crossDomain : true, apikey : myApiKey, cursor : 0 }
      let discoveryVerticesQuery = DiscoveryVerticesQuery { s : "oracle", crossDomain : true, apikey : myApiKey, cursor : 0 }
      let investorsQuery = InvestorsQuery { domain : "arangodb.com", crossDomain : true, apikey : myApiKey, cursor : 0 }
      let fundingDetailsQuery = FundingDetailsQuery { domain : "arangodb.com", crossDomain : true, apikey : myApiKey }
      --let logoQuery = LogoQuery { domain : "giantswarm.io", crossDomain : true, apikey : myApiKey }
      --let snapshotQuery = CompanySnapshotQuery { domain : "giantswarm.io", crossDomain : true, apikey : myApiKey }
      --getCompanySnapshot snapshotQuery companySnapshotCB
     --getFundingDetails fundingDetailsQuery fundingDetailsCB
      --getLogo logoQuery logoCB
      --getInvestors investorsQuery logInvestors
      --getDiscovery discoveryQuery logDiscovery
      --getDiscoveryCompanies discoveryCompaniesQuery logDiscoveryCompanies
      getDiscoveryVertices discoveryVerticesQuery logDiscoveryVertices

module DemoApp.Fedger where

import Prelude                       (Unit, bind, (++), ($), unit, return)
import Control.Monad.Eff             (Eff)
import Data.List                     (..)
import Data.Maybe                    (..)
import Control.Monad.Eff.Console     (CONSOLE(), log)
import API.Fedger                    (..)
import API.Fedger.Messages.Queries   (..)
import API.Fedger.Messages.Responses (..)
import API.Fedger.Messages.Partials  (..)
import Optic.Lens.Simple             (Lens, (^.), lens)
import Data.Foreign
import Data.Foreign.Class

-- | -----------------------  Lenses ----------------------------------

vertices_ :: Lens DiscoveryData (List Vertice)
vertices_ = lens _.vertices (_ { vertices = _ })

edges_ :: Lens DiscoveryData (List Edge)
edges_ = lens _.edges (_ { edges = _ })

-- | -----------------------   Callbacks ------------------------------
companySnapshotCB :: forall e. CompanySnapshotResponse -> Eff (console :: CONSOLE | e) Unit
companySnapshotCB = \(CompanySnapshotResponse r) -> do
                                                    log ("Company: "       ++ r.name          ++ "\r\n" ++
                                                         "Funding Level: " ++ r.fundingLevel  ++ "\r\n" ++
                                                         "Slug: "          ++ r.slug          ++ "\r\n" ++
                                                         "Twitter: "       ++ r.urlTwitter    ++ "\r\n" ++
                                                         "Crunchbase: "    ++ r.urlCrunchbase ++ "\r\n")

fundingDetailsCB :: forall e. FundingDetailsResponse -> Eff (console :: CONSOLE | e) Unit
fundingDetailsCB = \(FundingDetailsResponse r) -> do
                                                  let inv = Investor {
                                                                      "type" : "1",
                                                                      "name" : "2",
                                                                      "slug" : "3",
                                                                      "domain" : "4"
                                                                    }
                                                  let _round = Round {
                                                                        "date"  : 1,
                                                                        "amount"  : 2,
                                                                        "currency" : "EUR",
                                                                        "round" : "Seed",
                                                                        "investors" : Cons inv Nil
                                                                      }
                                                  let test = FundingDetailsResponse { "name" : "1",
                                                                                "domain" : "2" ,
                                                                                "amount_total" : 3,
                                                                                "currency" : "4",
                                                                                "rounds"  : Cons _round Nil
                                                                                }
                                                  -- logRaw r.rounds
                                                  logRaw test

logoCB :: forall e. LogoResponse -> Eff(console :: CONSOLE | e) Unit
logoCB = \(LogoResponse r) -> do
                              log ("logo: " ++ r.binary)

logAnyResponse :: forall a e. a -> Eff (console :: CONSOLE | e) Unit
logAnyResponse = \anyResponse -> do
                                 logRaw anyResponse

logDiscovery :: forall e. DiscoveryResponse -> Eff (console :: CONSOLE | e) Unit
logDiscovery = \(DiscoveryResponse r) -> do
                                        let vs = (r.data ^. vertices_)
                                        let es = (r.data ^. edges_)
                                        log "VERTICES"
                                        logRaw vs -- show vertices
                                        log "EDGES"
                                        logRaw es -- show edges
                                        return unit

logDiscoveryCompanies :: forall e. DiscoveryCompaniesResponse -> Eff (console :: CONSOLE | e) Unit
logDiscoveryCompanies = \(DiscoveryCompaniesResponse r) -> do
                                                          logRaw r.data
                                                          return unit

logDiscoveryVertices :: forall e. DiscoveryVerticesResponse -> Eff (console :: CONSOLE | e) Unit
logDiscoveryVertices = \(DiscoveryVerticesResponse r) -> do
                                                        logRaw r.data -- show vertices
                                                        return unit

logInvestors :: forall e. InvestorsResponse -> Eff (console :: CONSOLE | e) Unit
logInvestors = \(InvestorsResponse r) -> do
                                        --let inv = Just (Investor { "type" : "1", "name" : "2", "slug" : "3", "domain" : "4" })
                                        --logRaw inv
                                        --logRaw $ (head r.investors) :: (Maybe Investor)
                                        logRaw r
                                        return unit

-- | ------------------------ End of Callbacks -----------------------

main ::  forall e. Eff (console :: CONSOLE, fedgerM :: FedgerM | e) Unit
main = do
      let myApiKey = "YOUR_API_KEY_HERE"
      --let discoveryQuery = DiscoveryQuery { s : "oracle", crossDomain : true, apikey : myApiKey }
      --let discoveryCompaniesQuery = DiscoveryCompaniesQuery { s : "oracle", crossDomain : true, apikey : myApiKey, cursor : 0 }
      let discoveryVerticesQuery = DiscoveryVerticesQuery { s : "oracle", crossDomain : true, apikey : myApiKey, cursor : 0 }
      let investorsQuery = InvestorsQuery { domain : "arangodb.com", crossDomain : true, apikey : myApiKey, cursor : 0 }
      let fundingDetailsQuery = FundingDetailsQuery { domain : "arangodb.com", crossDomain : true, apikey : myApiKey }
      --let logoQuery = LogoQuery { domain : "giantswarm.io", crossDomain : true, apikey : myApiKey }
      --let snapshotQuery = CompanySnapshotQuery { domain : "giantswarm.io", crossDomain : true, apikey : myApiKey }
      --getCompanySnapshot snapshotQuery companySnapshotCB
     --getFundingDetails fundingDetailsQuery fundingDetailsCB
      --getLogo logoQuery logoCB
      --getInvestors investorsQuery logInvestors
      --getDiscovery discoveryQuery logDiscovery
      --getDiscoveryCompanies discoveryCompaniesQuery logDiscoveryCompanies
      getDiscoveryVertices discoveryVerticesQuery logDiscoveryVertices


Remove form to prevent page reloading on rename

module View.Notebook (view) where

import Api.Fs (saveNotebook)
import Control.Apply ((*>))
import Control.Functor (($>))
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Bind ((=<<))
import Control.Plus (empty)
import Controller.Notebook (I(), handleMenuSignal, handleSubmitName, handleNameInput)
import Controller.Notebook.Cell (runCell)
import Data.Array (range, length, zipWith, replicate, sort, singleton)
import Data.Bifunctor (bimap)
import Data.Either (either)
import Data.Inject1 (inj)
import Data.Int (toNumber, fromNumber, Int())
import Data.KeyCombo (printKeyComboWin, printKeyComboMac, printKeyComboLinux)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Path.Pathy
import Data.Platform (Platform(..))
import Data.String (joinWith)
import Data.These (these)
import Driver.File.Path (updatePath)
import Input.Notebook (Input(..))
import Model.Notebook
import Model.Notebook.Cell
import Model.Notebook.Cell.FileInput (_file)
import Model.Notebook.Domain (_cells, _name, _path, notebookPath)
import Model.Notebook.Menu (DropdownItem(), MenuElement(), MenuInsertSignal(..))
import Model.Path ((<./>), encodeURIPath)
import Model.Resource (Resource(), resourcePath)
import Number.Format (toFixed)
import Optic.Core ((..), (^.), (.~))
import Optic.Fold ((^?))
import Optic.Index (ix)
import View.Common
import View.Notebook.Cell (cell)
import View.Notebook.Cell.Search (searchOutput)
import View.Notebook.Common (HTML())
import View.Notebook.Modal (modal)

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as E
import qualified Halogen.HTML.Events.Forms as E
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import qualified Halogen.Themes.Bootstrap3 as B
import qualified View.Css as Vc
import qualified View.Modal.Common as Vm

view :: forall e. State -> HTML e
view state =
  H.div [ A.classes classes, E.onClick (E.input_ CloseDropdowns) ]
  (navigation state <> [body state] <> [modal state])
  where classes = if not state.editable
                  then [ Vc.notebookViewHack ]
                  else [ ]

navigation :: forall e. State -> [HTML e]
navigation state =
  let notebookHref = these exploreHref editHref (\_ -> editHref) (state ^. _notebook .. _name)
  in if not state.editable
     then []
     else [ navbar [ H.div [ A.classes [Vc.header, B.clearfix] ]
                           [ icon B.glyphiconBook notebookHref
                           , logo
                           , name state ]
                   , H.ul [ A.classes [Vc.headerMenu] ]
                          $ zipWith (li state) (range 0 (length state.dropdowns)) state.dropdowns
                   ]
          ]
  where
  exploreHref :: String -> String
  exploreHref _ =
    let inputRes = either (const Nothing) Just =<< state ^? _notebook .. _cells .. ix 0 .. _content .. _FileInput .. _file
    in maybe "" (\r -> Config.notebookUrl ++ "#/explore" ++ encodeURIPath (resourcePath r)) inputRes
  editHref :: String -> String
  editHref name =
    case notebookPath (state ^. _notebook) of
      Just path -> Config.notebookUrl ++ "#" ++ encodeURIPath (printPath path) ++ "edit"
      Nothing -> ""

body :: forall e. State -> HTML e
body state =
  if not state.loaded
  then H.h1 [ A.classes [ B.textCenter ] ]
            [ H.text "Loading..." ]
  else case state.error of
    Just err ->
      H.div [ A.classes [ B.alert, B.alertDanger ] ]
            [ H.h1 [ A.classes [ B.textCenter ] ]
                   [ H.text err ]
            ]
    Nothing ->
      contentFluid [ H.div [ A.class_ B.clearfix ]
                           $ cells state ++ if state.editable
                                            then newCellMenu state
                                            else []
                   ]

cells :: forall e. State -> [HTML e]
cells state = [ H.div [ A.classes [ Vc.notebookContent ] ]
                      $ (state ^. _notebook .. _cells) >>= cell state
              ]

newCellMenu :: forall e. State -> [HTML e]
newCellMenu state =
  [ H.ul [ A.classes [ Vc.newCellMenu ] ]
         [ H.li_ [ H.span_ [ glyph B.glyphiconPlus ] ]
         , li "Query" QueryInsert B.glyphiconHdd
         , li "Markdown" MarkdownInsert B.glyphiconEdit
         , li "Explore" ExploreInsert B.glyphiconEyeOpen
         , li "Search" SearchInsert B.glyphiconSearch
         ]
  ]
  where
  li :: String -> MenuInsertSignal -> A.ClassName -> HTML e
  li title inp cls =
    H.li_ [ H.button [ A.title title
                     , E.onClick (\_ -> pure <<< handleMenuSignal state <<< inj $ inp)
                     ]
                     [ glyph cls ]
          ]

txt :: forall e. Int -> String -> [HTML e]
txt lvl text =
  [ H.text $ (joinWith "" $ replicate (toNumber lvl) "--") <> " " <> text ]

li :: forall e. State -> Number ->  DropdownItem -> HTML e
li state i {visible: visible, name: name, children: children} =
  H.li [ E.onClick (\ev -> do E.stopPropagation
                              E.input_ (Dropdown i) ev)
       , A.classes $ [ B.dropdown ] <>
         (if visible then [ B.open ] else [ ]) ]
  [ H.a [ A.href "#"
        , E.onClick (\_ -> E.preventDefault $> empty)] (txt (fromNumber 0) name)
  , H.ul [ A.classes [ B.dropdownMenu ] ]
    (menuItem state <$> children) ]

menuItem :: forall e. State -> MenuElement -> HTML e
menuItem state {name: name, message: mbMessage, lvl: lvl, shortcut: shortcut} =
  H.li [ A.classes (maybe [B.disabled] (const []) mbMessage) ]
  [ H.a [ A.href "#"
        , A.class_ B.clearfix
        , E.onClick (\e -> do
                        E.stopPropagation
                        E.preventDefault $>
                          maybe empty (handleMenuSignal state) mbMessage) ]
    ([ H.span [A.class_ B.pullLeft] $ (txt lvl name) <>
                 (maybe [glyph B.glyphiconChevronRight] (const []) mbMessage)
     ] ++ maybe [] (\s -> [H.span [A.class_ B.pullRight] [ H.text $ printKeyCombo s ]]) shortcut)
  ]
  where
  printKeyCombo | state ^. _platform == Win = printKeyComboWin
                | state ^. _platform == Mac = printKeyComboMac
                | otherwise = printKeyComboLinux

name :: forall e. State -> HTML e
name state =
  H.div [ A.classes [Vc.notebookName] ]
        [ H.input [ A.id_ Config.notebookNameEditorId
                  , E.onInput (pure <<< handleNameInput)
                  , E.onChange (\_ -> pure $ handleSubmitName state)
                  , A.value (these id id (\n _ -> n) $ state ^. _notebook .. _name)
                  ]
                  []
        ]

module View.Notebook (view) where

import Api.Fs (saveNotebook)
import Control.Apply ((*>))
import Control.Functor (($>))
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Bind ((=<<))
import Control.Plus (empty)
import Controller.Notebook (I(), handleMenuSignal, handleSubmitName, handleNameInput)
import Controller.Notebook.Cell (runCell)
import Data.Array (range, length, zipWith, replicate, sort, singleton)
import Data.Bifunctor (bimap)
import Data.Either (either)
import Data.Inject1 (inj)
import Data.Int (toNumber, fromNumber, Int())
import Data.KeyCombo (printKeyComboWin, printKeyComboMac, printKeyComboLinux)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Path.Pathy
import Data.Platform (Platform(..))
import Data.String (joinWith)
import Data.These (these)
import Driver.File.Path (updatePath)
import Input.Notebook (Input(..))
import Model.Notebook
import Model.Notebook.Cell
import Model.Notebook.Cell.FileInput (_file)
import Model.Notebook.Domain (_cells, _name, _path, notebookPath)
import Model.Notebook.Menu (DropdownItem(), MenuElement(), MenuInsertSignal(..))
import Model.Path ((<./>), encodeURIPath)
import Model.Resource (Resource(), resourcePath)
import Number.Format (toFixed)
import Optic.Core ((..), (^.), (.~))
import Optic.Fold ((^?))
import Optic.Index (ix)
import View.Common
import View.Notebook.Cell (cell)
import View.Notebook.Cell.Search (searchOutput)
import View.Notebook.Common (HTML())
import View.Notebook.Modal (modal)

import qualified Halogen.HTML as H
import qualified Halogen.HTML.Attributes as A
import qualified Halogen.HTML.Events as E
import qualified Halogen.HTML.Events.Forms as E
import qualified Halogen.HTML.Events.Handler as E
import qualified Halogen.HTML.Events.Monad as E
import qualified Halogen.Themes.Bootstrap3 as B
import qualified View.Css as Vc
import qualified View.Modal.Common as Vm

view :: forall e. State -> HTML e
view state =
  H.div [ A.classes classes, E.onClick (E.input_ CloseDropdowns) ]
  (navigation state <> [body state] <> [modal state])
  where classes = if not state.editable
                  then [ Vc.notebookViewHack ]
                  else [ ]

navigation :: forall e. State -> [HTML e]
navigation state =
  let notebookHref = these exploreHref editHref (\_ -> editHref) (state ^. _notebook .. _name)
  in if not state.editable
     then []
     else [ navbar [ H.div [ A.classes [Vc.header, B.clearfix] ]
                           [ icon B.glyphiconBook notebookHref
                           , logo
                           , name state ]
                   , H.ul [ A.classes [Vc.headerMenu] ]
                          $ zipWith (li state) (range 0 (length state.dropdowns)) state.dropdowns
                   ]
          ]
  where
  exploreHref :: String -> String
  exploreHref _ =
    let inputRes = either (const Nothing) Just =<< state ^? _notebook .. _cells .. ix 0 .. _content .. _FileInput .. _file
    in maybe "" (\r -> Config.notebookUrl ++ "#/explore" ++ encodeURIPath (resourcePath r)) inputRes
  editHref :: String -> String
  editHref name =
    case notebookPath (state ^. _notebook) of
      Just path -> Config.notebookUrl ++ "#" ++ encodeURIPath (printPath path) ++ "edit"
      Nothing -> ""

body :: forall e. State -> HTML e
body state =
  if not state.loaded
  then H.h1 [ A.classes [ B.textCenter ] ]
            [ H.text "Loading..." ]
  else case state.error of
    Just err ->
      H.div [ A.classes [ B.alert, B.alertDanger ] ]
            [ H.h1 [ A.classes [ B.textCenter ] ]
                   [ H.text err ]
            ]
    Nothing ->
      contentFluid [ H.div [ A.class_ B.clearfix ]
                           $ cells state ++ if state.editable
                                            then newCellMenu state
                                            else []
                   ]

cells :: forall e. State -> [HTML e]
cells state = [ H.div [ A.classes [ Vc.notebookContent ] ]
                      $ (state ^. _notebook .. _cells) >>= cell state
              ]

newCellMenu :: forall e. State -> [HTML e]
newCellMenu state =
  [ H.ul [ A.classes [ Vc.newCellMenu ] ]
         [ H.li_ [ H.span_ [ glyph B.glyphiconPlus ] ]
         , li "Query" QueryInsert B.glyphiconHdd
         , li "Markdown" MarkdownInsert B.glyphiconEdit
         , li "Explore" ExploreInsert B.glyphiconEyeOpen
         , li "Search" SearchInsert B.glyphiconSearch
         ]
  ]
  where
  li :: String -> MenuInsertSignal -> A.ClassName -> HTML e
  li title inp cls =
    H.li_ [ H.button [ A.title title
                     , E.onClick (\_ -> pure <<< handleMenuSignal state <<< inj $ inp)
                     ]
                     [ glyph cls ]
          ]

txt :: forall e. Int -> String -> [HTML e]
txt lvl text =
  [ H.text $ (joinWith "" $ replicate (toNumber lvl) "--") <> " " <> text ]

li :: forall e. State -> Number ->  DropdownItem -> HTML e
li state i {visible: visible, name: name, children: children} =
  H.li [ E.onClick (\ev -> do E.stopPropagation
                              E.input_ (Dropdown i) ev)
       , A.classes $ [ B.dropdown ] <>
         (if visible then [ B.open ] else [ ]) ]
  [ H.a [ A.href "#"
        , E.onClick (\_ -> E.preventDefault $> empty)] (txt (fromNumber 0) name)
  , H.ul [ A.classes [ B.dropdownMenu ] ]
    (menuItem state <$> children) ]

menuItem :: forall e. State -> MenuElement -> HTML e
menuItem state {name: name, message: mbMessage, lvl: lvl, shortcut: shortcut} =
  H.li [ A.classes (maybe [B.disabled] (const []) mbMessage) ]
  [ H.a [ A.href "#"
        , A.class_ B.clearfix
        , E.onClick (\e -> do
                        E.stopPropagation
                        E.preventDefault $>
                          maybe empty (handleMenuSignal state) mbMessage) ]
    ([ H.span [A.class_ B.pullLeft] $ (txt lvl name) <>
                 (maybe [glyph B.glyphiconChevronRight] (const []) mbMessage)
     ] ++ maybe [] (\s -> [H.span [A.class_ B.pullRight] [ H.text $ printKeyCombo s ]]) shortcut)
  ]
  where
  printKeyCombo | state ^. _platform == Win = printKeyComboWin
                | state ^. _platform == Mac = printKeyComboMac
                | otherwise = printKeyComboLinux

name :: forall e. State -> HTML e
name state =
  H.div [ A.classes [Vc.notebookName] ]
        [ H.form_ [ H.input [ A.id_ Config.notebookNameEditorId
                            , E.onInput (pure <<< handleNameInput)
                            , E.onChange (\_ -> pure $ handleSubmitName state)
                            , A.value (these id id (\n _ -> n) $ state ^. _notebook .. _name)
                            ]
                            []
                  ]
        ]