Correct namespace

Correct namespace

Original commit 5e420aa7d47f2ad5e616d859511a1f166ef32c6c

module CSharp
    ( renderer
    ) where

import Doc
import IR
import Prelude
import Types

import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as Set
import Data.String.Util (capitalize, camelCase)
import Data.Tuple as Tuple

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , render: renderCSharp
    }

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

nullableFromSet :: Set.Set IRType -> Maybe IRType
nullableFromSet s =
    case L.fromFoldable s of
    IRNull : x : L.Nil -> Just x
    x : IRNull : L.Nil -> Just x
    _ -> Nothing

renderUnionToCSharp :: Set.Set IRType -> String
renderUnionToCSharp s =
    case nullableFromSet s of
    Just x -> if isValueType x then renderTypeToCSharp x <> "?" else renderTypeToCSharp x
    Nothing -> "Either<" <> intercalate ", " (Set.map renderTypeToCSharp s) <> ">"

renderTypeToCSharp :: IRType -> String
renderTypeToCSharp = case _ of
    IRNothing -> "object"
    IRNull -> "object"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> renderTypeToCSharp a <> "[]"
    IRClass (IRClassData name _) -> csNameStyle name
    IRUnion types -> renderUnionToCSharp types

renderCSharp :: L.List IRClassData -> Doc Unit
renderCSharp classes = do
    line "namespace QuickType"
    line "{"
    blank

    indent do
        line "using Newtonsoft.Json;"
        blank
        for_ classes \cls -> do
            renderCSharpClass cls
            blank
    line "}"

csNameStyle :: String -> String
csNameStyle = camelCase >>> capitalize

renderCSharpClass :: IRClassData -> Doc Unit
renderCSharpClass (IRClassData name properties) = do
    line $ words ["class", csNameStyle name]
    line "{"
    indent do
        for_ (Map.toUnfoldable properties :: Array _) \(Tuple.Tuple pname ptype) -> do
            line do
                string "[JsonProperty(\""
                string pname
                string "\")]"
            line do
                string "public "
                string $ renderTypeToCSharp ptype
                words ["", csNameStyle pname, "{ get; set; }"]
                blank
    line "}"

module CSharp
    ( renderer
    ) where

import Doc
import IR
import Prelude
import Types

import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..))
import Data.Set as Set
import Data.String.Util (capitalize, camelCase)
import Data.Tuple as Tuple

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , render: renderCSharp
    }

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

nullableFromSet :: Set.Set IRType -> Maybe IRType
nullableFromSet s =
    case L.fromFoldable s of
    IRNull : x : L.Nil -> Just x
    x : IRNull : L.Nil -> Just x
    _ -> Nothing

renderUnionToCSharp :: Set.Set IRType -> String
renderUnionToCSharp s =
    case nullableFromSet s of
    Just x -> if isValueType x then renderTypeToCSharp x <> "?" else renderTypeToCSharp x
    Nothing -> "Either<" <> intercalate ", " (Set.map renderTypeToCSharp s) <> ">"

renderTypeToCSharp :: IRType -> String
renderTypeToCSharp = case _ of
    IRNothing -> "object"
    IRNull -> "object"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> renderTypeToCSharp a <> "[]"
    IRClass (IRClassData name _) -> csNameStyle name
    IRUnion types -> renderUnionToCSharp types

renderCSharp :: L.List IRClassData -> Doc Unit
renderCSharp classes = do
    line "namespace QuickType"
    line "{"
    blank

    indent do
        line "using Newtonsoft.Json.JsonPropertyAttribute;"
        blank
        for_ classes \cls -> do
            renderCSharpClass cls
            blank
    line "}"

csNameStyle :: String -> String
csNameStyle = camelCase >>> capitalize

renderCSharpClass :: IRClassData -> Doc Unit
renderCSharpClass (IRClassData name properties) = do
    line $ words ["class", csNameStyle name]
    line "{"
    indent do
        for_ (Map.toUnfoldable properties :: Array _) \(Tuple.Tuple pname ptype) -> do
            line do
                string "[JsonProperty(\""
                string pname
                string "\")]"
            line do
                string "public "
                string $ renderTypeToCSharp ptype
                words ["", csNameStyle pname, "{ get; set; }"]
                blank
    line "}"


Update for Map.toAscUnfoldable becoming default

module Data.Interval.Duration.Iso
  ( IsoDuration
  , unIsoDuration
  , mkIsoDuration
  , Error(..)
  , Errors
  , prettyError
  ) where

import Prelude

import Control.Plus (empty)
import Data.Either (Either(..))
import Data.Foldable (fold, foldMap)
import Data.Interval.Duration (Duration(..), DurationComponent(..))
import Data.List (List(..), reverse, span, null)
import Data.List.NonEmpty (fromList)
import Data.List.Types (NonEmptyList)
import Data.Map as Map
import Data.Maybe (Maybe(..), isJust)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..), snd)
import Math as Math

newtype IsoDuration = IsoDuration Duration

derive instance eqIsoDuration :: Eq IsoDuration
derive instance ordIsoDuration :: Ord IsoDuration
instance showIsoDuration :: Show IsoDuration where
  show (IsoDuration d) = "(IsoDuration " <> show d <> ")"

type Errors = NonEmptyList Error

data Error
  = IsEmpty
  | InvalidWeekComponentUsage
  | ContainsNegativeValue DurationComponent
  | InvalidFractionalUse DurationComponent

derive instance eqError :: Eq Error
derive instance ordError :: Ord Error
instance showError :: Show Error where
  show (IsEmpty) = "(IsEmpty)"
  show (InvalidWeekComponentUsage) = "(InvalidWeekComponentUsage)"
  show (ContainsNegativeValue c) = "(ContainsNegativeValue " <> show c <> ")"
  show (InvalidFractionalUse c) = "(InvalidFractionalUse " <> show c <> ")"

prettyError :: Error -> String
prettyError (IsEmpty) = "Duration is empty (has no components)"
prettyError (InvalidWeekComponentUsage) = "Week component of Duration is used with other components"
prettyError (ContainsNegativeValue c) = "Component `" <> show c <> "` contains negative value"
prettyError (InvalidFractionalUse c) = "Invalid usage of Fractional value at component `" <> show c <> "`"

unIsoDuration :: IsoDuration -> Duration
unIsoDuration (IsoDuration a) = a

mkIsoDuration :: Duration -> Either Errors IsoDuration
mkIsoDuration d = case fromList (checkValidIsoDuration d) of
  Just errs -> Left errs
  Nothing -> Right (IsoDuration d)

checkValidIsoDuration :: Duration -> List Error
checkValidIsoDuration (Duration asMap) = check {asList, asMap}
  where
  asList = reverse (Map.toUnfoldable asMap)
  check = fold
    [ checkWeekUsage
    , checkEmptiness
    , checkFractionalUse
    , checkNegativeValues
    ]

type CheckEnv =
  { asList :: List (Tuple DurationComponent Number)
  , asMap :: Map.Map DurationComponent Number}

checkWeekUsage :: CheckEnv -> List Error
checkWeekUsage {asMap} = if isJust (Map.lookup Week asMap) && Map.size asMap > 1
  then pure InvalidWeekComponentUsage else empty

checkEmptiness :: CheckEnv -> List Error
checkEmptiness {asList} = if null asList then pure IsEmpty else empty

checkFractionalUse :: CheckEnv -> List Error
checkFractionalUse {asList} = case _.rest (span (snd >>> not isFractional) asList) of
  Cons (Tuple c _) rest | checkRest rest -> pure (InvalidFractionalUse c)
  _ -> empty
  where
  isFractional a = Math.floor a /= a
  checkRest rest = unwrap (foldMap (snd >>> Math.abs >>> Additive) rest) > 0.0

checkNegativeValues :: CheckEnv -> List Error
checkNegativeValues {asList} = flip foldMap asList \(Tuple c num) ->
  if num >= 0.0 then empty else pure (ContainsNegativeValue c)

module Data.Interval.Duration.Iso
  ( IsoDuration
  , unIsoDuration
  , mkIsoDuration
  , Error(..)
  , Errors
  , prettyError
  ) where

import Prelude

import Control.Plus (empty)
import Data.Either (Either(..))
import Data.Foldable (fold, foldMap)
import Data.Interval.Duration (Duration(..), DurationComponent(..))
import Data.List (List(..), reverse, span, null)
import Data.List.NonEmpty (fromList)
import Data.List.Types (NonEmptyList)
import Data.Map as Map
import Data.Maybe (Maybe(..), isJust)
import Data.Monoid.Additive (Additive(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..), snd)
import Math as Math

newtype IsoDuration = IsoDuration Duration

derive instance eqIsoDuration :: Eq IsoDuration
derive instance ordIsoDuration :: Ord IsoDuration
instance showIsoDuration :: Show IsoDuration where
  show (IsoDuration d) = "(IsoDuration " <> show d <> ")"

type Errors = NonEmptyList Error

data Error
  = IsEmpty
  | InvalidWeekComponentUsage
  | ContainsNegativeValue DurationComponent
  | InvalidFractionalUse DurationComponent

