add comments and organize render functions

module Main where

import App.Events (AppEffects)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Except (runExcept)
import DOM (DOM)
import DOM.Event.KeyboardEvent (code, eventToKeyboardEvent)
import Data.Array (filter, null, snoc, length)
import Data.Either (Either(..))
import Data.Foldable (all, for_)
import Data.Generic (class Generic, gShow)
import Data.String (joinWith)
import Data.String (null) as S
import Pux (CoreEffects, App, start, EffModel, noEffects)
import Pux.DOM.Events (DOMEvent, onBlur, onChange, onClick, onDoubleClick, onKeyDown, targetValue)
import Pux.DOM.HTML (HTML)
import Pux.DOM.HTML.Attributes (focused)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (a, button, div, footer, h1, header, input, label, li, p, section, span, strong, ul)
import Text.Smolder.HTML.Attributes (checked, className, href, placeholder, type', value)
import Text.Smolder.Markup (EventHandlers, text, (!), (!?), (#!))
import Prelude hiding (div)

-- define types and data
data Visibility = All | Active | Completed
derive instance eqVis :: Eq Visibility

data Event = FieldChanged DOMEvent
           | AddEntry DOMEvent
           | DeleteEntry Int DOMEvent
           | EditEntry Int DOMEvent
           | ChangeEntry Int DOMEvent
           | UpdateEntry Int DOMEvent
           | CancelEditEntry Int DOMEvent
           | ToggleComplete Int DOMEvent
           | ChangeVisibility Visibility DOMEvent
           | CheckAll Boolean DOMEvent
           | DeleteCompeleted DOMEvent
           | Noop DOMEvent

newtype Entry = Entry { id :: Int
                      , description :: String
                      , editingDesc :: String
                      , isEditing :: Boolean
                      , isCompleted :: Boolean
                      }

mkEntry :: Int -> String -> Entry
mkEntry id description = Entry { id
                               , description
                               , editingDesc: description
                               , isEditing: false
                               , isCompleted: false
                               }

newtype State = State { nextId :: Int
                      , editingField :: String
                      , entries :: Array Entry
                      , visibility :: Visibility
                      }

-- add show to easier debug
derive instance genericVisibility :: Generic Visibility
derive instance genericEntry :: Generic Entry
derive instance genericState :: Generic State

instance showVis :: Show Visibility where
  show = gShow

instance showEntry :: Show Entry where
  show = gShow

instance showState :: Show State where
  show = gShow

-- init state
init :: String -> State
init url = State { nextId: 0
                 , editingField: ""
                 , entries: []
                 , visibility: All
                 }

-- update reusable util functions
-- update only if match id
updateEntryWithId :: (Entry -> Entry) -> Int -> Array Entry -> Array Entry
updateEntryWithId f id = map applyIfMatch
  where applyIfMatch entry@(Entry en) | en.id == id = f entry
                                      | otherwise = entry

setEditState :: Boolean -> Entry -> Entry
setEditState isEditing (Entry en) = Entry $ en { isEditing = isEditing }

-- the foldp
foldp :: forall fx. Event -> State -> EffModel State Event (AppEffects fx)
foldp (FieldChanged ev) (State s) =
  noEffects $ State s { editingField = targetValue ev }

foldp (AddEntry ev) ss@(State s) =
  noEffects $ State s { nextId = s.nextId + 1
                      , editingField = ""
                      , entries = snoc s.entries $ mkEntry s.nextId s.editingField
                      }

foldp (DeleteEntry id ev) (State s) =
  noEffects $ State s { entries = filter (\(Entry en) -> en.id /= id) s.entries }

foldp (EditEntry id ev) (State s) =
  noEffects $ State s {
    entries = map update s.entries
  }

  where
    update ee@(Entry en) =
      if en.id == id
      then Entry en { isEditing = true }
      else Entry en { isEditing = false }

foldp (ChangeEntry id ev) (State s) =
  noEffects $ State s {
    entries = updateEntryWithId update id s.entries
  }

  where
    update (Entry en) = Entry $ en { editingDesc = targetValue ev }

foldp (CancelEditEntry id ev) ((State s)) =
  noEffects $ State s {
    entries = updateEntryWithId update id s.entries
  }

  where
    resetEditingDesc (Entry en) = Entry $ en { editingDesc = en.description }
    update = resetEditingDesc >>> setEditState false

foldp (UpdateEntry id ev) (State s) =
  noEffects $ State s {
    entries = updateEntryWithId update id s.entries
  }

  where
    commitEditingDesc (Entry en) = Entry $ en { description = en.editingDesc }
    update = commitEditingDesc >>> setEditState false

foldp (ToggleComplete id ev) (State s) =
  noEffects $ State s {
    entries = updateEntryWithId update id s.entries
  }

  where
    update (Entry en) = Entry $ en { isCompleted = not en.isCompleted }

foldp (ChangeVisibility vis ev) (State s) =
  noEffects $ State s { visibility = vis }

foldp (CheckAll complete ev) (State s) =
  noEffects $ State s { entries = map update s.entries}
  where
    update (Entry en) = Entry $ en { isCompleted = complete }

foldp (DeleteCompeleted ev) (State s) =
  noEffects $ State s { entries = filter (\(Entry en) -> not en.isCompleted) s.entries }

foldp (Noop ev) ss = noEffects ss

-- keyboard event handlers
filterKey :: String -> (DOMEvent -> Event) -> (DOMEvent -> Event)
filterKey keyCode f ev =
  case runExcept $ code <$> eventToKeyboardEvent ev of
    (Right code) | code == keyCode -> f ev
    _ -> Noop ev

onEnter :: (DOMEvent -> Event) -> EventHandlers (DOMEvent -> Event)
onEnter f = onKeyDown (filterKey "Enter" f)

-- render functions
viewEntry :: Entry -> HTML Event
viewEntry (Entry { id, description, editingDesc, isEditing, isCompleted }) =
  li ! className cName $ do
    div ! className "view" $ do
      (input
        ! className "toggle"
        ! type' "checkbox"
        !? isCompleted) (checked $ show isCompleted)
        #! onClick (ToggleComplete id)
      label
        #! onDoubleClick (EditEntry id)
        $ text description
      button
        ! className "destroy"
        #! onClick (DeleteEntry id)
        $ text ""
    (input
      ! className "edit"
      ! value editingDesc
      !? isEditing) focused
      #! onChange (ChangeEntry id)
      #! onEnter (UpdateEntry id)
      #! onBlur (CancelEditEntry id)

  where
    cEditing = if isEditing then "editing" else ""
    cCompleted = if isCompleted then "completed" else ""
    cName = joinWith " " <<< filter (not <<< S.null) $ [cEditing, cCompleted]

view :: State -> HTML Event
view (State st) = div do
  section ! className "todoapp" $ do
    inputForNewEntry
    viewEntries
    controls
  infoFooter

  where
    -- data
    completedEntries = filter completed st.entries
    leftEntries = filter (not <<< completed) st.entries
    visibleEntries = filter matchVis st.entries
    allCompleted = all completed st.entries
    hasEntries = not <<< null $ st.entries

    completed (Entry { isCompleted }) = isCompleted

    matchVis (Entry { isCompleted }) =
      if st.visibility == All
      then true
      else if st.visibility == Active
           then not isCompleted
           else isCompleted

    -- sub view functions
    inputForNewEntry =
      div do
        header ! className "header" $ do
          h1 $ text "todos"
        input
          ! className "new-todo"
          ! placeholder "What needs to be done?"
          ! value st.editingField
          #! onChange FieldChanged
          #! onEnter AddEntry

    viewEntries =
      when hasEntries do
        section ! className "main" $ do
          (input
            ! className "toggle-all"
            ! type' "checkbox"
            !? allCompleted) (checked "true")
            #! onClick (CheckAll $ not allCompleted)
        ul ! className "todo-list" $ do
          for_ visibleEntries $ viewEntry

    controls = when hasEntries do
      footer ! className "footer" $ do
        span ! className "todo-count" $ do
          strong $ text $ show $ length leftEntries
          text " item left"

        ul ! className "filters" $ do
          visBtn All "All" st.visibility
          visBtn Active "Active" st.visibility
          visBtn Completed "Completed" st.visibility

        when (not <<< null $ completedEntries) do
          button
            ! className "clear-completed"
            #! onClick DeleteCompeleted
            $ text ("Clear completed (" <> (show $ length completedEntries) <> ")")

    visBtn :: Visibility -> String -> Visibility -> HTML Event
    visBtn vis label currentVis = li do
      (a
        !? isCurrent) (className "selected")
        #! onClick (ChangeVisibility vis) $ text label
      where
        isCurrent = vis == currentVis

infoFooter :: HTML Event
infoFooter = footer ! className "info" $ do
  p $ text "Double-click to edit a todo"
  p do
    text "Template by "
    a ! href "http://sindresorhus.com" $ text "Sindre Sorhus"
  p do
    text "Created by "
    a $ text "Ray Shih"
  p do
    text "Part of "
    a ! href "http://todomvc.com" $ text "TodoMVC"

--------------------
-- infrastructure --
--------------------

type WebApp = App (DOMEvent -> Event) Event State

type ClientEffects = CoreEffects (AppEffects (dom :: DOM))

main :: String -> State -> Eff ClientEffects WebApp
main url state = do
  log "Do Reload"
  log $ show state

  -- | Start the app.
  app <- start
    { initialState: state
    , view
    , foldp
    , inputs: [] }

  -- | Render to the DOM
  renderToDOM "#app" app.markup app.input

  -- | Return app to be used for hot reloading logic in support/client.entry.js
  pure app

initialState :: State
initialState = init "/"

module Main where

import App.Events (AppEffects)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Except (runExcept)
import DOM (DOM)
import DOM.Event.KeyboardEvent (code, eventToKeyboardEvent)
import Data.Array (filter, null, snoc, length)
import Data.Either (Either(..))
import Data.Foldable (all, for_)
import Data.Generic (class Generic, gShow)
import Data.String (joinWith)
import Data.String (null) as S
import Pux (CoreEffects, App, start, EffModel, noEffects)
import Pux.DOM.Events (DOMEvent, onBlur, onChange, onClick, onDoubleClick, onKeyDown, targetValue)
import Pux.DOM.HTML (HTML)
import Pux.DOM.HTML.Attributes (focused)
import Pux.Renderer.React (renderToDOM)
import Text.Smolder.HTML (a, button, div, footer, h1, header, input, label, li, p, section, span, strong, ul)
import Text.Smolder.HTML.Attributes (checked, className, href, placeholder, type', value)
import Text.Smolder.Markup (EventHandlers, text, (!), (!?), (#!))
import Prelude hiding (div)

data Visibility = All | Active | Completed
derive instance eqVis :: Eq Visibility

data Event = FieldChanged DOMEvent
           | AddEntry DOMEvent
           | DeleteEntry Int DOMEvent
           | EditEntry Int DOMEvent
           | ChangeEntry Int DOMEvent
           | UpdateEntry Int DOMEvent
           | CancelEditEntry Int DOMEvent
           | ToggleComplete Int DOMEvent
           | ChangeVisibility Visibility DOMEvent
           | CheckAll Boolean DOMEvent
           | DeleteCompeleted DOMEvent
           | Noop DOMEvent

newtype Entry = Entry { id :: Int
                      , description :: String
                      , editingDesc :: String
                      , isEditing :: Boolean
                      , isCompleted :: Boolean
                      }

mkEntry :: Int -> String -> Entry
mkEntry id description = Entry { id
                               , description
                               , editingDesc: description
                               , isEditing: false
                               , isCompleted: false
                               }

newtype State = State { nextId :: Int
                      , editingField :: String
                      , entries :: Array Entry
                      , visibility :: Visibility
                      }

derive instance genericVisibility :: Generic Visibility
derive instance genericEntry :: Generic Entry
derive instance genericState :: Generic State

instance showVis :: Show Visibility where
  show = gShow

instance showEntry :: Show Entry where
  show = gShow

instance showState :: Show State where
  show = gShow

init :: String -> State
init url = State { nextId: 0
                 , editingField: ""
                 , entries: []
                 , visibility: All
                 }

updateEntryWithId :: (Entry -> Entry) -> Int -> Array Entry -> Array Entry
updateEntryWithId f id = map applyIfMatch
  where applyIfMatch entry@(Entry en) | en.id == id = f entry
                                      | otherwise = entry

setEditState :: Boolean -> Entry -> Entry
setEditState isEditing (Entry en) = Entry $ en { isEditing = isEditing }

foldp :: forall fx. Event -> State -> EffModel State Event (AppEffects fx)
foldp (FieldChanged ev) (State s) =
  noEffects $ State s { editingField = targetValue ev }

foldp (AddEntry ev) ss@(State s) =
  noEffects $ State s { nextId = s.nextId + 1
                      , editingField = ""
                      , entries = snoc s.entries $ mkEntry s.nextId s.editingField
                      }

foldp (DeleteEntry id ev) (State s) =
  noEffects $ State s { entries = filter (\(Entry en) -> en.id /= id) s.entries }

foldp (EditEntry id ev) (State s) =
  noEffects $ State s {
    entries = map update s.entries
  }

  where
    update ee@(Entry en) =
      if en.id == id
      then Entry en { isEditing = true }
      else Entry en { isEditing = false }

foldp (ChangeEntry id ev) (State s) =
  noEffects $ State s {
    entries = updateEntryWithId update id s.entries
  }
  where
    update (Entry en) = Entry $ en { editingDesc = targetValue ev }

foldp (CancelEditEntry id ev) ((State s)) =
  noEffects $ State s {
    entries = updateEntryWithId update id s.entries
  }

  where
    resetEditingDesc (Entry en) = Entry $ en { editingDesc = en.description }
    update = resetEditingDesc >>> setEditState false

foldp (UpdateEntry id ev) (State s) =
  noEffects $ State s {
    entries = updateEntryWithId update id s.entries
  }

  where
    commitEditingDesc (Entry en) = Entry $ en { description = en.editingDesc }
    update = commitEditingDesc >>> setEditState false

foldp (ToggleComplete id ev) (State s) =
  noEffects $ State s {
    entries = updateEntryWithId update id s.entries
  }

  where
    update (Entry en) = Entry $ en { isCompleted = not en.isCompleted }

foldp (ChangeVisibility vis ev) (State s) =
  noEffects $ State s { visibility = vis }

foldp (CheckAll complete ev) (State s) =
  noEffects $ State s { entries = map update s.entries}
  where
    update (Entry en) = Entry $ en { isCompleted = complete }

foldp (DeleteCompeleted ev) (State s) =
  noEffects $ State s { entries = filter (\(Entry en) -> not en.isCompleted) s.entries }

foldp (Noop ev) ss = noEffects ss

filterKey :: String -> (DOMEvent -> Event) -> (DOMEvent -> Event)
filterKey keyCode f ev =
  case runExcept $ code <$> eventToKeyboardEvent ev of
    (Right code) | code == keyCode -> f ev
    _ -> Noop ev

onEnter :: (DOMEvent -> Event) -> EventHandlers (DOMEvent -> Event)
onEnter f = onKeyDown (filterKey "Enter" f)

viewEntry :: Entry -> HTML Event
viewEntry (Entry { id, description, editingDesc, isEditing, isCompleted }) =
  li ! className cName $ do
    div ! className "view" $ do
      (input
        ! className "toggle"
        ! type' "checkbox"
        !? isCompleted) (checked $ show isCompleted)
        #! onClick (ToggleComplete id)
      label
        #! onDoubleClick (EditEntry id)
        $ text description
      button
        ! className "destroy"
        #! onClick (DeleteEntry id)
        $ text ""
    (input
      ! className "edit"
      ! value editingDesc
      !? isEditing) focused
      #! onChange (ChangeEntry id)
      #! onEnter (UpdateEntry id)
      #! onBlur (CancelEditEntry id)

  where
    cEditing = if isEditing then "editing" else ""
    cCompleted = if isCompleted then "completed" else ""
    cName = joinWith " " <<< filter (not <<< S.null) $ [cEditing, cCompleted]

view :: State -> HTML Event
view (State st) = div do
  section ! className "todoapp" $ do
    div do
      header ! className "header" $ do
        h1 $ text "todos"
      input
        ! className "new-todo"
        ! placeholder "What needs to be done?"
        ! value st.editingField
        #! onChange FieldChanged
        #! onEnter AddEntry
    section ! className "main" $ do
      when hasEntries do
        (input
          ! className "toggle-all"
          ! type' "checkbox"
          !? allCompleted) (checked "true")
          #! onClick (CheckAll $ not allCompleted)
      ul ! className "todo-list" $ do
        for_ visibleEntries $ viewEntry

    when hasEntries do
      footer ! className "footer" $ do
        span ! className "todo-count" $ do
          strong $ text $ show $ length leftEntries
          text " item left"

        ul ! className "filters" $ do
          visBtn All "All" st.visibility
          visBtn Active "Active" st.visibility
          visBtn Completed "Completed" st.visibility

        when (not <<< null $ completedEntries) do
          button
            ! className "clear-completed"
            #! onClick DeleteCompeleted
            $ text ("Clear completed (" <> (show $ length completedEntries) <> ")")

  footer ! className "info" $ do
    p $ text "Double-click to edit a todo"
    p do
      text "Template by "
      a ! href "http://sindresorhus.com" $ text "Sindre Sorhus"
    p do
      text "Created by "
      a $ text "Ray Shih"
    p do
      text "Part of "
      a ! href "http://todomvc.com" $ text "TodoMVC"

  where
    completedEntries = filter completed st.entries
    leftEntries = filter (not <<< completed) st.entries
    visibleEntries = filter matchVis st.entries
    allCompleted = all completed st.entries
    hasEntries = not <<< null $ st.entries

    completed (Entry { isCompleted }) = isCompleted

    matchVis (Entry { isCompleted }) =
      if st.visibility == All
      then true
      else if st.visibility == Active
           then not isCompleted
           else isCompleted

    visBtn :: Visibility -> String -> Visibility -> HTML Event
    visBtn vis label currentVis = li do
      (a
        !? isCurrent) (className "selected")
        #! onClick (ChangeVisibility vis) $ text label
      where
        isCurrent = vis == currentVis

--------------------
-- infrastructure --
--------------------

type WebApp = App (DOMEvent -> Event) Event State

type ClientEffects = CoreEffects (AppEffects (dom :: DOM))

main :: String -> State -> Eff ClientEffects WebApp
main url state = do
  log "do reload"
  log $ show state

  -- | Start the app.
  app <- start
    { initialState: state
    , view
    , foldp
    , inputs: [] }

  -- | Render to the DOM
  renderToDOM "#app" app.markup app.input

  -- | Return app to be used for hot reloading logic in support/client.entry.js
  pure app

initialState :: State
initialState = init "/"


Added more tests

Added more tests

module Main where

import Data.Tuple
import Data.String (toCharArray)
import Data.Map      (toList)
import SearchEngine
import Test.Spec (describe, pending, it)
import Test.Spec.Node
import Test.Spec.Assertions
import Test.Spec.Reporter.Console

main = runNode [consoleReporter] do

  describe "numLines tests" $ do

    it "should return first line with index" $
      numLines ["Hello World"] `shouldEqual` [Tuple "Hello World" 0]

    it "should return two lines with index" $
      numLines ["Hello", "World"] `shouldEqual` [Tuple "Hello" 0, Tuple "World" 1]

    it "should return n lines with index" $
      numLines ["Welcome to", "Real World", "of Haskell"]
       `shouldEqual` [Tuple "Welcome to" 0, Tuple "Real World" 1, Tuple "of Haskell" 2]

  describe "cleanWords tests" $ do

    it "should return words" $
       cleanWords ["Hello", "World"] `shouldEqual` ["hello", "world"]

    it "should remove numbers" $
       cleanWords ["Welcome6"] `shouldEqual` ["welcome"]

    it "should remove non ascii chars" $
       cleanWords ["This,", "is", "an", "experiment'", "of", "great", "%"]
         `shouldEqual` ["this", "is", "an", "experiment", "of", "great"]

  describe "allNumWords tests" $ do

    it "should convert lines in to words keeping line numbers" $
       allNumWords [Tuple "Welcome to" 0, Tuple "the real" 1]
         `shouldEqual` [Tuple "welcome" (Tuple 0 0), Tuple "to" (Tuple 1 0), Tuple "the" (Tuple 0 1), Tuple "real" (Tuple 1 1)]

    it "should clean while splitting into words" $
       allNumWords [Tuple "Lo ha detto papa'" 0, Tuple "che va' bene, capito" 1]
         `shouldEqual` [Tuple "lo" (Tuple 0 0), Tuple "ha" (Tuple 1 0), Tuple "detto" (Tuple 2 0), Tuple "papa" (Tuple 3 0),
                     Tuple "che" (Tuple 0 1), Tuple "va" (Tuple 1 1), Tuple "bene" (Tuple 2 1), Tuple "capito" (Tuple 3 1)]

  describe "createTermIndex tests" $ do

    it "should create an empty index for an empty document" $
       (toList <<< createTermIndex) []
         `shouldEqual` []

    it "should create an index of one element for a single word doc" $
       (toList <<< createTermIndex) ["Hello"]
         `shouldEqual` [Tuple "hello" [Tuple 0 0]]

    it "should create an index" $ do
       (toList <<< createTermIndex) ["Hello World"]
         `shouldEqual` [Tuple "hello" [Tuple 0 0], Tuple "world" [Tuple 1 0]]

       (toList <<< createTermIndex) ["Back to the Future", "A few good man"]
         `shouldEqual`[Tuple "a" [Tuple 0 1], Tuple "back" [Tuple 0 0],
                       Tuple "few" [Tuple 1 1], Tuple "future" [Tuple 3 0],
                       Tuple "good" [Tuple 2 1], Tuple "man" [Tuple 3 1],
                       Tuple "the" [Tuple 2 0], Tuple "to" [Tuple 1 0]]

       (toList <<< createTermIndex) ["A few good men", "All the President's men"]
         `shouldEqual`[Tuple "a" [Tuple 0 0], Tuple "all" [Tuple 0 1], Tuple "few"[Tuple 1 0],
                       Tuple "good" [Tuple 2 0], Tuple "men" [Tuple 3 1, Tuple 3 0],
                       Tuple "presidents" [Tuple 2 1], Tuple "the" [Tuple 1 1]]

       (toList <<< createTermIndex) ["Back to the future", "In to the future", "Back in time"]
         `shouldEqual`[Tuple "back" [Tuple 0 2, Tuple 0 0],
                       Tuple "future" [Tuple 3 1 , Tuple 3 0], Tuple "in" [Tuple 1 2, Tuple 0 1],
                       Tuple "the" [Tuple 2 1, Tuple 2 0], Tuple "time"[Tuple 2 2],
                       Tuple "to" [Tuple 1 1, Tuple 1 0]]

  describe "search tests" $ do

    it "should find single word document" $ do
        let index = createIndex ["Hello"]
        search index "Hello" `shouldEqual` [Tuple "hello" (Tuple 0 0)]

    it "should find word in two words document" $ do
        let index = createIndex ["Hello World"]
        search index "World" `shouldEqual` [Tuple "world" (Tuple 1 0)]

    it "should find word in two lines doc" $ do
        let index = createIndex ["Hello", "World"]
        search index "World" `shouldEqual` [Tuple "world" (Tuple 0 1)]

    it "should find most likely line" $ do
        let index = createIndex [
               "Back to the future",
               "Behind enemy lines",
               "Behind the planet of the apes",
               "Planet of the apes"]
        search index "Behind enemy" `shouldEqual` [Tuple "behind" (Tuple 0 1), Tuple "enemy" (Tuple 1 1)]

  describe "Partial term index tests" $ do

    it "should find all words starting with" $ do
        let partial_term_index  = createPartialTermIndex (words "welcome to the real world of back and bad")
        searchTermsFromPartial (toCharArray "b") partial_term_index `shouldEqual` (Tuple true [toCharArray "back", toCharArray "bad"])
        searchTermsFromPartial (toCharArray "ba") partial_term_index `shouldEqual` (Tuple true [toCharArray "back", toCharArray "bad"])
        searchTermsFromPartial (toCharArray "bac") partial_term_index `shouldEqual` (Tuple true [toCharArray "back"])
        searchTermsFromPartial (toCharArray "bad") partial_term_index `shouldEqual` (Tuple true [])
        searchTermsFromPartial (toCharArray "backs") partial_term_index `shouldEqual` (Tuple false [])
        searchTermsFromPartial (toCharArray "w") partial_term_index `shouldEqual` (Tuple true [toCharArray "welcome", toCharArray "world"])
        searchTermsFromPartial (toCharArray "wel") partial_term_index `shouldEqual` (Tuple true [toCharArray "welcome"])
        searchTermsFromPartial (toCharArray "wo") partial_term_index `shouldEqual` (Tuple true [toCharArray "world"])

module Main where

import Data.Tuple
import Data.Map      (toList)
import SearchEngine
import Test.Spec (describe, pending, it)
import Test.Spec.Node
import Test.Spec.Assertions
import Test.Spec.Reporter.Console

main = runNode [consoleReporter] do

  describe "numLines tests" $ do

    it "should return first line with index" $
      numLines ["Hello World"] `shouldEqual` [Tuple "Hello World" 0]

    it "should return two lines with index" $
      numLines ["Hello", "World"] `shouldEqual` [Tuple "Hello" 0, Tuple "World" 1]

    it "should return n lines with index" $
      numLines ["Welcome to", "Real World", "of Haskell"]
       `shouldEqual` [Tuple "Welcome to" 0, Tuple "Real World" 1, Tuple "of Haskell" 2]

  describe "cleanWords tests" $ do

    it "should return words" $
       cleanWords ["Hello", "World"] `shouldEqual` ["hello", "world"]

    it "should remove numbers" $
       cleanWords ["Welcome6"] `shouldEqual` ["welcome"]

    it "should remove non ascii chars" $
       cleanWords ["This,", "is", "an", "experiment'", "of", "great", "%"]
         `shouldEqual` ["this", "is", "an", "experiment", "of", "great"]

  describe "allNumWords tests" $ do

    it "should convert lines in to words keeping line numbers" $
       allNumWords [Tuple "Welcome to" 0, Tuple "the real" 1]
         `shouldEqual` [Tuple "welcome" (Tuple 0 0), Tuple "to" (Tuple 1 0), Tuple "the" (Tuple 0 1), Tuple "real" (Tuple 1 1)]

    it "should clean while splitting into words" $
       allNumWords [Tuple "Lo ha detto papa'" 0, Tuple "che va' bene, capito" 1]
         `shouldEqual` [Tuple "lo" (Tuple 0 0), Tuple "ha" (Tuple 1 0), Tuple "detto" (Tuple 2 0), Tuple "papa" (Tuple 3 0),
                     Tuple "che" (Tuple 0 1), Tuple "va" (Tuple 1 1), Tuple "bene" (Tuple 2 1), Tuple "capito" (Tuple 3 1)]

  describe "createTermIndex tests" $ do

    it "should create an empty index for an empty document" $
       (toList <<< createTermIndex) []
         `shouldEqual` []

    it "should create an index of one element for a single word doc" $
       (toList <<< createTermIndex) ["Hello"]
         `shouldEqual` [Tuple "hello" [Tuple 0 0]]

    it "should create an index" $ do
       (toList <<< createTermIndex) ["Hello World"]
         `shouldEqual` [Tuple "hello" [Tuple 0 0], Tuple "world" [Tuple 1 0]]

       (toList <<< createTermIndex) ["Back to the Future", "A few good man"]
         `shouldEqual`[Tuple "a" [Tuple 0 1], Tuple "back" [Tuple 0 0],
                       Tuple "few" [Tuple 1 1], Tuple "future" [Tuple 3 0],
                       Tuple "good" [Tuple 2 1], Tuple "man" [Tuple 3 1],
                       Tuple "the" [Tuple 2 0], Tuple "to" [Tuple 1 0]]

       (toList <<< createTermIndex) ["A few good men", "All the President's men"]
         `shouldEqual`[Tuple "a" [Tuple 0 0], Tuple "all" [Tuple 0 1], Tuple "few"[Tuple 1 0],
                       Tuple "good" [Tuple 2 0], Tuple "men" [Tuple 3 1, Tuple 3 0],
                       Tuple "presidents" [Tuple 2 1], Tuple "the" [Tuple 1 1]]

       (toList <<< createTermIndex) ["Back to the future", "In to the future", "Back in time"]
         `shouldEqual`[Tuple "back" [Tuple 0 2, Tuple 0 0],
                       Tuple "future" [Tuple 3 1 , Tuple 3 0], Tuple "in" [Tuple 1 2, Tuple 0 1],
                       Tuple "the" [Tuple 2 1, Tuple 2 0], Tuple "time"[Tuple 2 2],
                       Tuple "to" [Tuple 1 1, Tuple 1 0]]


[CSE-68] Explicitly discard results in `do` blocks

- needed by `psc 0.11.x`

module Explorer.Api.Socket where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (Error)
import Control.SocketIO.Client (Event, Host)
import Data.Argonaut.Core (Json)
import Data.Array (foldl, last)
import Data.Either (Either)
import Data.Foreign (Foreign)
import Data.Generic (class Generic, gShow)
import Data.Maybe (fromMaybe)
import Data.String (Pattern(..), Replacement(..), replaceAll, split, trim)
import Debug.Trace (traceAnyM)
import Explorer.Api.Helper (decodeResult')
import Explorer.Types.Actions (Action(..), ActionChannel)
import Explorer.Util.Config (Protocol(..))
import Pos.Explorer.Socket.Methods (ClientEvent, ServerEvent)
import Pos.Explorer.Web.ClientTypes (CTxId)
import Signal.Channel (CHANNEL, send)

-- | We need to have socket.io on port 8110 when testing (without `https`).
-- When we deploy on production we use nginx forwarding, so we send it to the
-- default port (443) and nginx forwards it to 8110 on the server.
mkSocketHost :: Protocol -> String -> Host
mkSocketHost Http  hostname = "http://"  <> hostname <> ":8110"
mkSocketHost Https hostname = "https://" <> hostname

-- events

class SocketEvent a where
    toEvent :: a -> String

instance socketEventServerEvent :: SocketEvent ClientEvent where
    toEvent = showEvent

instance socketEventClientEvent :: SocketEvent ServerEvent where
    toEvent = showEvent

-- | Helper to grab event names from ClientEvent | ServerEvent
-- | _Note_: We can't create a generic show instances from these types,
-- | because they are generated by purescript-bridge
showEvent :: forall b. (Generic b) => b -> String
showEvent t =
    trim <<< getModuleNames <<< split (Pattern " ") $ gShow t
    where
        getModuleNames m = foldl (\acc mn -> acc <> " " <> getModuleName mn) "" m
        getModuleName n = fromMaybe "" <<< last $ split (Pattern ".") n

-- | Helper function to remove """ from event names
cleanEventName :: Event -> Event
cleanEventName = replaceAll (Pattern "\"") (Replacement "")

connectEvent :: Event
connectEvent = "connect"

closeEvent :: Event
closeEvent = "close"

-- event handler

connectHandler :: forall eff. ActionChannel -> Foreign
    -> Eff (channel :: CHANNEL | eff) Unit
connectHandler channel _ =
    send channel $ SocketConnected true

closeHandler :: forall eff. ActionChannel -> Foreign
    -> Eff (channel :: CHANNEL | eff) Unit
closeHandler channel _ =
    send channel $ SocketConnected false

addressTxsUpdatedEventHandler :: forall eff. ActionChannel -> Json
    -> Eff (channel :: CHANNEL | eff) Unit
addressTxsUpdatedEventHandler channel json =
    let result = decodeResult' json in
    send channel $ SocketAddressTxsUpdated result

blocksPageUpdatedEventHandler :: forall eff. ActionChannel -> Json
    -> Eff (channel :: CHANNEL | eff) Unit
blocksPageUpdatedEventHandler channel json =
    let result = decodeResult' json in
    send channel $ SocketBlocksPageUpdated result

txsUpdatedHandler :: forall eff. ActionChannel -> Json
    -> Eff (channel :: CHANNEL | eff) Unit
txsUpdatedHandler channel json =
    let result = decodeResult' json in
    send channel $ SocketTxsUpdated result

callYouEventHandler :: forall eff. ActionChannel -> Foreign -> Eff eff Unit
callYouEventHandler channel _ =
    -- just an empty callback to be connected with socket.io
    pure unit

-- all following event handler are for debugging only

callYouStringEventHandler :: forall eff. ActionChannel -> String
    -> Eff (channel :: CHANNEL | eff) Unit
callYouStringEventHandler channel str = do
    _ <- traceAnyM "callYouStringEventHandler"
    _ <- traceAnyM str
    send channel NoOp

callYouCTxIdEventHandler :: forall eff. ActionChannel -> Json
    -> Eff (channel :: CHANNEL | eff) Unit
callYouCTxIdEventHandler channel json = do
    _ <- traceAnyM "callYouCTxIdEventHandler"
    _ <- traceAnyM json
    let result = decodeResult' json
    _ <- traceAnyM (result :: Either Error CTxId)
    send channel NoOp

module Explorer.Api.Socket where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (Error)
import Control.SocketIO.Client (Event, Host)
import Data.Argonaut.Core (Json)
import Data.Array (foldl, last)
import Data.Either (Either)
import Data.Foreign (Foreign)
import Data.Generic (class Generic, gShow)
import Data.Maybe (fromMaybe)
import Data.String (Pattern(..), Replacement(..), replaceAll, split, trim)
import Debug.Trace (traceAnyM)
import Explorer.Api.Helper (decodeResult')
import Explorer.Types.Actions (Action(..), ActionChannel)
import Explorer.Util.Config (Protocol(..))
import Pos.Explorer.Socket.Methods (ClientEvent, ServerEvent)
import Pos.Explorer.Web.ClientTypes (CTxId)
import Signal.Channel (CHANNEL, send)

-- | We need to have socket.io on port 8110 when testing (without `https`).
-- When we deploy on production we use nginx forwarding, so we send it to the
-- default port (443) and nginx forwards it to 8110 on the server.
mkSocketHost :: Protocol -> String -> Host
mkSocketHost Http  hostname = "http://"  <> hostname <> ":8110"
mkSocketHost Https hostname = "https://" <> hostname

-- events

class SocketEvent a where
    toEvent :: a -> String

instance socketEventServerEvent :: SocketEvent ClientEvent where
    toEvent = showEvent

instance socketEventClientEvent :: SocketEvent ServerEvent where
    toEvent = showEvent

-- | Helper to grab event names from ClientEvent | ServerEvent
-- | _Note_: We can't create a generic show instances from these types,
-- | because they are generated by purescript-bridge
showEvent :: forall b. (Generic b) => b -> String
showEvent t =
    trim <<< getModuleNames <<< split (Pattern " ") $ gShow t
    where
        getModuleNames m = foldl (\acc mn -> acc <> " " <> getModuleName mn) "" m
        getModuleName n = fromMaybe "" <<< last $ split (Pattern ".") n

-- | Helper function to remove """ from event names
cleanEventName :: Event -> Event
cleanEventName = replaceAll (Pattern "\"") (Replacement "")

connectEvent :: Event
connectEvent = "connect"

closeEvent :: Event
closeEvent = "close"

-- event handler

connectHandler :: forall eff. ActionChannel -> Foreign
    -> Eff (channel :: CHANNEL | eff) Unit
connectHandler channel _ =
    send channel $ SocketConnected true

closeHandler :: forall eff. ActionChannel -> Foreign
    -> Eff (channel :: CHANNEL | eff) Unit
closeHandler channel _ =
    send channel $ SocketConnected false

addressTxsUpdatedEventHandler :: forall eff. ActionChannel -> Json
    -> Eff (channel :: CHANNEL | eff) Unit
addressTxsUpdatedEventHandler channel json =
    let result = decodeResult' json in
    send channel $ SocketAddressTxsUpdated result

blocksPageUpdatedEventHandler :: forall eff. ActionChannel -> Json
    -> Eff (channel :: CHANNEL | eff) Unit
blocksPageUpdatedEventHandler channel json =
    let result = decodeResult' json in
    send channel $ SocketBlocksPageUpdated result

txsUpdatedHandler :: forall eff. ActionChannel -> Json
    -> Eff (channel :: CHANNEL | eff) Unit
txsUpdatedHandler channel json =
    let result = decodeResult' json in
    send channel $ SocketTxsUpdated result

callYouEventHandler :: forall eff. ActionChannel -> Foreign -> Eff eff Unit
callYouEventHandler channel _ =
    -- just an empty callback to be connected with socket.io
    pure unit

-- all following event handler are for debugging only

callYouStringEventHandler :: forall eff. ActionChannel -> String
    -> Eff (channel :: CHANNEL | eff) Unit
callYouStringEventHandler channel str = do
    traceAnyM "callYouStringEventHandler"
    traceAnyM str
    send channel NoOp

callYouCTxIdEventHandler :: forall eff. ActionChannel -> Json
    -> Eff (channel :: CHANNEL | eff) Unit
callYouCTxIdEventHandler channel json = do
    traceAnyM "callYouCTxIdEventHandler"
    traceAnyM json
    let result = decodeResult' json
    traceAnyM (result :: Either Error CTxId)
    send channel NoOp


Ensure that index is increasing.

Ensure that index is increasing.

module Data.TimeSeries.IO (fromCsv, toCsv) where

import Prelude
import Data.Array as A
import Data.Maybe (Maybe, fromMaybe)
import Data.String as S
import Data.Tuple (Tuple(..), fst, snd)
import Global (readFloat)

import Data.TimeSeries.Time (Timestamp, parseISOTime, formatTime)
import Data.TimeSeries as TS

-- Improve readability of this module
type Column = Array

-- | Load all columns from CSV.
-- | First column is treated as a index for all Time Series.
-- | So this function will return #column-1 Time Series
fromCsv :: String -> Array (TS.Series Number)
fromCsv str = map (\c -> TS.series idx c) cs
    where
        lines = S.split (S.Pattern "\n") str
        parsedLines = keepMonotonous(parseLines lines)
        -- The following lines could be written as
        -- Tuple idx cs
        idx = fst parsedLines
        cs = snd parsedLines

parseLines :: Array String -> Tuple (Column Timestamp) (Array (Column Number))
parseLines lines = Tuple (map fst rows) (toColumns (map snd rows))
    where rows = A.mapMaybe parseRow lines

-- Parse single line and return index with array of column values
parseRow :: String -> Maybe (Tuple Timestamp (Array Number))
parseRow str = do
    let fields = S.split (S.Pattern ",") str
    idx <- A.head fields  >>= parseISOTime
    vs <- (map readFloat) <$> A.tail fields
    pure $ Tuple idx vs

-- Convert Array with rows into Array with columns
toColumns :: ∀ a. Array (Array a) -> Array (Array a)
toColumns rows = map col (A.range 0 (len-1))
    where
        len = fromMaybe 0 $ A.length <$> A.head rows
        col i = A.mapMaybe (\row -> A.index row i) rows

-- | Convert Series to the CSV format
toCsv :: ∀ a. Show a => TS.Series a -> String
toCsv xs = A.foldl f "time,value\n" $ TS.toDataPoints xs
    where
        f acc x = acc <> formatTime (TS.dpIndex x) <> "," <> show (TS.dpValue x) <> "\n"

-- Ensure that index is monotonically increasing
keepMonotonous :: Tuple (Column Timestamp) (Array (Column Number)) -> Tuple (Column Timestamp) (Array (Column Number))
keepMonotonous tuple = tp
    where
        idx = fst tuple
        n = A.length idx
        diff = A.zipWith (-) idx (A.cons 0.0 idx)
        i = fromMaybe n $ A.findIndex (\x -> x <= 0.0) diff
        tp = if i < (n - 1)
                then Tuple (A.take (i + 1) idx)(A.take (i + 1) (snd tuple))
                else Tuple (idx)((snd tuple))

module Data.TimeSeries.IO (fromCsv, toCsv) where

import Prelude
import Data.Array as A
import Data.Maybe (Maybe, fromMaybe)
import Data.String as S
import Data.Tuple (Tuple(..), fst, snd)
import Global (readFloat)

import Data.TimeSeries.Time (Timestamp, parseISOTime, formatTime)
import Data.TimeSeries as TS

-- Improve readability of this module
type Column = Array

-- | Load all columns from CSV.
-- | First column is treated as a index for all Time Series.
-- | So this function will return #column-1 Time Series
fromCsv :: String -> Array (TS.Series Number)
fromCsv str = map (\c -> TS.series idx c) cs
    where
        lines = S.split (S.Pattern "\n") str
        parsedLines = parseLines lines
        -- The following lines could be written as
        -- Tuple idx cs
        idx = fst parsedLines
        cs = snd parsedLines

parseLines :: Array String -> Tuple (Column Timestamp) (Array (Column Number))
parseLines lines = Tuple (map fst rows) (toColumns (map snd rows))
    where rows = A.mapMaybe parseRow lines

-- Parse single line and return index with array of column values
parseRow :: String -> Maybe (Tuple Timestamp (Array Number))
parseRow str = do
    let fields = S.split (S.Pattern ",") str
    idx <- A.head fields  >>= parseISOTime
    vs <- (map readFloat) <$> A.tail fields
    pure $ Tuple idx vs

-- Convert Array with rows into Array with columns
toColumns :: ∀ a. Array (Array a) -> Array (Array a)
toColumns rows = map col (A.range 0 (len-1))
    where
        len = fromMaybe 0 $ A.length <$> A.head rows
        col i = A.mapMaybe (\row -> A.index row i) rows

-- | Convert Series to the CSV format
toCsv :: ∀ a. Show a => TS.Series a -> String
toCsv xs = A.foldl f "time,value\n" $ TS.toDataPoints xs
    where
        f acc x = acc <> formatTime (TS.dpIndex x) <> "," <> show (TS.dpValue x) <> "\n"


Remove superfluous 'eff's

Remove superfluous 'eff's

module Main where

import qualified Control.Monad.JQuery as J
import           Control.Monad.Eff
import DOM
import Data.Foreign (unsafeFromForeign)

import Data.Either
import Data.Maybe
import Control.Apply ((*>))
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Eff.Class

import Web (exprToJQuery, getPath)
import Parser
import Evaluator
import AST

import Debug.Trace

main = J.ready $ do
  J.select "#input"
    >>= J.on "change" (\_ _ -> startEvaluation)
  startEvaluation

type DOMEff = Eff (dom :: DOM, trace :: Trace)

type EvalState = { env :: Env, expr :: Expr, history :: [Expr] }

type EvalM a = StateT EvalState DOMEff a

startEvaluation :: DOMEff Unit
startEvaluation = do
  definitions <- J.select "#definitions" >>= getValue
  let env = defsToEnv $ case parseDefs definitions of Right d -> d

  input       <- J.select "#input"       >>= getValue
  let expr = case parseExpr input of Right e -> e

  void $ runStateT showExpr { env: env, expr: expr, history: [] }

foreign import map
  """
  function map(callback) {
    return function(ob) {
      return function () {
        return ob.map( function(i, e) { return callback(jQuery(e))(); } );
      };
    };
  }
  """ :: (J.JQuery -> DOMEff Unit) -> J.JQuery -> DOMEff Unit

showExpr :: forall eff. EvalM Unit
showExpr = do
  outputContainer <- liftEff $ J.select "#output-container"
  liftEff $ J.clear outputContainer

  output <- liftEff $ J.create "

" >>= J.addClass "output"
  liftEff $ J.append output outputContainer

  { env = env, expr = expr } <- get :: EvalM EvalState

  jexpr <- liftEff $ exprToJQuery expr
  liftEff $ J.append jexpr output

  liftEff (J.find ".binary, .app, .func" output) >>= makeClickable
  liftEff (J.find ".clickable" output) >>= addMouseOverListener >>= addClickListener
  liftEff $ J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver)

  liftEff $ return unit :: DOMEff Unit

makeClickable :: J.JQuery -> EvalM Unit
makeClickable jq = do
  { env = env, expr = expr } <- get
  liftEff $ map (testEval env expr) jq
  where
  testEval :: Env -> Expr -> J.JQuery -> DOMEff Unit
  testEval env expr jq = do
    path <- getPath jq
    case evalPath1 env path expr of
      Nothing -> return unit
      Just _  -> void $ J.addClass "clickable" jq

addMouseOverListener :: J.JQuery -> EvalM J.JQuery
addMouseOverListener jq = liftEff $ J.on "mouseover" handler jq
  where
  handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler jEvent jq = do
    J.stopImmediatePropagation jEvent
    removeMouseOver
    J.addClass "mouseOver" jq
    return unit

addClickListener :: J.JQuery -> EvalM J.JQuery
addClickListener jq = do
  evaluationState <- get
  liftEff $ J.on "click" (handler evaluationState) jq
  where
  handler :: EvalState -> J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler evaluationState jEvent jq = do
    J.stopImmediatePropagation jEvent
    path <- getPath jq
    void $ runStateT (evalExpr path) evaluationState

removeMouseOver :: DOMEff Unit
removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOve"

evalExpr :: Path -> EvalM Unit
evalExpr path = do
  { env = env, expr = expr } <- get
  case evalPath1 env path expr of
    Nothing    -> return unit
    Just expr' -> do
      modify (\es -> es { expr = expr' })
      showEvaluationState

getValue :: J.JQuery -> DOMEff String
getValue jq = unsafeFromForeign <$> J.getValue jq

module Main where

import qualified Control.Monad.JQuery as J
import           Control.Monad.Eff
import DOM
import Data.Foreign (unsafeFromForeign)

import Data.Either
import Data.Maybe
import Control.Apply ((*>))
import Control.Monad.State.Trans
import Control.Monad.State.Class
import Control.Monad.Eff.Class

import Web (exprToJQuery, getPath)
import Parser
import Evaluator
import AST

import Debug.Trace

main = J.ready $ do
  J.select "#input"
    >>= J.on "change" (\_ _ -> startEvaluation)
  startEvaluation

type DOMEff = Eff (dom :: DOM, trace :: Trace)

type EvalState = { env :: Env, expr :: Expr, history :: [Expr] }

type EvalM a = StateT EvalState DOMEff a

startEvaluation :: DOMEff Unit
startEvaluation = do
  definitions <- J.select "#definitions" >>= getValue
  let env = defsToEnv $ case parseDefs definitions of Right d -> d

  input       <- J.select "#input"       >>= getValue
  let expr = case parseExpr input of Right e -> e

  void $ runStateT showExpr { env: env, expr: expr, history: [] }

foreign import map
  """
  function map(callback) {
    return function(ob) {
      return function () {
        return ob.map( function(i, e) { return callback(jQuery(e))(); } );
      };
    };
  }
  """ :: forall eff. (J.JQuery -> DOMEff Unit) -> J.JQuery -> DOMEff Unit

showExpr :: forall eff. EvalM Unit
showExpr = do
  outputContainer <- liftEff $ J.select "#output-container"
  liftEff $ J.clear outputContainer

  output <- liftEff $ J.create "

" >>= J.addClass "output"
  liftEff $ J.append output outputContainer

  { env = env, expr = expr } <- get :: EvalM EvalState

  jexpr <- liftEff $ exprToJQuery expr
  liftEff $ J.append jexpr output

  liftEff (J.find ".binary, .app, .func" output) >>= makeClickable
  liftEff (J.find ".clickable" output) >>= addMouseOverListener >>= addClickListener
  liftEff $ J.body >>= J.on "mouseover" (\_ _ -> removeMouseOver)

  liftEff $ return unit :: DOMEff Unit

makeClickable :: forall eff. J.JQuery -> EvalM Unit
makeClickable jq = do
  { env = env, expr = expr } <- get
  liftEff $ map (testEval env expr) jq
  where
  testEval :: Env -> Expr -> J.JQuery -> DOMEff Unit
  testEval env expr jq = do
    path <- getPath jq
    case evalPath1 env path expr of
      Nothing -> return unit
      Just _  -> void $ J.addClass "clickable" jq

addMouseOverListener :: J.JQuery -> EvalM J.JQuery
addMouseOverListener jq = liftEff $ J.on "mouseover" handler jq
  where
  handler :: J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler jEvent jq = do
    J.stopImmediatePropagation jEvent
    removeMouseOver
    J.addClass "mouseOver" jq
    return unit

addClickListener :: J.JQuery -> EvalM J.JQuery
addClickListener jq = do
  evaluationState <- get
  liftEff $ J.on "click" (handler evaluationState) jq
  where
  handler :: EvalState -> J.JQueryEvent -> J.JQuery -> DOMEff Unit
  handler evaluationState jEvent jq = do
    J.stopImmediatePropagation jEvent
    path <- getPath jq
    void $ runStateT (evalExpr path) evaluationState

removeMouseOver :: DOMEff Unit
removeMouseOver = void $ J.select ".mouseOver" >>= J.removeClass "mouseOve"

evalExpr :: forall eff. Path -> EvalM Unit
evalExpr path = do
  { env = env, expr = expr } <- get
  case evalPath1 env path expr of
    Nothing    -> return unit
    Just expr' -> do
      modify (\es -> es { expr = expr' })
      showExpr

getValue :: forall eff. J.JQuery -> DOMEff String
getValue jq = unsafeFromForeign <$> J.getValue jq


Eliminates built-in phantom datastore types.

Prior, the default phantom types were provided such that implementors could use
them to specify `Query` types of their database. However, it is better to let
the implementors provide their custom datastore phantom types themselves. In
addition, the implementation of `class Database` was actually coded incorrectly
based on the above and some incorrect assumptions.

module Abstract.Database
	( DATABASE
	, CollectionImpl
	, class ToDBObject
	, toDBObject
	, class FromDBObject
	, fromDBObject
	, class IsDBObject
	, Collection
	, Pagination(Pagination)
	, limit
	, skip
	, SortOrder(Ascending, Descending)
	, asc
	, desc
	, sortOrder
	, getClauseType
	, Clause
		( Equals
		, NotEquals
		, LessThan
		, LessThanOrEquals
		, GreaterThan
		, GreaterThanOrEquals
		, SortBy
		, Custom
		, Negate
		)
	, clause
	, LogicConnector(And, Or)
	, logicConnector
	, Predicate
	, Query(Query)
	, ordering
	, equals'
	, equals'Flipped
	, (==..)
	, equals
	, equalsFlipped
	, (==.)
	, notEquals'
	, notEquals'Flipped
	, (/=..)
	, (!=..)
	, notEquals
	, notEqualsFlipped
	, (/=.)
	, (!=.)
	, lessThan'
	, lessThan'Flipped
	, (<..)
	, lessThan
	, lessThanFlipped
	, (<.)
	, lessThanOrEquals'
	, lessThanOrEquals'Flipped
	, (<=..)
	, lessThanOrEquals
	, lessThanOrEqualsFlipped
	, (<=.)
	, greaterThan'
	, greaterThan'Flipped
	, (>..)
	, greaterThan
	, greaterThanFlipped
	, (>.)
	, greaterThanOrEquals'
	, greaterThanOrEquals'Flipped
	, (>=..)
	, greaterThanOrEquals
	, greaterThanOrEqualsFlipped
	, (>=.)
	, sortBy'
	, sortBy
	, custom'
	, custom
	, Entity(..)
	, class Database
	, createCollection
	, getCollection
	, deleteCollection
	, getWhere
	, getWhere'
	, countWhere
	, insert
	, insert'
	, deleteWhere
	) where

import Prelude
	( class Eq
	, class Functor
	, class Ord
	, class Semigroup
	, class Show
	, Ordering(EQ, GT, LT)
	, Unit
	, compare
	, const
	, flip
	, map
	, negate
	, show
	, zero
	, ($)
	, (&&)
	, (<>)
	, (==)
	, (>=>)
	, (<<<)
	, (>>>)
	, (<$>)
	)

import Control.Alt           (class Alt, (<|>))
import Control.Monad.Eff     (Eff)
import Control.Monad.Eff.Ref (REF, Ref)
import Control.Monad.Except  (mapExcept, runExcept)
import Data.Array            (length, range, zipWith)
import Data.Foreign
	( F
	, Foreign
	, ForeignError(ErrorAtIndex)
	, readArray
	, toForeign
	)
import Data.Bifunctor        (lmap)
import Data.Foreign.Class    (read, write)
import Data.Foreign.Null     (Null(Null), readNull, writeNull)
import Data.Foreign.NullOrUndefined
	( NullOrUndefined(NullOrUndefined)
	, readNullOrUndefined
	)
import Data.Foreign.Undefined
	( Undefined(Undefined)
	, readUndefined
	, writeUndefined
	)
import Data.Either           (Either(Left, Right), either)
import Data.List             (List, singleton, uncons)
import Data.Maybe            (Maybe(Just, Nothing), maybe)
import Data.Monoid           (class Monoid, mempty)
import Data.Traversable      (sequence)
import Unsafe.Coerce         (unsafeCoerce)

foreign import data DATABASE       :: !
foreign import data CollectionImpl :: *

class FromDBObject a where
	fromDBObject :: Foreign -> F a

instance booleanFromDBObject :: FromDBObject Boolean where
	fromDBObject = read

instance intFromDBObject :: FromDBObject Int where
	fromDBObject = read

instance numberFromDBObject :: FromDBObject Number where
	fromDBObject = read

instance charFromDBObject :: FromDBObject Char where
	fromDBObject = read

instance stringFromDBObject :: FromDBObject String where
	fromDBObject = read

instance foreignFromDBObject :: FromDBObject Foreign where
	fromDBObject = read

instance nullFromDBObject :: FromDBObject a => FromDBObject (Null a) where
	fromDBObject = readNull fromDBObject

instance undefinedFromDBObject :: FromDBObject a => FromDBObject (Undefined a) where
	fromDBObject = readUndefined fromDBObject

instance nullOrUndefinedFromDBObject :: FromDBObject a => FromDBObject (NullOrUndefined a) where
	fromDBObject = readNullOrUndefined fromDBObject

instance arrayFromDBObject :: FromDBObject a => FromDBObject (Array a) where
	fromDBObject = readArray >=> fromDBObjectElements
		where
			fromDBObjectWith f          = mapExcept (lmap f) <<< fromDBObject
			fromDBObjectElement i value = fromDBObjectWith (map (ErrorAtIndex i)) value
			fromDBObjectElements arr    = sequence (zipWith fromDBObjectElement (range zero (length arr)) arr)

class ToDBObject a where
	toDBObject :: a -> Foreign

instance booleanToDBObject :: ToDBObject Boolean where
	toDBObject = write

instance intToDBObject :: ToDBObject Int where
	toDBObject = write

instance numberToDBObject :: ToDBObject Number where
	toDBObject = write

instance charToDBObject :: ToDBObject Char where
	toDBObject = write

instance stringToDBObject :: ToDBObject String where
	toDBObject = write

instance foreignToDBObject :: ToDBObject Foreign where
	toDBObject = write

instance nullToDBObject :: ToDBObject a => ToDBObject (Null a) where
	toDBObject (Null a) = maybe writeNull toDBObject a

instance undefinedToDBObject :: ToDBObject a => ToDBObject (Undefined a) where
	toDBObject (Undefined a) = maybe writeUndefined toDBObject a

instance nullOrUndefinedToDBObject :: ToDBObject a => ToDBObject (NullOrUndefined a) where
	toDBObject (NullOrUndefined a) = toDBObject (Null a)

instance arrayToDBObject :: ToDBObject a => ToDBObject (Array a) where
	toDBObject = toForeign <<< map toDBObject

class (FromDBObject a, ToDBObject a) <= IsDBObject a

instance booleanIsDBObject :: IsDBObject Boolean

instance intIsDBObject :: IsDBObject Int

instance numberIsDBObject :: IsDBObject Number

instance charIsDBObject :: IsDBObject Char

instance stringIsDBObject :: IsDBObject String

instance foreignIsDBObject :: IsDBObject Foreign

instance nullIsDBObject :: IsDBObject a => IsDBObject (Null a)

instance undefinedIsDBObject :: IsDBObject a => IsDBObject (Undefined a)

instance nullOrUndefinedIsDBObject :: IsDBObject a => IsDBObject (NullOrUndefined a)

instance arrayIsDBObject :: IsDBObject a => IsDBObject (Array a)

type Collection t = { collectionImpl :: CollectionImpl }

newtype Pagination = Pagination
	{ skip   :: Maybe Int
	, limit  :: Maybe Int
	}

instance showPagination :: Show Pagination where
	show (Pagination p) = "(Pagination {"
		<> " skip: "   <> show p.skip
		<> ", limit: " <> show p.limit
		<> " })"

instance eqPagination :: Eq Pagination where
	eq p1 p2 = show p1 == show p2

instance ordPagination :: Ord Pagination where
	compare p1 p2 = compare (show p1) (show p2)

instance semigroupPagination :: Semigroup Pagination where
	append (Pagination p1) (Pagination p2) = Pagination
		{ skip: p2.skip     <|> p1.skip   <|> Nothing
		, limit : p2.limit  <|> p1.limit  <|> Nothing
		}

defPagination :: { skip :: Maybe Int, limit :: Maybe Int }
defPagination =
	{ skip : Nothing
	, limit: Nothing
	}

instance monoidPagination :: Monoid Pagination where
	mempty = Pagination defPagination

limit :: Int -> Maybe Pagination
limit l = Just $ Pagination defPagination { limit = Just l }

skip :: Int -> Maybe Pagination
skip o = Just $ Pagination defPagination { skip = Just o }

data SortOrder = Ascending | Descending

instance showSortOrder :: Show SortOrder where
	show Ascending  = "Ascending"
	show Descending = "Descending"

instance eqSortOrder :: Eq SortOrder where
	eq Ascending  Ascending  = true
	eq Descending Descending = true
	eq _          _          = false

instance ordSortOrder :: Ord SortOrder where
	compare Descending Ascending  = LT
	compare Ascending  Descending = GT
	compare _          _          = EQ

asc :: SortOrder
asc = Ascending

desc :: SortOrder
desc = Descending

sortOrder:: { asc :: SortOrder, desc :: SortOrder }
sortOrder =
	{ asc : Ascending
	, desc: Descending
	}

data Clause = Equals
	    | NotEquals
	    | LessThan
	    | LessThanOrEquals
	    | GreaterThan
	    | GreaterThanOrEquals
	    | SortBy { sortOrder :: SortOrder }
	    | Custom { name      :: String    }
	    | Negate { clause    :: Clause    }

instance showClause :: Show Clause where
	show Equals              = "Equals"
	show NotEquals           = "NotEquals"
	show LessThan            = "LessThan"
	show LessThanOrEquals    = "LessThanOrEquals"
	show GreaterThan         = "GreaterThan"
	show GreaterThanOrEquals = "GreaterThanOrEquals"
	show (SortBy s)          =
		"SortBy ({ sortOrder: " <> show s.sortOrder <> " })"
	show (Custom n)          = "Custom ({ name: " <> show n.name <> " })"
	show (Negate c)          =
		"Negate ({ clause: " <> show c.clause <> " })"

instance eqClause :: Eq Clause where
	eq c1 c2 = show c1 == show c2

getClauseType :: Clause -> String
getClauseType Equals              = "Equals"
getClauseType NotEquals           = "NotEquals"
getClauseType LessThan            = "LessThan"
getClauseType LessThanOrEquals    = "LessThanOrEquals"
getClauseType GreaterThan         = "GreaterThan"
getClauseType GreaterThanOrEquals = "GreaterThanOrEquals"
getClauseType (SortBy _)          = "SortBy"
getClauseType (Custom _)          = "Custom"
getClauseType (Negate _)          = "Negate"

clause :: { equals              :: String
	  , notEquals           :: String
	  , lessThan            :: String
	  , lessThanOrEquals    :: String
	  , greaterThan         :: String
	  , greaterThanOrEquals :: String
	  , sortBy              :: String
	  , custom              :: String
	  , negate              :: String
	  }
clause =
	{ equals             : getClauseType Equals
	, notEquals          : getClauseType NotEquals
	, lessThan           : getClauseType LessThan
	, lessThanOrEquals   : getClauseType LessThanOrEquals
	, greaterThan        : getClauseType GreaterThan
	, greaterThanOrEquals: getClauseType GreaterThanOrEquals
	, sortBy             : getClauseType $ SortBy { sortOrder: desc }
	, custom             : getClauseType $ Custom { name: mempty }
	, negate             : getClauseType $ Negate { clause: Equals }
	}

data LogicConnector = And | Or

logicConnector :: { and :: LogicConnector, or :: LogicConnector }
logicConnector =
	{ and: And
	, or : Or
	}

instance showLogicConnector :: Show LogicConnector where
	show And = "And"
	show Or  = "Or"

instance eqLogicConnector :: Eq LogicConnector where
	eq And And = true
	eq Or  Or  = true
	eq _   _   = false

type Predicate t =
	{ clause         :: Clause
	, logicConnector :: LogicConnector
	, clauseValue    :: Foreign
	, predicate      :: Either String (Foreign -> Maybe Foreign)
	}

showPredicate :: forall t. Predicate t -> String
showPredicate p = "({"
	<> " clause: "          <> show p.clause
	<> ", logicConnector: " <> show p.logicConnector
	<> ", clauseValue: "    <> "(Foreign)"
	<> ", predicate: "      <> "(Foreign -> Maybe Foreign)"
	<> " })"

data Query datastore t = Query (List (Predicate t))

instance showQuery :: Show (Query datastore t) where
	show (Query l) =
		"(Query (datastore) " <> show (map showPredicate l) <> ")"

instance semigroupQuery :: Semigroup (Query datastore t) where
	append (Query l1) (Query l2) = Query (l1 <> l2)

instance monoidQuery :: Monoid (Query datastore t) where
	mempty = Query mempty

instance functorQuery :: Functor (Query datastore) where
	map _ q = unsafeCoerce q -- Father, forgive me.

instance altQuery :: Alt (Query datastore) where
	alt (Query l1) (Query l2) =
		case uncons l2 of
			Just { head, tail } ->
				Query (l1 <> connectorToOr head <> tail)
			Nothing             -> Query l1
		where
			connectorToOr = singleton <<< _ { logicConnector = Or }

orderingToInt :: Ordering -> Int
orderingToInt LT = -1
orderingToInt EQ = 0
orderingToInt GT = 1

ordering :: { lt :: Int, eq :: Int, gt :: Int }
ordering =
	{ lt: orderingToInt LT
	, eq: orderingToInt EQ
	, gt: orderingToInt GT
	}

leftPredicate :: forall t a datastore. (ToDBObject a) =>
		 Clause                               ->
		 a                                    ->
		 String                               ->
		 Query datastore t
leftPredicate clause_ clauseValue fieldName = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : toDBObject clauseValue
	, predicate     : Left fieldName
	}

-- In this contexts this is used, it *should* never fail a conversion (because
-- this will most likely be used with data gotten back directly from the
-- datastore.
fromDBObject' :: forall t. FromDBObject t => Foreign -> Maybe t
fromDBObject' = fromDBObject >>> runExcept >>> either (const Nothing) Just

predicate' :: forall t a. (FromDBObject t, ToDBObject a) =>
	      (t -> a)                                   ->
	      Foreign                                    ->
	      Maybe Foreign
predicate' fn t' = (fn >>> toDBObject) <$> fromDBObject' t'

rightPredicate :: forall t a datastore. (FromDBObject t, ToDBObject a) =>
		  Clause                                               ->
		  a                                                    ->
		  (t -> a)                                             ->
		  Query datastore t
rightPredicate clause_ clauseValue fn = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : toDBObject clauseValue
	, predicate     : Right $ predicate' fn
	}

equals' :: forall datastore t e. (ToDBObject e, Eq e) =>
	   e                                          ->
	   String                                     ->
	   Query datastore t
equals' = leftPredicate Equals

equals'Flipped :: forall datastore t e. (ToDBObject e, Eq e) =>
		  String                                     ->
		  e                                          ->
		  Query datastore t
equals'Flipped = flip equals'
infix 4 equals'Flipped as ==..

equals :: forall datastore t e. (FromDBObject t, ToDBObject e, Eq e) =>
	  e                                                          ->
	  (t -> e)                                                   ->
	  Query datastore t
equals = rightPredicate Equals

equalsFlipped :: forall datastore t e. (FromDBObject t, ToDBObject e, Eq e) =>
		 (t -> e)                                                   ->
		 e                                                          ->
		 Query datastore t
equalsFlipped = flip equals
infix 4 equalsFlipped as ==.

notEquals' :: forall datastore t e. (ToDBObject e, Eq e) =>
	      e                                          ->
	      String                                     ->
	      Query datastore t
notEquals' = leftPredicate NotEquals

notEquals'Flipped :: forall datastore t e. (ToDBObject e, Eq e) =>
		     String                                     ->
		     e                                          ->
		     Query datastore t
notEquals'Flipped = flip notEquals'
infix 4 notEquals'Flipped as /=..
infix 4 notEquals'Flipped as !=..

notEquals :: forall datastore t e. (FromDBObject t, ToDBObject e, Eq e) =>
	     e                                                          ->
	     (t -> e)                                                   ->
	     Query datastore t
notEquals = rightPredicate NotEquals

notEqualsFlipped :: forall datastore t e. (FromDBObject t, ToDBObject e, Eq e) =>
		    (t -> e)                                                   ->
		    e                                                          ->
		    Query datastore t
notEqualsFlipped = flip notEquals
infix 4 notEquals' as /=.
infix 4 notEquals' as !=.

lessThan' :: forall datastore t o. (ToDBObject o, Ord o) =>
	     o                                           ->
	     String                                      ->
	     Query datastore t
lessThan' = leftPredicate LessThan

lessThan'Flipped :: forall datastore t o. (ToDBObject o, Ord o) =>
	     String                                             ->
	     o                                                  ->
	     Query datastore t
lessThan'Flipped = flip lessThan'
infixl 4 lessThan'Flipped as <..

lessThan :: forall datastore t o. (FromDBObject t, ToDBObject o, Ord o) =>
	    o                                                           ->
	    (t -> o)                                                    ->
	    Query datastore t
lessThan = rightPredicate LessThan

lessThanFlipped :: forall datastore t o. (FromDBObject t, ToDBObject o, Ord o) =>
		   (t -> o)                                                    ->
		   o                                                           ->
		   Query datastore t
lessThanFlipped = flip lessThan
infixl 4 lessThanFlipped as <.

lessThanOrEquals' :: forall datastore t o. (ToDBObject o, Ord o) =>
		     o                                           ->
		     String                                      ->
		     Query datastore t
lessThanOrEquals' = leftPredicate LessThanOrEquals

lessThanOrEquals'Flipped :: forall datastore t o. (ToDBObject o, Ord o) =>
			    String                                      ->
			    o                                           ->
			    Query datastore t
lessThanOrEquals'Flipped = flip lessThanOrEquals'
infixl 4 lessThanOrEquals'Flipped as <=..

lessThanOrEquals :: forall datastore t o. (FromDBObject t, ToDBObject o, Ord o) =>
		    o                                                           ->
		    (t -> o)                                                    ->
		    Query datastore t
lessThanOrEquals = rightPredicate LessThanOrEquals

lessThanOrEqualsFlipped :: forall datastore t o. (FromDBObject t, ToDBObject o, Ord o) =>
			   (t -> o)                                                    ->
			   o                                                           ->
			   Query datastore t
lessThanOrEqualsFlipped = flip lessThanOrEquals
infixl 4 lessThanOrEqualsFlipped as <=.

greaterThan' :: forall datastore t o. (ToDBObject o, Ord o) =>
		o                                           ->
		String                                      ->
		Query datastore t
greaterThan' = leftPredicate GreaterThan

greaterThan'Flipped :: forall datastore t o. (ToDBObject o, Ord o) =>
		       String                                      ->
		       o                                           ->
		       Query datastore t
greaterThan'Flipped = flip greaterThan'
infixl 4 greaterThan'Flipped as >..

greaterThan :: forall datastore t o. (FromDBObject t, ToDBObject o, Ord o) =>
	       o                                                           ->
	       (t -> o)                                                    ->
	       Query datastore t
greaterThan = rightPredicate GreaterThan

greaterThanFlipped :: forall datastore t o. (FromDBObject t, ToDBObject o, Ord o) =>
	       (t -> o)                                                           ->
	       o                                                                  ->
	       Query datastore t
greaterThanFlipped = flip greaterThan
infixl 4 greaterThanFlipped as >.

greaterThanOrEquals' :: forall datastore t o. (ToDBObject o, Ord o) =>
			o                                           ->
			String                                      ->
			Query datastore t
greaterThanOrEquals' = leftPredicate GreaterThanOrEquals

greaterThanOrEquals'Flipped :: forall datastore t o. (ToDBObject o, Ord o) =>
			       String                                      ->
			       o                                           ->
			       Query datastore t
greaterThanOrEquals'Flipped = flip greaterThanOrEquals'
infixl 4 greaterThanOrEquals'Flipped as >=..

greaterThanOrEquals :: forall datastore t o. (FromDBObject t, ToDBObject o, Ord o) =>
		       o                                                           ->
		       (t -> o)                                                    ->
		       Query datastore t
greaterThanOrEquals = rightPredicate GreaterThanOrEquals

greaterThanOrEqualsFlipped :: forall datastore t o. (FromDBObject t, ToDBObject o, Ord o) =>
		       (t -> o)                                                    ->
		       o                                                           ->
		       Query datastore t
greaterThanOrEqualsFlipped = flip greaterThanOrEquals
infixl 4 greaterThanOrEqualsFlipped as >=.

sortBy' :: forall datastore t. SortOrder -> String -> Query datastore t
sortBy' order fieldName = Query $ singleton $
	{ clause        : SortBy { sortOrder: order }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left fieldName
	}

sortBy :: forall datastore t. FromDBObject t =>
	  SortOrder                          ->
	  (t -> Ordering)                    ->
	  Query datastore t
sortBy order fn = Query $ singleton $
	{ clause        : SortBy { sortOrder: order }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right $ predicate' (fn >>> orderingToInt)
	}

custom' :: forall datastore t. String -> String -> Query datastore t
custom' name p = Query $ singleton $
	{ clause        : Custom { name }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left p
	}

custom :: forall datastore t. FromDBObject t =>
	  String                             ->
	  (t -> Boolean)                     ->
	  Query datastore t
custom name fn = Query $ singleton $
	{ clause        : Custom { name }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right $ predicate' fn
	}

data Entity key a = Entity key a | Entity' a

instance showEntity :: (Show key, Show a) => Show (Entity key a) where
	show (Entity key a) = "(Entity"
		<> " (" <> show key <> ")"
		<> " (" <> show a   <> ")"
		<> ")"
	show (Entity' a)     = "(Entity' (" <> show a <> "))"

instance eqEntity :: (Eq key, Eq a) => Eq (Entity key a) where
	eq (Entity k1 a1) (Entity k2 a2) = k1 == k2 && a1 == a2
	eq (Entity'   a1) (Entity'   a2) = a1 == a2
	eq              _              _ = false

instance ordEntity :: (Ord key, Ord a) => Ord (Entity key a) where
	compare (Entity k1 a1) (Entity k2 a2) = compare k1 k2 <> compare a1 a2
	compare (Entity'   a1) (Entity'   a2) = compare a1 a2
	-- I'm not entirely sure how an Entity with a key can be 'greater' than
	-- one without, but I've just decided to choose this implementation and
	-- stick with it.
	compare (Entity'    _) (Entity _   _) = LT
	compare (Entity _   _) (Entity'    _) = GT

class Database datastore where
	createCollection :: forall e. String -> Eff (db :: DATABASE | e) Unit
	getCollection    :: forall e t. String ->
			    Eff (db :: DATABASE, ref :: REF | e) (Ref (Collection t))
	deleteCollection :: forall e. String -> Eff (db :: DATABASE | e) Unit

	getWhere :: forall e t. FromDBObject t =>
		    Maybe Pagination           ->
		    Query datastore t          ->
		    Ref (Collection t)         ->
		    Eff (db :: DATABASE, ref :: REF | e) (Maybe t)

	getWhere' :: forall e t. FromDBObject t =>
		    Maybe Pagination            ->
		    Query datastore t           ->
		    Ref (Collection t)          ->
		    Eff (db :: DATABASE, ref :: REF | e) (List t)

	countWhere :: forall e t. FromDBObject t =>
		      Query datastore t          ->
		      Ref (Collection t)         ->
		      Eff (db :: DATABASE, ref :: REF | e) Int

	insert :: forall e t b. ToDBObject t =>
		  t                          ->
		  Ref (Collection t)         ->
		  Eff (db :: DATABASE, ref :: REF | e) b

	insert' :: forall e t b. ToDBObject t =>
		   List t                     ->
		   Ref (Collection t)         ->
		   Eff (db :: DATABASE, ref :: REF | e) b

	deleteWhere :: forall e t b. ToDBObject t =>
		       Query datastore t          ->
		       Ref (Collection t)         ->
		       Eff (db :: DATABASE, ref :: REF | e) b

module Abstract.Database
	( DATABASE
	, CollectionImpl
	, class ToDBObject
	, toDBObject
	, class FromDBObject
	, fromDBObject
	, class IsDBObject
	, Collection
	, Pagination(Pagination)
	, limit
	, skip
	, SortOrder(Ascending, Descending)
	, asc
	, desc
	, sortOrder
	, getClauseType
	, Clause
		( Equals
		, NotEquals
		, LessThan
		, LessThanOrEquals
		, GreaterThan
		, GreaterThanOrEquals
		, SortBy
		, Custom
		, Negate
		)
	, clause
	, LogicConnector(And, Or)
	, logicConnector
	, Predicate
	, SQL
	, Native
	, Query(Query)
	, ordering
	, equals'
	, equals'Flipped
	, (==..)
	, equals
	, equalsFlipped
	, (==.)
	, notEquals'
	, notEquals'Flipped
	, (/=..)
	, (!=..)
	, notEquals
	, notEqualsFlipped
	, (/=.)
	, (!=.)
	, lessThan'
	, lessThan'Flipped
	, (<..)
	, lessThan
	, lessThanFlipped
	, (<.)
	, lessThanOrEquals'
	, lessThanOrEquals'Flipped
	, (<=..)
	, lessThanOrEquals
	, lessThanOrEqualsFlipped
	, (<=.)
	, greaterThan'
	, greaterThan'Flipped
	, (>..)
	, greaterThan
	, greaterThanFlipped
	, (>.)
	, greaterThanOrEquals'
	, greaterThanOrEquals'Flipped
	, (>=..)
	, greaterThanOrEquals
	, greaterThanOrEqualsFlipped
	, (>=.)
	, sortBy'
	, sortBy
	, custom'
	, custom
	, Entity(..)
	, class Database
	, createCollection
	, getCollection
	, deleteCollection
	, getWhere
	, getWhere'
	, countWhere
	, insert
	, insert'
	, deleteWhere
	) where

import Prelude
	( class Eq
	, class Functor
	, class Ord
	, class Semigroup
	, class Show
	, Ordering(EQ, GT, LT)
	, Unit
	, compare
	, flip
	, map
	, negate
	, show
	, zero
	, ($)
	, (&&)
	, (<>)
	, (==)
	, (>=>)
	, (<<<)
	, (>>>)
	)

import Control.Alt           (class Alt, (<|>))
import Control.Monad.Eff     (Eff)
import Control.Monad.Eff.Ref (REF, Ref)
import Control.Monad.Except  (mapExcept)
import Data.Array            (length, range, zipWith)
import Data.Foreign
	( F
	, Foreign
	, ForeignError(ErrorAtIndex)
	, readArray
	, toForeign
	)
import Data.Bifunctor        (lmap)
import Data.Foreign.Class    (read, write)
import Data.Foreign.Null     (Null(Null), readNull, writeNull)
import Data.Foreign.NullOrUndefined
	( NullOrUndefined(NullOrUndefined)
	, readNullOrUndefined
	)
import Data.Foreign.Undefined
	( Undefined(Undefined)
	, readUndefined
	, writeUndefined
	)
import Data.Either           (Either(Left, Right))
import Data.List             (List, singleton, uncons)
import Data.Maybe            (Maybe(Just, Nothing), maybe)
import Data.Monoid           (class Monoid, mempty)
import Data.Traversable      (sequence)
import Unsafe.Coerce         (unsafeCoerce)

foreign import data DATABASE       :: !
foreign import data CollectionImpl :: *

class FromDBObject a where
	fromDBObject :: Foreign -> F a

instance booleanFromDBObject :: FromDBObject Boolean where
	fromDBObject = read

instance intFromDBObject :: FromDBObject Int where
	fromDBObject = read

instance numberFromDBObject :: FromDBObject Number where
	fromDBObject = read

instance charFromDBObject :: FromDBObject Char where
	fromDBObject = read

instance stringFromDBObject :: FromDBObject String where
	fromDBObject = read

instance foreignFromDBObject :: FromDBObject Foreign where
	fromDBObject = read

instance nullFromDBObject :: FromDBObject a => FromDBObject (Null a) where
	fromDBObject = readNull fromDBObject

instance undefinedFromDBObject :: FromDBObject a => FromDBObject (Undefined a) where
	fromDBObject = readUndefined fromDBObject

instance nullOrUndefinedFromDBObject :: FromDBObject a => FromDBObject (NullOrUndefined a) where
	fromDBObject = readNullOrUndefined fromDBObject

instance arrayFromDBObject :: FromDBObject a => FromDBObject (Array a) where
	fromDBObject = readArray >=> fromDBObjectElements
		where
			fromDBObjectWith f          = mapExcept (lmap f) <<< fromDBObject
			fromDBObjectElement i value = fromDBObjectWith (map (ErrorAtIndex i)) value
			fromDBObjectElements arr    = sequence (zipWith fromDBObjectElement (range zero (length arr)) arr)

class ToDBObject a where
	toDBObject :: a -> Foreign

instance booleanToDBObject :: ToDBObject Boolean where
	toDBObject = write

instance intToDBObject :: ToDBObject Int where
	toDBObject = write

instance numberToDBObject :: ToDBObject Number where
	toDBObject = write

instance charToDBObject :: ToDBObject Char where
	toDBObject = write

instance stringToDBObject :: ToDBObject String where
	toDBObject = write

instance foreignToDBObject :: ToDBObject Foreign where
	toDBObject = write

instance nullToDBObject :: ToDBObject a => ToDBObject (Null a) where
	toDBObject (Null a) = maybe writeNull toDBObject a

instance undefinedToDBObject :: ToDBObject a => ToDBObject (Undefined a) where
	toDBObject (Undefined a) = maybe writeUndefined toDBObject a

instance nullOrUndefinedToDBObject :: ToDBObject a => ToDBObject (NullOrUndefined a) where
	toDBObject (NullOrUndefined a) = toDBObject (Null a)

instance arrayToDBObject :: ToDBObject a => ToDBObject (Array a) where
	toDBObject = toForeign <<< map toDBObject

class (FromDBObject a, ToDBObject a) <= IsDBObject a

instance booleanIsDBObject :: IsDBObject Boolean

instance intIsDBObject :: IsDBObject Int

instance numberIsDBObject :: IsDBObject Number

instance charIsDBObject :: IsDBObject Char

instance stringIsDBObject :: IsDBObject String

instance foreignIsDBObject :: IsDBObject Foreign

instance nullIsDBObject :: IsDBObject a => IsDBObject (Null a)

instance undefinedIsDBObject :: IsDBObject a => IsDBObject (Undefined a)

instance nullOrUndefinedIsDBObject :: IsDBObject a => IsDBObject (NullOrUndefined a)

instance arrayIsDBObject :: IsDBObject a => IsDBObject (Array a)

type Collection t = { collectionImpl :: CollectionImpl }

newtype Pagination = Pagination
	{ skip   :: Maybe Int
	, limit  :: Maybe Int
	}

instance showPagination :: Show Pagination where
	show (Pagination p) = "(Pagination {"
		<> " skip: "   <> show p.skip
		<> ", limit: " <> show p.limit
		<> " })"

instance eqPagination :: Eq Pagination where
	eq p1 p2 = show p1 == show p2

instance ordPagination :: Ord Pagination where
	compare p1 p2 = compare (show p1) (show p2)

instance semigroupPagination :: Semigroup Pagination where
	append (Pagination p1) (Pagination p2) = Pagination
		{ skip: p2.skip     <|> p1.skip   <|> Nothing
		, limit : p2.limit  <|> p1.limit  <|> Nothing
		}

defPagination :: { skip :: Maybe Int, limit :: Maybe Int }
defPagination =
	{ skip : Nothing
	, limit: Nothing
	}

instance monoidPagination :: Monoid Pagination where
	mempty = Pagination defPagination

limit :: Int -> Maybe Pagination
limit l = Just $ Pagination defPagination { limit = Just l }

skip :: Int -> Maybe Pagination
skip o = Just $ Pagination defPagination { skip = Just o }

data SortOrder = Ascending | Descending

instance showSortOrder :: Show SortOrder where
	show Ascending  = "Ascending"
	show Descending = "Descending"

instance eqSortOrder :: Eq SortOrder where
	eq Ascending  Ascending  = true
	eq Descending Descending = true
	eq _          _          = false

instance ordSortOrder :: Ord SortOrder where
	compare Descending Ascending  = LT
	compare Ascending  Descending = GT
	compare _          _          = EQ

asc :: SortOrder
asc = Ascending

desc :: SortOrder
desc = Descending

sortOrder:: { asc :: SortOrder, desc :: SortOrder }
sortOrder =
	{ asc : Ascending
	, desc: Descending
	}

data Clause = Equals
	    | NotEquals
	    | LessThan
	    | LessThanOrEquals
	    | GreaterThan
	    | GreaterThanOrEquals
	    | SortBy { sortOrder :: SortOrder }
	    | Custom { name      :: String    }
	    | Negate { clause    :: Clause    }

instance showClause :: Show Clause where
	show Equals              = "Equals"
	show NotEquals           = "NotEquals"
	show LessThan            = "LessThan"
	show LessThanOrEquals    = "LessThanOrEquals"
	show GreaterThan         = "GreaterThan"
	show GreaterThanOrEquals = "GreaterThanOrEquals"
	show (SortBy s)          =
		"SortBy ({ sortOrder: " <> show s.sortOrder <> " })"
	show (Custom n)          = "Custom ({ name: " <> show n.name <> " })"
	show (Negate c)          =
		"Negate ({ clause: " <> show c.clause <> " })"

instance eqClause :: Eq Clause where
	eq c1 c2 = show c1 == show c2

getClauseType :: Clause -> String
getClauseType Equals              = "Equals"
getClauseType NotEquals           = "NotEquals"
getClauseType LessThan            = "LessThan"
getClauseType LessThanOrEquals    = "LessThanOrEquals"
getClauseType GreaterThan         = "GreaterThan"
getClauseType GreaterThanOrEquals = "GreaterThanOrEquals"
getClauseType (SortBy _)          = "SortBy"
getClauseType (Custom _)          = "Custom"
getClauseType (Negate _)          = "Negate"

clause :: { equals              :: String
	  , notEquals           :: String
	  , lessThan            :: String
	  , lessThanOrEquals    :: String
	  , greaterThan         :: String
	  , greaterThanOrEquals :: String
	  , sortBy              :: String
	  , custom              :: String
	  , negate              :: String
	  }
clause =
	{ equals             : getClauseType Equals
	, notEquals          : getClauseType NotEquals
	, lessThan           : getClauseType LessThan
	, lessThanOrEquals   : getClauseType LessThanOrEquals
	, greaterThan        : getClauseType GreaterThan
	, greaterThanOrEquals: getClauseType GreaterThanOrEquals
	, sortBy             : getClauseType $ SortBy { sortOrder: desc }
	, custom             : getClauseType $ Custom { name: mempty }
	, negate             : getClauseType $ Negate { clause: Equals }
	}

data LogicConnector = And | Or

logicConnector :: { and :: LogicConnector, or :: LogicConnector }
logicConnector =
	{ and: And
	, or : Or
	}

instance showLogicConnector :: Show LogicConnector where
	show And = "And"
	show Or  = "Or"

instance eqLogicConnector :: Eq LogicConnector where
	eq And And = true
	eq Or  Or  = true
	eq _   _   = false

type Predicate t =
	{ clause         :: Clause
	, logicConnector :: LogicConnector
	, clauseValue    :: Foreign
	, predicate      :: Either String (t -> Foreign)
	}

showPredicate :: forall t. Predicate t -> String
showPredicate p = "({"
	<> " clause: "          <> show p.clause
	<> ", logicConnector: " <> show p.logicConnector
	<> ", clauseValue: "    <> "(Foreign)"
	<> ", predicate: "      <> "(t -> Foreign)"
	<> " })"

data SQL
data Native

data Query datastore t = Query (List (Predicate t))

instance showQuery :: Show (Query datastore t) where
	show (Query l) =
		"(Query (datastore) " <> show (map showPredicate l) <> ")"

instance semigroupQuery :: Semigroup (Query datastore t) where
	append (Query l1) (Query l2) = Query (l1 <> l2)

instance monoidQuery :: Monoid (Query datastore t) where
	mempty = Query mempty

instance functorQuery :: Functor (Query datastore) where
	map _ q = unsafeCoerce q -- Father, forgive me.

instance altQuery :: Alt (Query datastore) where
	alt (Query l1) (Query l2) =
		case uncons l2 of
			Just { head, tail } ->
				Query (l1 <> connectorToOr head <> tail)
			Nothing             -> Query l1
		where
			connectorToOr = singleton <<< _ { logicConnector = Or }

orderingToInt :: Ordering -> Int
orderingToInt LT = -1
orderingToInt EQ = 0
orderingToInt GT = 1

ordering :: { lt :: Int, eq :: Int, gt :: Int }
ordering =
	{ lt: orderingToInt LT
	, eq: orderingToInt EQ
	, gt: orderingToInt GT
	}

leftPredicate :: forall t a datastore. (ToDBObject a) =>
		 Clause                               ->
		 a                                    ->
		 String                               ->
		 Query datastore t
leftPredicate clause_ clauseValue fieldName = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : toDBObject clauseValue
	, predicate     : Left fieldName
	}

rightPredicate :: forall t a datastore. (ToDBObject a) =>
		  Clause                               ->
		  a                                    ->
		  (t -> a)                             ->
		  Query datastore t
rightPredicate clause_ clauseValue fn = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : toDBObject clauseValue
	, predicate     : Right (fn >>> toDBObject)
	}

equals' :: forall t e. (ToDBObject e, Eq e) => e -> String -> Query SQL t
equals' = leftPredicate Equals

equals'Flipped :: forall t e. (ToDBObject e, Eq e) =>
		  String                           ->
		  e                                ->
		  Query SQL t
equals'Flipped = flip equals'
infix 4 equals'Flipped as ==..

equals :: forall t e. (ToDBObject e, Eq e) =>
	  e                                ->
	  (t -> e)                         ->
	  Query Native t
equals = rightPredicate Equals

equalsFlipped :: forall t e. (ToDBObject e, Eq e) =>
		 (t -> e)                         ->
		 e                                ->
		 Query Native t
equalsFlipped = flip equals
infix 4 equalsFlipped as ==.

notEquals' :: forall t e. (ToDBObject e, Eq e) => e -> String -> Query SQL t
notEquals' = leftPredicate NotEquals

notEquals'Flipped :: forall t e. (ToDBObject e, Eq e) =>
		     String                           ->
		     e                                ->
		     Query SQL t
notEquals'Flipped = flip notEquals'
infix 4 notEquals'Flipped as /=..
infix 4 notEquals'Flipped as !=..

notEquals :: forall t e. (ToDBObject e, Eq e) =>
	     e                                ->
	     (t -> e)                         ->
	     Query Native t
notEquals = rightPredicate NotEquals

notEqualsFlipped :: forall t e. (ToDBObject e, Eq e) =>
		    (t -> e)                         ->
		    e                                ->
		    Query Native t
notEqualsFlipped = flip notEquals
infix 4 notEquals' as /=.
infix 4 notEquals' as !=.

lessThan' :: forall t o. (ToDBObject o, Ord o) => o -> String -> Query SQL t
lessThan' = leftPredicate LessThan

lessThan'Flipped :: forall t o. (ToDBObject o, Ord o) =>
		    String                            ->
		    o                                 ->
		    Query SQL t
lessThan'Flipped = flip lessThan'
infixl 4 lessThan'Flipped as <..

lessThan :: forall t o. (ToDBObject o, Ord o) =>
	    o                                 ->
	    (t -> o)                          ->
	    Query Native t
lessThan = rightPredicate LessThan

lessThanFlipped :: forall t o. (ToDBObject o, Ord o) =>
		   (t -> o)                          ->
		   o                                 ->
		   Query Native t
lessThanFlipped = flip lessThan
infixl 4 lessThanFlipped as <.

lessThanOrEquals' :: forall t o. (ToDBObject o, Ord o) =>
		     o                                 ->
		     String                            ->
		     Query SQL t
lessThanOrEquals' = leftPredicate LessThanOrEquals

lessThanOrEquals'Flipped :: forall t o. (ToDBObject o, Ord o) =>
			    String                            ->
			    o                                 ->
			    Query SQL t
lessThanOrEquals'Flipped = flip lessThanOrEquals'
infixl 4 lessThanOrEquals'Flipped as <=..

lessThanOrEquals :: forall t o. (ToDBObject o, Ord o) =>
		    o                                 ->
		    (t -> o)                          ->
		    Query Native t
lessThanOrEquals = rightPredicate LessThanOrEquals

lessThanOrEqualsFlipped :: forall t o. (ToDBObject o, Ord o) =>
			   (t -> o)                          ->
			   o                                 ->
			   Query Native t
lessThanOrEqualsFlipped = flip lessThanOrEquals
infixl 4 lessThanOrEqualsFlipped as <=.

greaterThan' :: forall t o. (ToDBObject o, Ord o) =>
		o                                 ->
		String                            ->
		Query SQL t
greaterThan' = leftPredicate GreaterThan

greaterThan'Flipped :: forall t o. (ToDBObject o, Ord o) =>
		       String                            ->
		       o                                 ->
		       Query SQL t
greaterThan'Flipped = flip greaterThan'
infixl 4 greaterThan'Flipped as >..

greaterThan :: forall t o. (ToDBObject o, Ord o) =>
	       o                                 ->
	       (t -> o)                          ->
	       Query Native t
greaterThan = rightPredicate GreaterThan

greaterThanFlipped :: forall t o. (ToDBObject o, Ord o) =>
		     (t -> o)                           ->
		     o                                  ->
		     Query Native t
greaterThanFlipped = flip greaterThan
infixl 4 greaterThanFlipped as >.

greaterThanOrEquals' :: forall t o. (ToDBObject o, Ord o) =>
			o                                 ->
			String                            ->
			Query SQL t
greaterThanOrEquals' = leftPredicate GreaterThanOrEquals

greaterThanOrEquals'Flipped :: forall t o. (ToDBObject o, Ord o) =>
			       String                            ->
			       o                                 ->
			       Query SQL t
greaterThanOrEquals'Flipped = flip greaterThanOrEquals'
infixl 4 greaterThanOrEquals'Flipped as >=..

greaterThanOrEquals :: forall t o. (ToDBObject o, Ord o) =>
		       o                                 ->
		       (t -> o)                          ->
		       Query Native t
greaterThanOrEquals = rightPredicate GreaterThanOrEquals

greaterThanOrEqualsFlipped :: forall t o. (ToDBObject o, Ord o) =>
			      (t -> o)                          ->
			      o                                 ->
			      Query Native t
greaterThanOrEqualsFlipped = flip greaterThanOrEquals
infixl 4 greaterThanOrEqualsFlipped as >=.

sortBy' :: forall datastore t. SortOrder -> String -> Query datastore t
sortBy' order fieldName = Query $ singleton $
	{ clause        : SortBy { sortOrder: order }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left fieldName
	}

sortBy :: forall datastore t. SortOrder ->
	  (t -> Ordering)               ->
	  Query datastore t
sortBy order fn = Query $ singleton $
	{ clause        : SortBy { sortOrder: order }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> orderingToInt >>> toDBObject)
	}

custom' :: forall t. String -> String -> Query SQL t
custom' name p = Query $ singleton $
	{ clause        : Custom { name }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left p
	}

custom :: forall t. String -> (t -> Boolean) -> Query Native t
custom name fn = Query $ singleton $
	{ clause        : Custom { name }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> toDBObject)
	}

data Entity key a = Entity key a | Entity' a

instance showEntity :: (Show key, Show a) => Show (Entity key a) where
	show (Entity key a) = "(Entity"
		<> " (" <> show key <> ")"
		<> " (" <> show a   <> ")"
		<> ")"
	show (Entity' a)     = "(Entity' (" <> show a <> "))"

instance eqEntity :: (Eq key, Eq a) => Eq (Entity key a) where
	eq (Entity k1 a1) (Entity k2 a2) = k1 == k2 && a1 == a2
	eq (Entity'   a1) (Entity'   a2) = a1 == a2
	eq              _              _ = false

instance ordEntity :: (Ord key, Ord a) => Ord (Entity key a) where
	compare (Entity k1 a1) (Entity k2 a2) = compare k1 k2 <> compare a1 a2
	compare (Entity'   a1) (Entity'   a2) = compare a1 a2
	-- I'm not entirely sure how an Entity with a key can be 'greater' than
	-- one without, but I've just decided to choose this implementation and
	-- stick with it.
	compare (Entity'    _) (Entity _   _) = LT
	compare (Entity _   _) (Entity'    _) = GT

class Database d datastore where
	createCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit
	getCollection    :: forall e t. String ->
			    Eff (db :: DATABASE, ref :: REF | e) (Ref (Collection t))
	deleteCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit

	getWhere :: forall e t. FromDBObject t =>
		    Maybe Pagination           ->
		    Query datastore t          ->
		    Ref (Collection t)         ->
		    Eff (db :: DATABASE, ref :: REF | e) (Maybe t)

	getWhere' :: forall e t. FromDBObject t =>
		    Maybe Pagination            ->
		    Query datastore t           ->
		    Ref (Collection t)          ->
		    Eff (db :: DATABASE, ref :: REF | e) (List t)

	countWhere :: forall e t. FromDBObject t =>
		      Query datastore t          ->
		      Ref (Collection t)         ->
		      Eff (db :: DATABASE, ref :: REF | e) Int

	insert :: forall e t b. ToDBObject t =>
		  t                          ->
		  Ref (Collection t)         ->
		  Eff (db :: DATABASE, ref :: REF | e) b

	insert' :: forall e t b. ToDBObject t =>
		   List t                     ->
		   Ref (Collection t)         ->
		   Eff (db :: DATABASE, ref :: REF | e) b

	deleteWhere :: forall e t b. ToDBObject t =>
		       Query datastore t          ->
		       Ref (Collection t)         ->
		       Eff (db :: DATABASE, ref :: REF | e) b