derive instance eqError :: Eq Error
derive instance ordError :: Ord Error
instance showError :: Show Error where
  show (IsEmpty) = "(IsEmpty)"
  show (InvalidWeekComponentUsage) = "(InvalidWeekComponentUsage)"
  show (ContainsNegativeValue c) = "(ContainsNegativeValue " <> show c <> ")"
  show (InvalidFractionalUse c) = "(InvalidFractionalUse " <> show c <> ")"

prettyError :: Error -> String
prettyError (IsEmpty) = "Duration is empty (has no components)"
prettyError (InvalidWeekComponentUsage) = "Week component of Duration is used with other components"
prettyError (ContainsNegativeValue c) = "Component `" <> show c <> "` contains negative value"
prettyError (InvalidFractionalUse c) = "Invalid usage of Fractional value at component `" <> show c <> "`"

unIsoDuration :: IsoDuration -> Duration
unIsoDuration (IsoDuration a) = a

mkIsoDuration :: Duration -> Either Errors IsoDuration
mkIsoDuration d = case fromList (checkValidIsoDuration d) of
  Just errs -> Left errs
  Nothing -> Right (IsoDuration d)

checkValidIsoDuration :: Duration -> List Error
checkValidIsoDuration (Duration asMap) = check {asList, asMap}
  where
  asList = reverse (Map.toAscUnfoldable asMap)
  check = fold
    [ checkWeekUsage
    , checkEmptiness
    , checkFractionalUse
    , checkNegativeValues
    ]

type CheckEnv =
  { asList :: List (Tuple DurationComponent Number)
  , asMap :: Map.Map DurationComponent Number}

checkWeekUsage :: CheckEnv -> List Error
checkWeekUsage {asMap} = if isJust (Map.lookup Week asMap) && Map.size asMap > 1
  then pure InvalidWeekComponentUsage else empty

checkEmptiness :: CheckEnv -> List Error
checkEmptiness {asList} = if null asList then pure IsEmpty else empty

checkFractionalUse :: CheckEnv -> List Error
checkFractionalUse {asList} = case _.rest (span (snd >>> not isFractional) asList) of
  Cons (Tuple c _) rest | checkRest rest -> pure (InvalidFractionalUse c)
  _ -> empty
  where
  isFractional a = Math.floor a /= a
  checkRest rest = unwrap (foldMap (snd >>> Math.abs >>> Additive) rest) > 0.0

checkNegativeValues :: CheckEnv -> List Error
checkNegativeValues {asList} = flip foldMap asList \(Tuple c num) ->
  if num >= 0.0 then empty else pure (ContainsNegativeValue c)


Add support for clicking glyphs with features

module Genetics.Browser.UI.Native where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, delay, forkAff, launchAff)
import Control.Monad.Aff.AVar (makeVar, peekVar, putVar, takeVar, tryPeekVar)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Random (randomRange)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Free (foldFree)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State.Trans (StateT(..), evalStateT, execStateT, put)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Writer (Writer, execWriter, tell)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((..))
import Data.Either (Either(..))
import Data.Eq (class Eq1, eq1)
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Identity (Identity(..))
import Data.Int (round, toNumber)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe, Maybe(Just, Nothing), fromJust, isNothing)
import Data.Monoid (class Monoid)
import Data.Newtype (class Newtype, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (sequence_, traverse, traverse_)
import Data.Tuple (Tuple(..), snd)
import FRP (FRP)
import FRP.Event (Event, sampleOn_)
import FRP.Event as FRP
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Glyph (Glyph, circle, fill, path, stroke)
import Genetics.Browser.GlyphF (GlyphF(..))
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.GlyphF.Log (showGlyph)
import Genetics.Browser.Units (Bp(..), BpPerPixel(..), Chr(..), bpToPixels, pixelsToBp)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

type Point = { x :: Number
             , y :: Number }

type Fetch eff = Aff eff (Array (Feature Bp Number))

fileFetch :: String
          -> View
          -> Fetch _
fileFetch url view = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe (Feature Bp Number)
      f j = do
            obj <- j ^? _Object
            min <- Bp <$> obj ^? ix "min" <<< _Number
            max <- Bp <$> obj ^? ix "max" <<< _Number
            score <- Global.readFloat <$> obj ^? ix "pValue" <<< _String
            pure $ Feature (Chr "chr11") min max ((-2.0) * (Math.log score / Math.log 10.0))

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

glyphify :: Number
         -> View
         -> Feature Bp Number
         -> Glyph Unit
glyphify h v (Feature chr min max score) = do
  let height = 10.0
      y = h - (score + height)
      x = bpToPixels v.scale (min - v.min)
  stroke "black"
  fill "red"
  circle { x, y } 3.0

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

fetchToCanvas :: Number -> (View -> Fetch _) -> View -> Context2D -> Aff _ Unit
fetchToCanvas h f v ctx = do
  features <- f v
  let gs = traverse_ (glyphify h v) features
  liftEff $ renderGlyph ctx gs

glyphifyFeatures :: Number
                 -> Array (Feature Bp Number)
                 -> View
                 -> (Array (Tuple (Feature Bp Number) (Glyph Unit)))
glyphifyFeatures h fs v = gs
  where gs = map (\f -> Tuple f (glyphify h v f)) fs

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
foreign import scrollCanvas :: forall eff.
                               CanvasElement
                            -> CanvasElement
                            -> Point
                            -> Eff eff Unit

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { w :: Number, h :: Number }
                         -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
                                                        , total :: Nullable Point }

foreign import canvasEvent :: String -> CanvasElement -> Event Point

canvasDrag :: CanvasElement -> Event (Either Point Point)
canvasDrag el = f <$> canvasDragImpl el
  where f ev = case toMaybe ev.during of
          Just p  -> Right p
          Nothing -> Left $ unsafePartial $ fromJust (toMaybe ev.total)

type View = { min :: Bp
            , max :: Bp
            , scale :: BpPerPixel
            }

data UpdateView = ScrollBp Bp
                | ScrollPixels Number
                | SetRange Bp Bp
                | ModScale (BpPerPixel -> BpPerPixel)
                | SetScale BpPerPixel

modScale :: View
         -> (BpPerPixel -> BpPerPixel)
         -> View
modScale v f = { scale, min: mid - d, max: mid + d }
  where bpsWide = v.max - v.min
        pixelsWide = bpToPixels v.scale bpsWide
        mid = v.min + ((v.max - v.min) * Bp 0.5)
        scale = f v.scale
        bpsWide' = pixelsToBp scale pixelsWide
        d = bpsWide' * Bp 0.5

viewBehavior :: Event UpdateView
             -> View
             -> Event View
viewBehavior ev v = FRP.fold f ev v
  where f :: UpdateView -> View -> View
        f (ScrollBp x) v' = v' { min = v'.min + x
                               , max = v'.max + x }

        f (ScrollPixels x) v' = v' { min = v'.min - (pixelsToBp v'.scale x)
                                   , max = v'.max - (pixelsToBp v'.scale x) }

        f (SetRange min' max') v' = v' { min = min'
                                       , max = max' }

        f (ModScale g) v' = modScale v' g

        f (SetScale s) v' = modScale v' (const s)

-- how far to scroll when clicking a button
btnScroll :: Bp -> Event UpdateView
btnScroll x = f' (-x) <$> buttonEvent "scrollLeft" <|>
              f'   x  <$> buttonEvent "scrollRight"
  where f' = const <<< ScrollBp

btnZoom :: (BpPerPixel -> BpPerPixel)
        -> (BpPerPixel -> BpPerPixel)
        -> Event UpdateView
btnZoom zIn zOut = f' zOut <$> buttonEvent "zoomOut" <|>
                   f' zIn  <$> buttonEvent "zoomIn"
  where f' = const <<< ModScale

foreign import setViewUI :: forall eff. String -> Eff eff Unit

-- TODO: set a range to jump the view to
-- DONE: zoom in and out
-- TODO: set zoom/scale
-- TODO: window/canvas resizing

widthToView :: Number
            -> { min :: Bp, max :: Bp }
            -> View
widthToView w { min, max } = { min, max, scale }
  where scale = BpPerPixel $ (unwrap (max - min)) / w

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoom :: CanvasElement -> Event UpdateView
scrollZoom el = map (ModScale <<< f) $ canvasWheelEvent el
  where f :: Number -> (BpPerPixel -> BpPerPixel)
        f dY = over BpPerPixel $ (_ * (1.0 + (dY / 30.0)))

newtype GlyphBounds = GlyphBounds (Point -> Boolean)

derive instance newtypeGlyphBounds :: Newtype GlyphBounds _

instance semigroupGlyphBounds :: Semigroup GlyphBounds where
  append (GlyphBounds a) (GlyphBounds b) = GlyphBounds (a || b)

instance monoidGlyphBounds :: Monoid GlyphBounds where
  mempty = GlyphBounds $ const false

glyphBoundsNat :: GlyphF ~> Writer GlyphBounds
glyphBoundsNat (Circle p r a) = do
  tell $ GlyphBounds \p' -> let x' = p'.x - p.x
                                y' = p'.y - p.y
                            in Math.sqrt ((x' * x') + (y' * y')) < r
  pure a
glyphBoundsNat (Line _ _ a) = pure a
glyphBoundsNat (Rect p1 p2 a) = do
  tell $ GlyphBounds \p' -> (p'.x > p1.x && p'.x < p2.x) &&
                            (p'.y > p1.y && p'.y < p2.y)
  pure a
glyphBoundsNat (Stroke _ a) = pure a
glyphBoundsNat (Fill _ a) = pure a
glyphBoundsNat (Path _ a) = pure a

glyphBounds :: forall a. Glyph a -> GlyphBounds
glyphBounds = execWriter <<< foldFree glyphBoundsNat

-- Filters a collection of glyphs annotated with some functor,
-- returning glyphs that cover the given point on the canvas
clickAnnGlyphs :: forall f g a.
                  Filterable f
               => Functor g
               => Eq1 g
               => f (g (Glyph a))
               -> Point
               -> f (g (Glyph a))
clickAnnGlyphs gs p =
    filter (\x -> map pred x `eq1` map (const true) x) gs
  where pred = \g -> unwrap (glyphBounds g) p

-- For collections of unannotated glyphs
clickGlyphs :: forall f a.
               Filterable f
            => f (Glyph a)
            -> Point
            -> f (Glyph a)
clickGlyphs fs p = unwrap $ clickAnnGlyphs (Identity fs) p

browser :: Aff _ Unit
browser = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}

  browserState <- makeVar

  let minView = Bp 200000.0
      maxView = Bp 300000.0
      v = widthToView w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch "./gwas.json"

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls
      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = viewBehavior updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    -- fetch
    _ <- launchAff do
      fgs <- (\f' -> glyphifyFeatures h f' v') <$> f v'
      putVar browserState { featsAndGlyphs: fgs
                          , view: v' }
      liftEff do
        clearCanvas canvas
        traverse_ (renderGlyph ctx <<< snd) fgs

    setViewUI $ "View range: "
             <> show (round $ unwrap v'.min) <> " - "
             <> show (round $ unwrap v'.max)

  -- thread rendering view
  -- _ <- forkAff $ forever do
    -- render when the view & features have been updated
    -- state <- peekVar browserState
    -- liftEff do
    --   clearCanvas canvas
    --   traverse_ (renderGlyph ctx <<< snd) state.featsAndGlyphs
      -- renderFeatures h state.glyphs state.view ctx

  _ <- liftEff $ unsafeCoerceEff $
       FRP.subscribe (canvasEvent "click" canvas) \p -> launchAff do
         state <- tryPeekVar browserState
         liftEff $ log $ "clicked: (" <> show p.x <> ", " <> show p.y <> ")"
         case state of
           Nothing -> liftEff $ log "no state!"
           Just s' -> do
             liftEff $ log "state!"
             let gs' :: _
                 gs' = clickAnnGlyphs s'.featsAndGlyphs p

             traverse_ (liftEff <<< log <<< showGlyph <<< snd) gs'

  -- render first frame
  fetchToCanvas h f v ctx

main :: Eff _ _
main = launchAff browser

module Genetics.Browser.UI.Native where

import Prelude

import Control.Alt ((<|>))
import Control.Monad.Aff (Aff, delay, forkAff, launchAff)
import Control.Monad.Aff.AVar (makeVar, putVar, takeVar)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Random (randomRange)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Free (foldFree)
import Control.Monad.Rec.Class (forever)
import Control.Monad.State.Trans (StateT(..), evalStateT, execStateT, put)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Writer (Writer, execWriter, tell)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array, _Number, _Object, _String)
import Data.Array ((..))
import Data.Either (Either(..))
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Int (round, toNumber)
import Data.Lens ((^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe, Maybe(Just, Nothing), fromJust, isNothing)
import Data.Monoid (class Monoid)
import Data.Newtype (class Newtype, over, unwrap, wrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (sequence_, traverse, traverse_)
import Data.Tuple (Tuple(..), snd)
import FRP (FRP)
import FRP.Event (Event, sampleOn_)
import FRP.Event as FRP
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Glyph (Glyph, circle, fill, path, stroke)
import Genetics.Browser.GlyphF (GlyphF(..))
import Genetics.Browser.GlyphF.Canvas (renderGlyph)
import Genetics.Browser.GlyphF.Log (showGlyph)
import Genetics.Browser.Units (Bp(..), BpPerPixel(..), Chr(..), bpToPixels, pixelsToBp)
import Global as Global
import Global.Unsafe (unsafeStringify)
import Graphics.Canvas (CanvasElement, Context2D, getCanvasElementById, getCanvasHeight, getContext2D, setCanvasWidth)
import Math as Math
import Network.HTTP.Affjax as Affjax
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

type Point = { x :: Number
             , y :: Number }

type Fetch eff = Aff eff (Array (Feature Bp Number))

fileFetch :: String
          -> View
          -> Fetch _
fileFetch url view = do
  json <- _.response <$> Affjax.get url

  let f :: Json -> Maybe (Feature Bp Number)
      f j = do
            obj <- j ^? _Object
            min <- Bp <$> obj ^? ix "min" <<< _Number
            max <- Bp <$> obj ^? ix "max" <<< _Number
            score <- Global.readFloat <$> obj ^? ix "pValue" <<< _String
            pure $ Feature (Chr "chr11") min max ((-2.0) * (Math.log score / Math.log 10.0))

  case traverse f =<< json ^? _Array of
    Nothing -> throwError $ error "Failed to parse JSON features"
    Just fs -> pure $ fs

glyphify :: Number
         -> View
         -> Feature Bp Number
         -> Glyph Unit
glyphify h v (Feature chr min max score) = do
  let height = 10.0
      y = h - (score + height)
      x = bpToPixels v.scale (min - v.min)
  stroke "black"
  fill "red"
  circle { x, y } 3.0

canvasElementToHTML :: CanvasElement -> HTMLElement
canvasElementToHTML = unsafeCoerce

fetchToCanvas :: Number -> (View -> Fetch _) -> View -> Context2D -> Aff _ Unit
fetchToCanvas h f v ctx = do
  features <- f v
  let gs = traverse_ (glyphify h v) features
  liftEff $ renderGlyph ctx gs

renderFeatures :: Number -> Array (Feature Bp Number) -> View -> Context2D -> Eff _ Unit
renderFeatures h fs v ctx = do
  let gs = traverse_ (glyphify h v) fs
  renderGlyph ctx gs

foreign import getScreenSize :: forall eff. Eff eff { w :: Number, h :: Number }

-- 1st element is a backbuffer, 2nd the one shown on screen
foreign import scrollCanvas :: forall eff.
                               CanvasElement
                            -> CanvasElement
                            -> Point
                            -> Eff eff Unit

-- creates a new CanvasElement, not attached to the DOM and thus not visible
foreign import newCanvas :: forall eff.
                            { w :: Number, h :: Number }
                         -> Eff eff CanvasElement

foreign import clearCanvas :: forall eff. CanvasElement -> Eff eff Unit

-- set an event to fire on the given button id
foreign import buttonEvent :: String
                           -> Event Unit

foreign import canvasDragImpl :: CanvasElement -> Event { during :: Nullable Point
                                                        , total :: Nullable Point }

foreign import canvasEvent :: String -> CanvasElement -> Event Point

canvasDrag :: CanvasElement -> Event (Either Point Point)
canvasDrag el = f <$> canvasDragImpl el
  where f ev = case toMaybe ev.during of
          Just p  -> Right p
          Nothing -> Left $ unsafePartial $ fromJust (toMaybe ev.total)

type View = { min :: Bp
            , max :: Bp
            , scale :: BpPerPixel
            }

data UpdateView = ScrollBp Bp
                | ScrollPixels Number
                | SetRange Bp Bp
                | ModScale (BpPerPixel -> BpPerPixel)
                | SetScale BpPerPixel

modScale :: View
         -> (BpPerPixel -> BpPerPixel)
         -> View
modScale v f = { scale, min: mid - d, max: mid + d }
  where bpsWide = v.max - v.min
        pixelsWide = bpToPixels v.scale bpsWide
        mid = v.min + ((v.max - v.min) * Bp 0.5)
        scale = f v.scale
        bpsWide' = pixelsToBp scale pixelsWide
        d = bpsWide' * Bp 0.5

viewBehavior :: Event UpdateView
             -> View
             -> Event View
viewBehavior ev v = FRP.fold f ev v
  where f :: UpdateView -> View -> View
        f (ScrollBp x) v' = v' { min = v'.min + x
                               , max = v'.max + x }

        f (ScrollPixels x) v' = v' { min = v'.min - (pixelsToBp v'.scale x)
                                   , max = v'.max - (pixelsToBp v'.scale x) }

        f (SetRange min' max') v' = v' { min = min'
                                       , max = max' }

        f (ModScale g) v' = modScale v' g

        f (SetScale s) v' = modScale v' (const s)

-- how far to scroll when clicking a button
btnScroll :: Bp -> Event UpdateView
btnScroll x = f' (-x) <$> buttonEvent "scrollLeft" <|>
              f'   x  <$> buttonEvent "scrollRight"
  where f' = const <<< ScrollBp

btnZoom :: (BpPerPixel -> BpPerPixel)
        -> (BpPerPixel -> BpPerPixel)
        -> Event UpdateView
btnZoom zIn zOut = f' zOut <$> buttonEvent "zoomOut" <|>
                   f' zIn  <$> buttonEvent "zoomIn"
  where f' = const <<< ModScale

foreign import setViewUI :: forall eff. String -> Eff eff Unit

-- TODO: set a range to jump the view to
-- DONE: zoom in and out
-- TODO: set zoom/scale
-- TODO: window/canvas resizing

widthToView :: Number
            -> { min :: Bp, max :: Bp }
            -> View
widthToView w { min, max } = { min, max, scale }
  where scale = BpPerPixel $ (unwrap (max - min)) / w

foreign import canvasWheelEvent :: CanvasElement -> Event Number

scrollZoom :: CanvasElement -> Event UpdateView
scrollZoom el = map (ModScale <<< f) $ canvasWheelEvent el
  where f :: Number -> (BpPerPixel -> BpPerPixel)
        f dY = over BpPerPixel $ (_ * (1.0 + (dY / 30.0)))

newtype GlyphBounds = GlyphBounds (Point -> Boolean)

derive instance newtypeGlyphBounds :: Newtype GlyphBounds _

instance semigroupGlyphBounds :: Semigroup GlyphBounds where
  append (GlyphBounds a) (GlyphBounds b) = GlyphBounds (a || b)

instance monoidGlyphBounds :: Monoid GlyphBounds where
  mempty = GlyphBounds $ const false

glyphBoundsNat :: GlyphF ~> Writer GlyphBounds
glyphBoundsNat (Circle p r a) = do
  tell $ GlyphBounds \p' -> let x' = p'.x - p.x
                                y' = p'.y - p.y
                            in Math.sqrt ((x' * x') + (y' * y')) < r
  pure a
glyphBoundsNat (Line _ _ a) = pure a
glyphBoundsNat (Rect p1 p2 a) = do
  tell $ GlyphBounds \p' -> (p'.x > p1.x && p'.x < p2.x) &&
                            (p'.y > p1.y && p'.y < p2.y)
  pure a
glyphBoundsNat (Stroke _ a) = pure a
glyphBoundsNat (Fill _ a) = pure a
glyphBoundsNat (Path _ a) = pure a

glyphBounds :: forall a. Glyph a -> GlyphBounds
glyphBounds = execWriter <<< foldFree glyphBoundsNat

clickGlyphs :: forall f a.
               Filterable f
            => f (Glyph a)
            -> Point
            -> f (Glyph a)
clickGlyphs gs p = filter pred gs
  where pred = \g -> unwrap (glyphBounds g) p
foreign import subscribeM :: forall m eff a r.
                             MonadEff (frp :: FRP | eff) m
                          => Event a
                          -> (a -> m r)
                          -> m (Eff (frp :: FRP | eff) Unit)
browser :: Aff _ Unit
browser = do
  canvas <- liftEff $ unsafePartial $ fromJust <$> getCanvasElementById "canvas"
  ctx <- liftEff $ getContext2D canvas

  {w,h} <- liftEff do
    {w} <- getScreenSize
    h <- getCanvasHeight canvas
    _ <- setCanvasWidth (w-2.0) canvas
    pure {w, h}

  backCanvas <- liftEff $ newCanvas {w,h}

  browserState <- makeVar

  let minView = Bp 200000.0
      maxView = Bp 300000.0
      v = widthToView w { min: minView, max: maxView }
      f :: View -> Fetch _
      f = fileFetch "./gwas.json"

  let cDrag = canvasDrag canvas
      lefts = case _ of
        Left x -> Just x
        Right _ -> Nothing
      -- the alt operator <|> combines the two event streams,
      -- resulting in an event of both button-click scrolls
      -- and canvas-drag scrolls
      dragScroll = filterMap (map (ScrollPixels <<< _.x) <<< lefts) cDrag
      updateViews = btnScroll (Bp 500.0)
                <|> dragScroll
                <|> btnZoom (wrap <<< (_ * 0.8) <<< unwrap)
                            (wrap <<< (_ * 1.2) <<< unwrap)
                <|> scrollZoom canvas
      viewB = viewBehavior updateViews v

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe cDrag $ case _ of
    Left _      -> pure unit
    Right {x,y} -> scrollCanvas backCanvas canvas {x: -x, y: 0.0}

  _ <- liftEff $ unsafeCoerceEff $ FRP.subscribe viewB \v' -> do
    -- fetch
    _ <- launchAff do
      fs <- f v'
      putVar browserState { features: fs
                          , view: v' }

    setViewUI $ "View range: "
             <> show (round $ unwrap v'.min) <> " - "
             <> show (round $ unwrap v'.max)

  -- thread rendering view
  _ <- forkAff $ forever do
    -- render when the view & features have been updated
    state <- takeVar browserState
    liftEff do
      clearCanvas canvas
      renderFeatures h state.features state.view ctx

  -- render first frame
  fetchToCanvas h f v ctx

main :: Eff _ _
main = launchAff browser


Update app.purs to be compatible with 0.12

module DemoApp.WithRedux where

import Prelude                   (Unit, bind, unit, pure, discard, (-), (+), (<>))
import Unsafe.Coerce             (unsafeCoerce)
import Effect                    (Effect)
import Effect.Console            (log)
import Control.Effect.Ractive    (Data(Data), Ractive, get, on, ractive)
import Control.Effect.Redux      (Next, Store, subscribe, applyMiddleware, getState, dispatch)

-- | A simple reducer accepting two actions: INCREMENT, DECREMENT
counter ::  forall a. Int -> { "type" :: String | a } -> Int
counter = \v t -> case t.type of
                        "INCREMENT" -> v + 1
                        "DECREMENT" -> v - 1
                        _ -> v

-- | Event handler for handling button clicks
onIncrementClicked :: forall event.
                      Ractive ->
                      event   ->
                      Effect Unit
onIncrementClicked = \r e -> do
                             store <- (get "store" r)
                             action <- (dispatch { "type" : "INCREMENT", payload: "TEST INCR" } store)
                             pure unit

-- | Event handler for handling button clicks
onDecrementClicked :: forall event.
                        Ractive ->
                        event   ->
                        Effect Unit
onDecrementClicked = \r e -> do
                             store <- (get "store" r)
                             action <- (dispatch { "type" : "DECREMENT", payload: "TEST DECR" } store)
                             pure unit

-- | A simple listener for displaying current state
numericListener :: Store -> Effect Unit
numericListener = \store -> do
                     currentState <- (getState store)
                     log ("STATE: " <> (unsafeCoerce currentState))

-- | This is a middleware for logging
-- | It receives a subset of the Store API (getState & dispatch) and processes `actions`
simpleLogger :: forall a. Store ->
                            (Next) ->
                            { "type" :: String, "payload" :: String | a } ->
                            Effect { "type" :: String, "payload" :: String | a }
simpleLogger = \store next action -> do
                                     log ("Middleware (Logger) :: Action: " <>
                                            action.type <> ", payload: " <>
                                            action.payload)
                                     (next action)

-- | The app starts here
main :: Effect Unit
main = do
       -- | Create an array of middlewares
       let middlewares = [ simpleLogger ]
       -- | Initialize a Redux Store while building up a chain of middlewares
       store <- (applyMiddleware middlewares counter 1)

       -- | ALTERNATIVE (without middleware)
       -- | Create a Redux Store by wiring up the `counter` Reducer and
       -- | the initial state `1`
       ---store <- (createStore counter 1)

       -- | Define UI's properties (RactiveJS)
       -- | Notice the presence of the property `store`. This is where we
       -- | save the reference to our Redux store. On each button click this
       -- | property will be used to change the app's state.
       let appSettings = Data {
                         template : "#template",
                         el       : "#app",
                         "data" : {
                                  library   : "Redux",
                                  language  : "PureScript",
                                  logoUrl   : "./content/img/ps-logo.png",
                                  message   : "Click on the PureScript Logo!",
                                  "store"   : store,
                                  uiLib     : "RactiveJS",
                                  counter   : 0,
                                  numbers   : []
                              }
                      }
       -- | Instantiate the UI
       ract <- ractive appSettings

       -- | Subscribe with listener `numericListener`
       (subscribe (numericListener store) store)

       -- Register event-handlers
       _ <- on "increment-clicked" (onIncrementClicked ract) ract
       _ <- on "decrement-clicked" (onDecrementClicked ract) ract

       log "Demo App with Redux!"

module DemoApp.WithRedux where

import Prelude                   (Unit, bind, unit, pure, (-), (+), (<>))
import Unsafe.Coerce             (unsafeCoerce)
import Control.Monad.Eff         (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Ractive (RactiveM, Ractive, Data(Data), on, ractive, get)
import Control.Monad.Eff.Redux   (ReduxM, Next, Store, subscribe, applyMiddleware, getState, dispatch)

-- | A simple reducer accepting two actions: INCREMENT, DECREMENT
counter ::  forall a. Int -> { "type" :: String | a } -> Int
counter = \v t -> case t.type of
                        "INCREMENT" -> v + 1
                        "DECREMENT" -> v - 1
                        _ -> v

-- | Event handler for handling button clicks
onIncrementClicked :: forall event eff.
                      Ractive ->
                      event   ->
                      Eff (
                            ractiveM :: RactiveM,
                            reduxM   :: ReduxM,
                            console  :: CONSOLE
                            | eff
                          ) Unit
onIncrementClicked = \r e -> do
                             store <- (get "store" r)
                             action <- (dispatch { "type" : "INCREMENT", payload: "TEST INCR" } store)
                             pure unit

-- | Event handler for handling button clicks
onDecrementClicked :: forall event eff.
                        Ractive ->
                        event   ->
                        Eff (
                              ractiveM :: RactiveM,
                              reduxM   :: ReduxM,
                              console  :: CONSOLE
                              | eff
                            ) Unit
onDecrementClicked = \r e -> do
                             store <- (get "store" r)
                             action <- (dispatch { "type" : "DECREMENT", payload: "TEST DECR" } store)
                             pure unit

-- | A simple listener for displaying current state
numericListener :: forall e. Store -> Eff (reduxM :: ReduxM, console :: CONSOLE | e) Unit
numericListener = \store -> do
                     currentState <- (getState store)
                     log ("STATE: " <> (unsafeCoerce currentState))

-- | This is a middleware for logging
-- | It receives a subset of the Store API (getState & dispatch) and processes `actions`
simpleLogger :: forall a e. Store ->
                            (Next) ->
                            { "type" :: String, "payload" :: String | a } ->
                            Eff (
                              reduxM :: ReduxM,
                              console :: CONSOLE
                              | e
                              )
                            { "type" :: String, "payload" :: String | a }
simpleLogger = \store next action -> do
                                     log ("Middleware (Logger) :: Action: " <>
                                            action.type <> ", payload: " <>
                                            action.payload)
                                     (next action)

-- | The app starts here
main :: forall eff. Eff
          (
            console  :: CONSOLE,
            ractiveM :: RactiveM,
            reduxM   :: ReduxM
          | eff
          )
          Unit
main = do
       -- | Create an array of middlewares
       let middlewares = [ simpleLogger ]
       -- | Initialize a Redux Store while building up a chain of middlewares
       store <- (applyMiddleware middlewares counter 1)

       -- | ALTERNATIVE (without middleware)
       -- | Create a Redux Store by wiring up the `counter` Reducer and
       -- | the initial state `1`
       ---store <- (createStore counter 1)

       -- | Define UI's properties (RactiveJS)
       -- | Notice the presence of the property `store`. This is where we
       -- | save the reference to our Redux store. On each button click this
       -- | property will be used to change the app's state.
       let appSettings = Data {
                         template : "#template",
                         el       : "#app",
                         "data" : {
                                  library   : "Redux",
                                  language  : "PureScript",
                                  logoUrl   : "./content/img/ps-logo.png",
                                  message   : "Click on the PureScript Logo!",
                                  "store"   : store,
                                  uiLib     : "RactiveJS",
                                  counter   : 0,
                                  numbers   : []
                              }
                      }
       -- | Instantiate the UI
       ract <- ractive appSettings

       -- | Subscribe with listener `numericListener`
       (subscribe (numericListener store) store)

       -- Register event-handlers
       on "increment-clicked" (onIncrementClicked ract) ract
       on "decrement-clicked" (onDecrementClicked ract) ract

       log "Demo App with Redux!"


Remove module-qualified identifiers.

Remove module-qualified identifiers.

Fix https://github.com/nwolverson/atom-ide-purescript/issues/123

module IdePurescript.PscIde (getCompletion, getCompletion', cwd, loadDeps, getType, eitherToErr
  , getPursuitModuleCompletion, getPursuitCompletion, getAvailableModules, getLoadedModules, SearchResult, ModuleSearchResult
  , getTypeInfo) where

import Prelude
import Control.Monad.Eff.Exception as Ex
import Data.String as S
import PscIde as P
import PscIde.Command as C
import Control.Monad.Aff (Aff)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Decode (class DecodeJson, decodeJson)
import Data.Argonaut.Decode.Combinators ((.?))
import Data.Array (head)
import Data.Either (Either(Right, Left))
import Data.Maybe (maybe, Maybe(..))
import Data.Nullable (toNullable, Nullable)
import Data.String.Regex (noFlags, regex)
import IdePurescript.Regex (replace')
import PscIde.Command (TypePosition)

eitherToErr :: forall a eff. Aff (net :: P.NET | eff) (Either String a) -> (Aff (net :: P.NET | eff) a)
eitherToErr c = do
  r <- c
  case r of
    Left s -> throwError (Ex.error s)
    Right res -> pure res

result :: forall eff a b. (a -> b) ->  Aff (net :: P.NET | eff) (Either String a) -> Aff (net :: P.NET | eff) b
result f a = eitherToErr ((f <$> _) <$> a)

cwd :: forall eff. Int -> Aff (net :: P.NET | eff) String
cwd = result runMsg <<< P.cwd

runMsg :: C.Message -> String
runMsg (C.Message m) = m

getImports' :: forall eff. Int -> String
  -> Aff (net :: P.NET | eff) (Array { module :: String, qualifier :: Nullable String })
getImports' port s = result conv $ P.listImports port s
  where
  conv (C.ImportList imps) = conv' <$> imps
  conv' (C.Import {moduleName, qualifier}) = {
    "module": moduleName,
    qualifier: toNullable qualifier
  }

getAvailableModules :: forall eff. Int -> Aff (net :: P.NET | eff) (Array String)
getAvailableModules = result conv <<< P.listAvailableModules
  where
  conv (C.ModuleList modules) = modules

getLoadedModules :: forall eff. Int -> Aff (net :: P.NET | eff) (Array String)
getLoadedModules = result conv <<< P.listLoadedModules
  where
  conv (C.ModuleList modules) = modules

moduleFilterModules :: String -> Array String -> (String -> Array String) -> Array String
moduleFilterModules modulePrefix unqualModules getQualifiedModule =
  if S.null modulePrefix then
    unqualModules
  else
    getQualifiedModule modulePrefix

abbrevType :: String -> String
abbrevType = replace' r "$1"
  where r = regex """(?:\w+\.)+(\w+)""" $ noFlags { global = true }

type TypeResult = {type :: String, identifier :: String, module :: String, position :: Maybe TypePosition}

getTypeInfo :: forall eff. Int -> String -> Maybe String -> String -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) (Maybe C.TypeInfo)
getTypeInfo port text currentModule modulePrefix unqualModules getQualifiedModule =
  result head $ P.type' port text moduleFilters currentModule
  where
    moduleFilters = [ C.ModuleFilter $ moduleFilterModules modulePrefix unqualModules getQualifiedModule ]

getType :: forall eff. Int -> String -> Maybe String -> String -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) String
getType port text currentModule modulePrefix unqualModules getQualifiedModule =
  maybe "" getType' <$> getTypeInfo port text currentModule modulePrefix unqualModules getQualifiedModule
  where
  getType' (C.TypeInfo { type' }) = type'

type CompletionResult = {type :: String, identifier :: String, module :: String}

getCompletion :: forall eff. Int -> String -> Maybe String -> String -> Boolean -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) (Array C.TypeInfo)
getCompletion port prefix =
  getCompletion' Nothing [C.PrefixFilter prefix] port

getCompletion' :: forall eff. Maybe C.Matcher -> Array C.Filter -> Int -> Maybe String -> String -> Boolean -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) (Array C.TypeInfo)
getCompletion' matcher mainFilter port currentModule modulePrefix moduleCompletion unqualModules getQualifiedModule =
  eitherToErr $ P.complete port (mainFilter <> moduleFilters) matcher currentModule
  where
  moduleFilters = if moduleCompletion then [] else [ C.ModuleFilter $ moduleFilterModules modulePrefix unqualModules getQualifiedModule ]

loadDeps :: forall eff. Int -> String
  -> Aff (net :: P.NET | eff) String
loadDeps port main = result runMsg $ P.load port [] [main]

type SearchResult = { module :: String, package :: String, type:: String, identifier :: String }

getPursuitCompletion :: forall eff. Int -> String -> Aff (net :: P.NET | eff) (Array SearchResult)
getPursuitCompletion port str = result (map convPursuitCompletion) $ P.pursuitCompletion port str

convPursuitCompletion :: C.PursuitCompletion -> SearchResult
convPursuitCompletion (C.PursuitCompletion { identifier, type', module', package })
  = { identifier, package, type: type', module: module' }

data ModuleCompletion = ModuleCompletion {
  module' :: String,
  package :: String
}

instance decodeModuleCompletion :: DecodeJson ModuleCompletion where
  decodeJson json = do
    o <- decodeJson json
    module' <- o .? "module"
    package <- o .? "package"
    pure (ModuleCompletion {
      module': module',
      package: package
      })

type ModuleSearchResult = { module :: String, package :: String }

getPursuitModuleCompletion :: forall eff. Int -> String
  -> Aff (net :: P.NET | eff) (Array ModuleSearchResult)
getPursuitModuleCompletion port str = result (map convPursuitModuleCompletion) $ complete str
  where

  complete :: String -> P.Cmd (Array ModuleCompletion)
  complete q = P.sendCommand port (C.Pursuit C.Package q)

  convPursuitModuleCompletion :: ModuleCompletion -> ModuleSearchResult
  convPursuitModuleCompletion (ModuleCompletion { module', package })
    = { package, module: module' }

module IdePurescript.PscIde (getCompletion, getCompletion', cwd, loadDeps, getType, eitherToErr
  , getPursuitModuleCompletion, getPursuitCompletion, getAvailableModules, getLoadedModules, SearchResult, ModuleSearchResult
  , getTypeInfo) where

import Prelude
import Control.Monad.Eff.Exception as Ex
import Data.String as S
import PscIde as P
import PscIde.Command as C
import Control.Monad.Aff (Aff)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut.Decode (class DecodeJson, decodeJson)
import Data.Argonaut.Decode.Combinators ((.?))
import Data.Array ((:), null, head)
import Data.Either (Either(Right, Left))
import Data.Maybe (maybe, Maybe(..))
import Data.Nullable (toNullable, Nullable)
import Data.String.Regex (noFlags, regex)
import IdePurescript.Regex (replace')
import PscIde.Command (TypePosition)

eitherToErr :: forall a eff. Aff (net :: P.NET | eff) (Either String a) -> (Aff (net :: P.NET | eff) a)
eitherToErr c = do
  r <- c
  case r of
    Left s -> throwError (Ex.error s)
    Right res -> pure res

result :: forall eff a b. (a -> b) ->  Aff (net :: P.NET | eff) (Either String a) -> Aff (net :: P.NET | eff) b
result f a = eitherToErr ((f <$> _) <$> a)

cwd :: forall eff. Int -> Aff (net :: P.NET | eff) String
cwd = result runMsg <<< P.cwd

runMsg :: C.Message -> String
runMsg (C.Message m) = m

getImports' :: forall eff. Int -> String
  -> Aff (net :: P.NET | eff) (Array { module :: String, qualifier :: Nullable String })
getImports' port s = result conv $ P.listImports port s
  where
  conv (C.ImportList imps) = conv' <$> imps
  conv' (C.Import {moduleName, qualifier}) = {
    "module": moduleName,
    qualifier: toNullable qualifier
  }

getAvailableModules :: forall eff. Int -> Aff (net :: P.NET | eff) (Array String)
getAvailableModules = result conv <<< P.listAvailableModules
  where
  conv (C.ModuleList modules) = modules

getLoadedModules :: forall eff. Int -> Aff (net :: P.NET | eff) (Array String)
getLoadedModules = result conv <<< P.listLoadedModules
  where
  conv (C.ModuleList modules) = modules

moduleFilterModules :: String -> Array String -> (String -> Array String) -> Array String
moduleFilterModules modulePrefix unqualModules getQualifiedModule =
  if S.null modulePrefix then
    unqualModules
  else if S.contains "." modulePrefix then
    [ modulePrefix ]
  else
    let mods = getQualifiedModule modulePrefix in
    if null mods then
      [ modulePrefix ]
    else
      mods

moduleFilters :: Array String -> Array C.Filter
moduleFilters [] = []
moduleFilters modules = [ C.ModuleFilter modules ]

abbrevType :: String -> String
abbrevType = replace' r "$1"
  where r = regex """(?:\w+\.)+(\w+)""" $ noFlags { global = true }

type TypeResult = {type :: String, identifier :: String, module :: String, position :: Maybe TypePosition}

getTypeInfo :: forall eff. Int -> String -> Maybe String -> String -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) (Maybe C.TypeInfo)
getTypeInfo port text currentModule modulePrefix unqualModules getQualifiedModule =
  result conv $ P.type' port text (moduleFilters mods) currentModule
  where
    mods = moduleFilterModules modulePrefix unqualModules getQualifiedModule
    conv = head

getType :: forall eff. Int -> String -> Maybe String -> String -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) String
getType port text currentModule modulePrefix unqualModules getQualifiedModule =
  maybe "" getType' <$> getTypeInfo port text currentModule modulePrefix unqualModules getQualifiedModule
  where
  getType' (C.TypeInfo { type' }) = type'

type CompletionResult = {type :: String, identifier :: String, module :: String}

getCompletion :: forall eff. Int -> String -> Maybe String -> String -> Boolean -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) (Array C.TypeInfo)
getCompletion port prefix =
  getCompletion' Nothing [C.PrefixFilter prefix] port

getCompletion' :: forall eff. Maybe C.Matcher -> Array C.Filter -> Int -> Maybe String -> String -> Boolean -> Array String -> (String -> Array String)
  -> Aff (net :: P.NET | eff) (Array C.TypeInfo)
getCompletion' matcher mainFilter port currentModule modulePrefix moduleCompletion unqualModules getQualifiedModule =
  eitherToErr $ P.complete port (mainFilter <> moduleFilters mods) matcher currentModule
  where
  mods = if moduleCompletion then [] else moduleFilterModules modulePrefix unqualModules getQualifiedModule

loadDeps :: forall eff. Int -> String
  -> Aff (net :: P.NET | eff) String
loadDeps port main = result runMsg $ P.load port [] [main]

type SearchResult = { module :: String, package :: String, type:: String, identifier :: String }

getPursuitCompletion :: forall eff. Int -> String -> Aff (net :: P.NET | eff) (Array SearchResult)
getPursuitCompletion port str = result (map convPursuitCompletion) $ P.pursuitCompletion port str

convPursuitCompletion :: C.PursuitCompletion -> SearchResult
convPursuitCompletion (C.PursuitCompletion { identifier, type', module', package })
  = { identifier, package, type: type', module: module' }

data ModuleCompletion = ModuleCompletion {
  module' :: String,
  package :: String
}

instance decodeModuleCompletion :: DecodeJson ModuleCompletion where
  decodeJson json = do
    o <- decodeJson json
    module' <- o .? "module"
    package <- o .? "package"
    pure (ModuleCompletion {
      module': module',
      package: package
      })

type ModuleSearchResult = { module :: String, package :: String }

getPursuitModuleCompletion :: forall eff. Int -> String
  -> Aff (net :: P.NET | eff) (Array ModuleSearchResult)
getPursuitModuleCompletion port str = result (map convPursuitModuleCompletion) $ complete str
  where

  complete :: String -> P.Cmd (Array ModuleCompletion)
  complete q = P.sendCommand port (C.Pursuit C.Package q)

  convPursuitModuleCompletion :: ModuleCompletion -> ModuleSearchResult
  convPursuitModuleCompletion (ModuleCompletion { module', package })
    = { package, module: module' }


Fixed definition of hasPlayerPiece

Fixed definition of hasPlayerPiece

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events
import Data.DOM.Simple.Window
import Data.Int
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (abs, max, pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  { player: player,
    color:  if player == playerOne then colorPlayerOne else colorPlayerTwo,
    king:   false }

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:                  createGrid offset width height layers,
    currentPlayer:         playerOne,
    selectedCoordinate:    Nothing,
    highlightedCoordinate: Nothing }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

hasPlayer :: Player -> Piece -> Boolean
hasPlayer player piece = piece.player == player

hasCoordinate :: Coordinate -> Square -> Boolean
hasCoordinate coordinate square = coordinate == square.coordinate

findSquare :: Array Square -> Coordinate -> Maybe Int
findSquare squares coordinate = findIndex (hasCoordinate coordinate) squares

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  fromMaybe Nothing $ (squares !!) <$> findSquare squares coordinate

squareHasPiece :: Player -> Square -> Boolean
squareHasPiece player square = fromMaybe false $ hasPlayer player <$> square.piece

hasPlayerPiece :: Player -> Array Square -> Coordinate -> Boolean
hasPlayerPiece player squares coordinate =
  fromMaybe false $ squareHasPiece player <$> getSquare squares coordinate

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece playerOne squares coordinate ||
  hasPlayerPiece playerTwo squares coordinate

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  offset <- 1 : (singleton 2)
  return (Tuple (x + i * offset) (y + j * offset))

isOnSquare :: Pixel -> Square -> Boolean
isOnSquare (Tuple x y) square =
  let px = square.render + square.offset
      px' = px + (Tuple renderSize renderSize)
  in fst px < x && x < fst px' && snd px < y && y < snd px'

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare pixel square && not (null moves)

searchGrid :: Grid -> (Square -> Boolean) -> Maybe Coordinate
searchGrid grid predicate =
  case findIndex predicate grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel = searchGrid grid (isOnActiveSquare grid player pixel)

getHighlightCoordinate :: State -> Pixel -> Maybe Coordinate
getHighlightCoordinate state pixel =
  case searchGrid state.grid (isOnSquare pixel) of
    Nothing -> Nothing
    Just to -> do
      case state.selectedCoordinate of
        Nothing -> getActiveCoordinate state.grid state.currentPlayer pixel
        Just from ->
          if isValidMove state.grid state.currentPlayer from to
          then Just to
          else getActiveCoordinate state.grid state.currentPlayer pixel

isRegularMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isRegularMove _ (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
  in d1 == to || d2 == to
isRegularMove _ _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
  in d3 == to || d4 == to

isJumpMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isJumpMove grid (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
      d5 = from + Tuple   2    2
      d6 = from + Tuple (-2)   2
      f = hasPlayerPiece playerTwo grid.squares
  in d5 == to && f d1 || d6 == to && f d2
isJumpMove grid _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
      d7 = from + Tuple   2  (-2)
      d8 = from + Tuple (-2) (-2)
      f = hasPlayerPiece playerOne grid.squares
  in d7 == to && f d3 || d8 == to && f d4

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = isJust (elemIndex to (getMoves grid player from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate =
  if null allJumpMoves then allRegularMoves else allJumpMoves
  where
    allRegularMoves = getMoves' isRegularMove
    allJumpMoves = getMoves' isJumpMove

    getMoves' validator = do
      guard $ hasPlayerPiece player grid.squares coordinate
      potential <- getDiagonalSquares coordinate
      guard $ (isValid grid potential &&
               not hasPiece grid.squares potential &&
               validator grid player coordinate potential)
      return potential

alterPiece :: Maybe Piece -> Coordinate -> Grid -> Grid
alterPiece piece coordinate grid = grid { squares = newSquares }
  where
    index = fromJust (findSquare grid.squares coordinate)
    newSquares = fromJust (modifyAt index (setPiece piece) grid.squares)

removePiece :: Coordinate -> Grid -> Grid
removePiece = alterPiece Nothing

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid =
  let fromIndex = fromJust (findSquare grid.squares from)
      originalSquare = fromJust (grid.squares !! fromIndex)

      getMiddle :: Coordinate -> Coordinate -> Maybe Coordinate
      getMiddle (Tuple x1 y1) (Tuple x2 y2) =
        if abs (toNumber (y1 - y2)) == 2.0
        then
          let f v w = floor (max (toNumber v) (toNumber w) - 1.0)
          in Just (Tuple (f x1 x2) (f y1 y2))
        else Nothing
      gridAfterMove = removePiece from $ alterPiece originalSquare.piece to grid
  in
    case getMiddle from to of
      Nothing -> gridAfterMove
      Just middle -> removePiece middle gridAfterMove

otherPlayer :: Player -> Player
otherPlayer (Player 1) = Player 2
otherPlayer (Player 2) = Player 1
otherPlayer _          = Player 1

renderSquare :: forall e.
                  Context2D ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: fst square.render,
                 y: snd square.render,
                 w: renderSize,
                 h: renderSize }
  return unit

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx _ square = do
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle colorBorder ctx
  strokeRect ctx border
  return unit

renderHighlight :: forall e.
                     Context2D ->
                     Array Square ->
                     Maybe Coordinate ->
                     Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderHighlight ctx squares selection = do
  case selection of
    Nothing -> return unit
    Just coordinate -> do
      let square = fromJust (getSquare squares coordinate)
          arcPiece = { x:     fst square.render + 0.5 * renderSize,
                       y:     snd square.render + 0.5 * renderSize,
                       r:     (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end:   2.0 * pi }
      setLineWidth highlightWidth ctx
      strokePath ctx $ arc ctx arcPiece
      return unit

renderCurrentPlayer :: forall e.
                        State ->
                        Eff (dom :: DOM | e) Unit
renderCurrentPlayer state = do
  doc <- document globalWindow
  playerIndicator <- getElementById "player" doc
  case playerIndicator of
    Just indicator -> do
      setInnerHTML (if state.currentPlayer == playerOne
                    then colorPlayerOne
                    else colorPlayerTwo) indicator
      return unit
    _ -> return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.selectedCoordinate
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.highlightedCoordinate
  renderCurrentPlayer state
  return unit

renderPage :: forall s e.
                STRef s State ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st
      return unit
    _ -> return unit
  return unit

moveListener :: forall s e.
                  STRef s State ->
                  DOMEvent ->
                  Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
moveListener st e = do
  ux <- unsafeEventNumberProp "clientX" e
  uy <- unsafeEventNumberProp "clientY" e
  state <- readSTRef st
  let pixel = (Tuple (toNumber ux) (toNumber uy))
      highlightedCoordinate = getHighlightCoordinate state pixel
  writeSTRef st $ state { highlightedCoordinate = highlightedCoordinate }
  renderPage st
  return unit

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          toCoordinate = getHighlightCoordinate state pixel
      case toCoordinate of
        Nothing -> return unit
        Just to -> do
          case state.selectedCoordinate of
            Nothing -> do
              writeSTRef st $ state { selectedCoordinate = Just to }
              renderPage st
              return unit
            Just from -> do
              case isValidMove state.grid state.currentPlayer from to of
                false -> do
                  writeSTRef st $ state { selectedCoordinate = if to == from
                                                               then Nothing
                                                               else Just to }
                  renderPage st
                  return unit
                true -> do
                  writeSTRef st $ state { highlightedCoordinate = Nothing,
                                          selectedCoordinate = Nothing,
                                          grid = movePiece from to state.grid,
                                          currentPlayer = otherPlayer state.currentPlayer }
                  renderPage st
                  return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (moveListener st) canvas
      addMouseEventListener MouseClickEvent (clickListener st) canvas
      renderPage st
      return unit
    _ -> return unit

module Checkers.Main where

import Control.Monad.Eff
import Control.Monad.ST
import Control.MonadPlus
import Data.Array
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Events
import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Events
import Data.DOM.Simple.Window
import Data.Int
import Data.Maybe
import Data.Maybe.Unsafe
import Data.Tuple
import DOM
import Graphics.Canvas
import Math (abs, max, pi)
import Prelude

import Checkers.Constants
import Checkers.Types

createPiece :: Player -> Piece
createPiece player =
  { player: player,
    color:  if player == playerOne then colorPlayerOne else colorPlayerTwo,
    king:   false }

createGrid :: Pixel -> Int -> Int -> Int -> Grid
createGrid offset width height layers = { width: width, height: height, squares: squares }
  where
    squares = do
      x <- 0 .. (width - 1)
      y <- 0 .. (height - 1)
      let rx = (toNumber x) * renderSize
          ry = (toNumber y) * renderSize
          isPieceSquare = ((even x) && (odd y)) || ((even y) && (odd x))
          color = if isPieceSquare then colorSquareOne else colorSquareTwo
          piece = if isPieceSquare && (y < layers)
                  then Just (createPiece playerOne)
                  else if isPieceSquare && (y >= height - layers)
                       then Just (createPiece playerTwo)
                       else Nothing
      return { offset:     offset,
               coordinate: (Tuple x y),
               render:     (Tuple rx ry),
               color:      color,
               piece:      piece }

createState :: Pixel -> Int -> Int -> Int -> State
createState offset width height layers =
  { grid:                  createGrid offset width height layers,
    currentPlayer:         playerOne,
    selectedCoordinate:    Nothing,
    highlightedCoordinate: Nothing }

setPiece :: Maybe Piece -> Square -> Square
setPiece piece square = square { piece = piece }

isValid :: Grid -> Coordinate -> Boolean
isValid grid (Tuple x y) = x >= 0 && x < grid.width && y >= 0 && y < grid.height

hasPlayer :: Player -> Piece -> Boolean
hasPlayer player piece = piece.player == player

hasCoordinate :: Coordinate -> Square -> Boolean
hasCoordinate coordinate square = coordinate == square.coordinate

findSquare :: Array Square -> Coordinate -> Maybe Int
findSquare squares coordinate = findIndex (hasCoordinate coordinate) squares

getSquare :: Array Square -> Coordinate -> Maybe Square
getSquare squares coordinate =
  fromMaybe Nothing $ (squares !!) <$> findSquare squares coordinate

squareHasPiece :: Player -> Square -> Boolean
squareHasPiece player square = fromMaybe false $ hasPlayer player <$> square.piece

hasPlayerPiece :: Player -> Array Square -> Coordinate -> Boolean
hasPlayerPiece player = fromMaybe false $ squareHasPiece player <$> getSquare

hasPiece :: Array Square -> Coordinate -> Boolean
hasPiece squares coordinate =
  hasPlayerPiece playerOne squares coordinate ||
  hasPlayerPiece playerTwo squares coordinate

getDiagonalSquares :: Coordinate -> Array Coordinate
getDiagonalSquares (Tuple x y) = do
  i <- -1 : (singleton 1)
  j <- -1 : (singleton 1)
  offset <- 1 : (singleton 2)
  return (Tuple (x + i * offset) (y + j * offset))

isOnSquare :: Pixel -> Square -> Boolean
isOnSquare (Tuple x y) square =
  let px = square.render + square.offset
      px' = px + (Tuple renderSize renderSize)
  in fst px < x && x < fst px' && snd px < y && y < snd px'

isOnActiveSquare :: Grid -> Player -> Pixel -> Square -> Boolean
isOnActiveSquare grid player pixel square =
  let moves = getMoves grid player square.coordinate
  in isOnSquare pixel square && not (null moves)

searchGrid :: Grid -> (Square -> Boolean) -> Maybe Coordinate
searchGrid grid predicate =
  case findIndex predicate grid.squares of
    Just index -> _.coordinate <$> grid.squares !! index
    Nothing    -> Nothing

getActiveCoordinate :: Grid -> Player -> Pixel -> Maybe Coordinate
getActiveCoordinate grid player pixel = searchGrid grid (isOnActiveSquare grid player pixel)

getHighlightCoordinate :: State -> Pixel -> Maybe Coordinate
getHighlightCoordinate state pixel =
  case searchGrid state.grid (isOnSquare pixel) of
    Nothing -> Nothing
    Just to -> do
      case state.selectedCoordinate of
        Nothing -> getActiveCoordinate state.grid state.currentPlayer pixel
        Just from ->
          if isValidMove state.grid state.currentPlayer from to
          then Just to
          else getActiveCoordinate state.grid state.currentPlayer pixel

isRegularMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isRegularMove _ (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
  in d1 == to || d2 == to
isRegularMove _ _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
  in d3 == to || d4 == to

isJumpMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isJumpMove grid (Player 1) from to =
  let d1 = from + Tuple   1    1
      d2 = from + Tuple (-1)   1
      d5 = from + Tuple   2    2
      d6 = from + Tuple (-2)   2
      f = hasPlayerPiece playerTwo grid.squares
  in d5 == to && f d1 || d6 == to && f d2
isJumpMove grid _ from to =
  let d3 = from + Tuple   1  (-1)
      d4 = from + Tuple (-1) (-1)
      d7 = from + Tuple   2  (-2)
      d8 = from + Tuple (-2) (-2)
      f = hasPlayerPiece playerOne grid.squares
  in d7 == to && f d3 || d8 == to && f d4

isValidMove :: Grid -> Player -> Coordinate -> Coordinate -> Boolean
isValidMove grid player from to = isJust (elemIndex to (getMoves grid player from))

getMoves :: Grid -> Player -> Coordinate -> Array Coordinate
getMoves grid player coordinate =
  if null allJumpMoves then allRegularMoves else allJumpMoves
  where
    allRegularMoves = getMoves' isRegularMove
    allJumpMoves = getMoves' isJumpMove

    getMoves' validator = do
      guard $ hasPlayerPiece player grid.squares coordinate
      potential <- getDiagonalSquares coordinate
      guard $ (isValid grid potential &&
               not hasPiece grid.squares potential &&
               validator grid player coordinate potential)
      return potential

alterPiece :: Maybe Piece -> Coordinate -> Grid -> Grid
alterPiece piece coordinate grid = grid { squares = newSquares }
  where
    index = fromJust (findSquare grid.squares coordinate)
    newSquares = fromJust (modifyAt index (setPiece piece) grid.squares)

removePiece :: Coordinate -> Grid -> Grid
removePiece = alterPiece Nothing

movePiece :: Coordinate -> Coordinate -> Grid -> Grid
movePiece from to grid =
  let fromIndex = fromJust (findSquare grid.squares from)
      originalSquare = fromJust (grid.squares !! fromIndex)

      getMiddle :: Coordinate -> Coordinate -> Maybe Coordinate
      getMiddle (Tuple x1 y1) (Tuple x2 y2) =
        if abs (toNumber (y1 - y2)) == 2.0
        then
          let f v w = floor (max (toNumber v) (toNumber w) - 1.0)
          in Just (Tuple (f x1 x2) (f y1 y2))
        else Nothing
      gridAfterMove = removePiece from $ alterPiece originalSquare.piece to grid
  in
    case getMiddle from to of
      Nothing -> gridAfterMove
      Just middle -> removePiece middle gridAfterMove

otherPlayer :: Player -> Player
otherPlayer (Player 1) = Player 2
otherPlayer (Player 2) = Player 1
otherPlayer _          = Player 1

renderSquare :: forall e.
                  Context2D ->
                  Unit ->
                  Square ->
                  Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderSquare ctx _ square = do
  setFillStyle square.color ctx
  fillRect ctx { x: fst square.render,
                 y: snd square.render,
                 w: renderSize,
                 h: renderSize }
  return unit

renderPiece :: forall e.
                 State ->
                 Context2D ->
                 Unit ->
                 Square ->
                 Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderPiece state ctx _ square = do
  case square.piece of
    Just piece -> do
      setFillStyle piece.color ctx
      let arcPiece = { x: fst square.render + 0.5 * renderSize,
                       y: snd square.render + 0.5 * renderSize,
                       r: (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end: 2.0 * pi }
      fillPath ctx $ arc ctx arcPiece
      return unit
    _ -> return unit

renderBorder :: forall e. Context2D -> Grid -> Eff (canvas :: Canvas | e) Unit
renderBorder ctx grid = do
  let border = { x: 0.5,
                 y: 0.5,
                 w: (toNumber grid.width) * renderSize - 0.5,
                 h: (toNumber grid.height) * renderSize - 0.5 }
  setStrokeStyle colorBorder ctx
  strokeRect ctx border
  return unit

renderHighlight :: forall e.
                     Context2D ->
                     Array Square ->
                     Maybe Coordinate ->
                     Eff (canvas :: Canvas, dom :: DOM | e) Unit
renderHighlight ctx squares selection = do
  case selection of
    Nothing -> return unit
    Just coordinate -> do
      let square = fromJust (getSquare squares coordinate)
          arcPiece = { x:     fst square.render + 0.5 * renderSize,
                       y:     snd square.render + 0.5 * renderSize,
                       r:     (renderSize / 2.0) * 0.8,
                       start: 0.0,
                       end:   2.0 * pi }
      setLineWidth highlightWidth ctx
      strokePath ctx $ arc ctx arcPiece
      return unit

renderCurrentPlayer :: forall e.
                        State ->
                        Eff (dom :: DOM | e) Unit
renderCurrentPlayer state = do
  doc <- document globalWindow
  playerIndicator <- getElementById "player" doc
  case playerIndicator of
    Just indicator -> do
      setInnerHTML (if state.currentPlayer == playerOne
                    then colorPlayerOne
                    else colorPlayerTwo) indicator
      return unit
    _ -> return unit

render :: forall s e.
            Context2D ->
            STRef s State ->
            Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
render ctx st = do
  state <- readSTRef st
  withContext ctx $ do
    foldM (renderSquare ctx) unit state.grid.squares
  withContext ctx $ do
    foldM (renderPiece state ctx) unit state.grid.squares
  withContext ctx $ do
    renderBorder ctx state.grid
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.selectedCoordinate
  withContext ctx $ do
    renderHighlight ctx state.grid.squares state.highlightedCoordinate
  renderCurrentPlayer state
  return unit

renderPage :: forall s e.
                STRef s State ->
                Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
renderPage st = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      setCanvasDimensions renderDimension canvas
      ctx <- getContext2D canvas
      render ctx st
      return unit
    _ -> return unit
  return unit

moveListener :: forall s e.
                  STRef s State ->
                  DOMEvent ->
                  Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
moveListener st e = do
  ux <- unsafeEventNumberProp "clientX" e
  uy <- unsafeEventNumberProp "clientY" e
  state <- readSTRef st
  let pixel = (Tuple (toNumber ux) (toNumber uy))
      highlightedCoordinate = getHighlightCoordinate state pixel
  writeSTRef st $ state { highlightedCoordinate = highlightedCoordinate }
  renderPage st
  return unit

clickListener :: forall s e.
                   STRef s State ->
                   DOMEvent ->
                   Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
clickListener st e = do
  element <- getCanvasElementById "canvas"
  case element of
    Just canvas -> do
      state <- readSTRef st
      ux <- unsafeEventNumberProp "clientX" e
      uy <- unsafeEventNumberProp "clientY" e
      let pixel = Tuple (toNumber ux) (toNumber uy)
          toCoordinate = getHighlightCoordinate state pixel
      case toCoordinate of
        Nothing -> return unit
        Just to -> do
          case state.selectedCoordinate of
            Nothing -> do
              writeSTRef st $ state { selectedCoordinate = Just to }
              renderPage st
              return unit
            Just from -> do
              case isValidMove state.grid state.currentPlayer from to of
                false -> do
                  writeSTRef st $ state { selectedCoordinate = if to == from
                                                               then Nothing
                                                               else Just to }
                  renderPage st
                  return unit
                true -> do
                  writeSTRef st $ state { highlightedCoordinate = Nothing,
                                          selectedCoordinate = Nothing,
                                          grid = movePiece from to state.grid,
                                          currentPlayer = otherPlayer state.currentPlayer }
                  renderPage st
                  return unit
    _ -> return unit
  return unit

main :: forall s e. Eff (st :: ST s, canvas :: Canvas, dom :: DOM | e) Unit
main = do
  doc <- document globalWindow
  mcanvas <- getElementById "canvas" doc
  case mcanvas of
    Just canvas -> do
      x <- offsetLeft canvas
      y <- offsetTop canvas
      let offset = (Tuple (toNumber x) (toNumber y))
      st <- newSTRef (createState offset defaultWidth defaultHeight layerCount)
      addMouseEventListener MouseMoveEvent (moveListener st) canvas
      addMouseEventListener MouseClickEvent (clickListener st) canvas
      renderPage st
      return unit
    _ -> return unit