Summarise thoughts on parsing options

Summarise thoughts on parsing options

-- | This module parses the options section of the Docopt source string.
-- |
-- | ```
-- |   -h --help     Show this screen.
-- |   --version     Show version.
-- |   --speed=<kn>  Speed in knots [default: 10].
-- |   --moored      Moored (anchored) mine.
-- |   --drifting    Drifting mine.
-- | ```
-- |
-- | XXX:
-- | Because of the structure of the string, lexing and parsing must be
-- | interwoven to some degree. It would be great, however to re-use the
-- | existing TokenParsers written for the usage section somehow. Maybe
-- | a `pre-lex -> lex -> parse` method is justified? Or just ignore all
-- | unknown tokens.
-- |
-- | Known tokens would be [ SOpt, LOpt, Comma, '--', ':', '[default', ']'
-- |                       , StringLiteral, NumericLiteral ]
-- |
-- | During parsing, we would look for either:
-- |
-- | [ Sopt, Comma, Lopt ]
-- | [ Sopt, Lopt ]
-- | [ Lopt ]
-- | [ -- ]
-- |
-- | All following tokens are then part of the description, mostly garbage.
-- | However, we keep an eye open for '[default' and ']' and the StringLiteral
-- | and NumericLiterals contained in it.

module Docopt.Parser.Options where

import Prelude
import Control.Lazy (defer)
import Control.Alt ((<|>))
import Control.Apply ((*>), (<*))
import Data.List (List(..), some, (:), toList)
import qualified Text.Parsing.Parser as P
import qualified Text.Parsing.Parser.Combinators as P
import qualified Text.Parsing.Parser.Pos as P
import qualified Text.Parsing.Parser.String as P
import Data.Either
import Data.Maybe hiding (maybe)
import Docopt.Parser.Base
import Docopt.Parser.Lexer


Remove some dead code

Remove some dead code

module Input.Notebook
  ( Input(..)
  , updateState
  , CellResultContent(..)
  ) where

import Control.Monad.Eff.Class (liftEff)
import Control.Timer (Timeout())
import Control.Alt ((<|>))
import Data.Array (filter, modifyAt, (!!))
import Data.Date (Date(), Now(), now, toEpochMilliseconds)
import Data.Either (Either(), either)
import Data.Function (on)
import Data.Inject1 (inj, prj)
import Data.Maybe (maybe, Maybe(..))
import Data.Maybe.Unsafe (fromJust)
import Data.Tuple (fst)
import Halogen.HTML.Events.Monad (Event(), async)
import Model.Notebook
import Model.Notebook.Cell
import Model.Notebook.Domain (_notebookCells, addCell)
import Model.Resource (_name, Resource())
import Optic.Core ((..), (<>~), (%~), (+~), (.~), (^.))
import Optic.Setter (mapped, over)
import Text.Markdown.SlamDown.Html (SlamDownEvent())
import Control.Timer (Timeout())
import qualified Data.Array.NonEmpty as NEL

data CellResultContent = AceContent String

data Input
  = WithState (State -> State)
  | Dropdown Number
  | CloseDropdowns
  | AddCell CellContent
  | TrashCell CellId
  | RunCell CellId Date
  | StopCell CellId
  | CellResult CellId Date (Either (NEL.NonEmpty FailureMessage) CellResultContent)
  | UpdateCell CellId (Cell -> Cell)
  | CellSlamDownEvent CellId SlamDownEvent

updateState state (WithState f) =
  f state

updateState state (UpdateCell cellId fn) =
  state # _notebook.._notebookCells..mapped %~ onCell cellId fn

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # _dropdowns %~
  (modifyAt i _{visible = visSet}) <<<  (_{visible = false} <$>)

updateState state CloseDropdowns =
  state{addingCell = false} # _dropdowns %~ (_{visible = false} <$>)

updateState state (AddCell cellType) =
  state # _notebook %~ (addCell cellType Nothing >>> fst)

updateState state (TrashCell cellId) =
  state # _notebook.._notebookCells %~ filter (not <<< isCell cellId)

updateState state (CellResult cellId date content) =
  let f (RunningSince d) = RunFinished $ on (-) toEpochMilliseconds date d
      f _                = RunInitial -- TODO: Cell in bad state
  in state # _notebook.._notebookCells..mapped %~ onCell cellId (modifyRunState f <<< cellContent content)

updateState state (RunCell cellId date) =
  state # _notebook.._notebookCells..mapped %~ onCell cellId (modifyRunState <<< const $ RunningSince date)

updateState state i = state

cellContent :: Either (NEL.NonEmpty FailureMessage) CellResultContent -> Cell -> Cell
cellContent = either (setFailures <<< NEL.toArray) success
  where success (AceContent content) = setFailures [ ] <<< setContent content

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

setFailures :: [FailureMessage] -> Cell -> Cell
setFailures fs (Cell o) = Cell $ o { failures = fs }

setContent :: String -> Cell -> Cell
setContent content (Cell o) =
  let content' = case o.content of
                  Evaluate _ -> Evaluate content
                  Search _ -> Search content
                  Query _ -> Query content
                  Visualize _ -> Visualize content
                  Markdown _ -> Markdown content
                  other -> other
  in Cell $ o { content = content' }

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'

module Input.Notebook
  ( Input(..)
  , updateState
  , CellResultContent(..)
  ) where

import Control.Monad.Eff.Class (liftEff)
import Control.Timer (Timeout())
import Control.Alt ((<|>))
import Data.Array (filter, modifyAt, (!!))
import Data.Date (Date(), Now(), now, toEpochMilliseconds)
import Data.Either (Either(), either)
import Data.Function (on)
import Data.Inject1 (inj, prj)
import Data.Maybe (maybe, Maybe(..))
import Data.Maybe.Unsafe (fromJust)
import Data.Tuple (fst)
import Halogen.HTML.Events.Monad (Event(), async)
import Model.Notebook
import Model.Notebook.Cell
import Model.Notebook.Domain (_notebookCells, addCell)
import Model.Resource (_name, Resource())
import Optic.Core ((..), (<>~), (%~), (+~), (.~), (^.))
import Optic.Setter (mapped, over)
import Text.Markdown.SlamDown.Html (SlamDownEvent())
import Control.Timer (Timeout())
import qualified Data.Array.NonEmpty as NEL

data CellResultContent = AceContent String

data Input
  = WithState (State -> State)
  | Dropdown Number
  | CloseDropdowns
  | AddCell CellContent
  | TrashCell CellId
  | RunCell CellId Date
  | StopCell CellId
  | CellResult CellId Date (Either (NEL.NonEmpty FailureMessage) CellResultContent)
  | UpdateCell CellId (Cell -> Cell)
  | CellSlamDownEvent CellId SlamDownEvent

updateState state (WithState f) =
  f state

updateState state (UpdateCell cellId fn) =
  state # _notebook.._notebookCells..mapped %~ onCell cellId fn

updateState state (Dropdown i) =
  let visSet = maybe true not (_.visible <$> state.dropdowns !! i) in
  state # _dropdowns %~
  (modifyAt i _{visible = visSet}) <<<  (_{visible = false} <$>)

updateState state CloseDropdowns =
  state{addingCell = false} # _dropdowns %~ (_{visible = false} <$>)

updateState state (AddCell cellType) =
  state # _notebook %~ (addCell cellType Nothing >>> fst)

-- updateState state (ToggleEditorCell cellId) =
--   state # _notebook.._notebookCells..mapped %~ onCell cellId toggleEditor

updateState state (TrashCell cellId) =
  state # _notebook.._notebookCells %~ filter (not <<< isCell cellId)

updateState state (CellResult cellId date content) =
  let f (RunningSince d) = RunFinished $ on (-) toEpochMilliseconds date d
      f _                = RunInitial -- TODO: Cell in bad state
  in state # _notebook.._notebookCells..mapped %~ onCell cellId (modifyRunState f <<< cellContent content)

updateState state (RunCell cellId date) =
  state # _notebook.._notebookCells..mapped %~ onCell cellId (modifyRunState <<< const $ RunningSince date)

updateState state i = state

cellContent :: Either (NEL.NonEmpty FailureMessage) CellResultContent -> Cell -> Cell
cellContent = either (setFailures <<< NEL.toArray) success
  where success (AceContent content) = setFailures [ ] <<< setContent content

onCell :: CellId -> (Cell -> Cell) -> Cell -> Cell
onCell ci f c = if isCell ci c then f c else c

toggleEditor :: Cell -> Cell
toggleEditor (Cell o) = Cell $ o { hiddenEditor = not o.hiddenEditor }

toggleFailures :: Cell -> Cell
toggleFailures (Cell o) = Cell $ o { expandedStatus = not o.expandedStatus }

setFailures :: [FailureMessage] -> Cell -> Cell
setFailures fs (Cell o) = Cell $ o { failures = fs }

setContent :: String -> Cell -> Cell
setContent content (Cell o) =
  let content' = case o.content of
                  Evaluate _ -> Evaluate content
                  Search _ -> Search content
                  Query _ -> Query content
                  Visualize _ -> Visualize content
                  Markdown _ -> Markdown content
                  other -> other
  in Cell $ o { content = content' }

modifyRunState :: (RunState -> RunState) -> Cell -> Cell
modifyRunState f (Cell o) = Cell $ o { runState = f o.runState }

isCell :: CellId -> Cell -> Boolean
isCell ci (Cell { cellId = ci' }) = ci == ci'


Use DeclarationType instead of String in Filter

module PscIde.Command where

import Prelude

import Control.Alt ((<|>))
import Data.Argonaut (JsonDecodeError(..), getField, parseJson, printJsonDecodeError)
import Data.Argonaut.Core (jsonEmptyObject, jsonSingletonObject, jsonNull, fromString, Json, toString)
import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.:))
import Data.Argonaut.Encode (class EncodeJson, encodeJson, (~>), (:=))
import Data.Array (singleton)
import Data.Bifunctor (lmap)
import Data.Either (Either(..), either, hush)
import Data.Maybe (Maybe(..), maybe)
import Data.String (joinWith)
import Foreign.Object (Object)

data PursuitType = Package | Ident

instance showPursuitType :: Show PursuitType where
  show Package = "package"
  show Ident   = "completion"

instance encodePursuitType :: EncodeJson PursuitType where
  encodeJson = encodeJson <<< show

data Matcher =
  Flex String
  | Distance String Int

instance encodeMatcher :: EncodeJson Matcher where
  encodeJson (Flex q) =
    "matcher" := "flex"
    ~> "params" := (jsonSingletonObject' "search" q)
    ~> jsonEmptyObject
  encodeJson (Distance q maxDist) =
    "matcher" := "distance"
    ~> "params" := (
       "search" := q
       ~> "maximumDistance" := maxDist
       ~> jsonEmptyObject
      )
    ~> jsonEmptyObject

data Filter =
  ExactFilter String
  | PrefixFilter String
  | ModuleFilter (Array String)
  | DependencyFilter (Array String)
  | NamespaceFilter (Array Namespace)
  | DeclarationFilter (Array DeclarationType)

filterWrapper :: forall a. (EncodeJson a) => String -> a -> Json
filterWrapper f q =
  "filter" := f
  ~> ("params" := q)
  ~> jsonEmptyObject

jsonSingletonObject' :: forall a. (EncodeJson a) => String -> a -> Json
jsonSingletonObject' s o = jsonSingletonObject s (encodeJson o)

instance encodeFilter :: EncodeJson Filter where
  encodeJson (ExactFilter q) =
    filterWrapper "exact" (jsonSingletonObject' "search" q)
  encodeJson (PrefixFilter q) =
    filterWrapper "prefix" (jsonSingletonObject' "search" q)
  encodeJson (ModuleFilter modules) =
    filterWrapper "modules" (jsonSingletonObject' "modules" modules)
  encodeJson (DependencyFilter deps) =
    filterWrapper "dependencies" (jsonSingletonObject' "modules" deps)
  encodeJson (NamespaceFilter nss) =
    filterWrapper "namespace" (jsonSingletonObject' "namespaces" nss)
  encodeJson (DeclarationFilter decls) =
    filterWrapper "declarations" (map declarationTypeToString decls)

newtype CompletionOptions = CompletionOptions {
  maxResults :: Maybe Int,
  groupReexports :: Boolean
}

instance encodeCompletionOptions :: EncodeJson CompletionOptions where
  encodeJson (CompletionOptions { maxResults, groupReexports }) =
   "maxResults" := encodeMaybeNull maxResults
    ~> "groupReexports" := encodeJson groupReexports
    ~> jsonEmptyObject

data Command =
  Cwd
  | Ls ListType
  | Quit
  | Reset
  | Load (Array String) (Array String)
  | Complete (Array Filter) (Maybe Matcher) (Maybe String) CompletionOptions
  | Pursuit PursuitType String
  | Type String (Array Filter) (Maybe String)
  | AddClause String Boolean
  | CaseSplit String Int Int Boolean String
  | ImportCmd FileName (Maybe FileName) (Array Filter) ImportCommand
  | RebuildCmd String (Maybe FileName) (Maybe (Array CodegenTarget))
  | Usages String Namespace String

data ListType = LoadedModules | Imports String | AvailableModules
data Namespace = NSValue | NSType | NSKind
data CodegenTarget =  JS | JSSourceMap | CoreFn | Other String

type FileName = String
data ImportCommand = AddImplicitImport String | AddQualifiedImport String String | AddImport String (Maybe String)

data DeclarationType =
  DeclValue
  | DeclType
  | DeclTypeSynonym
  | DeclDataConstructor
  | DeclTypeClass
  | DeclValueOperator
  | DeclTypeOperator
  | DeclModule

declarationTypeFromString :: String -> Maybe DeclarationType
declarationTypeFromString = case _ of
  "value" -> Just DeclValue
  "type" -> Just DeclType
  "synonym" -> Just DeclTypeSynonym
  "dataconstructor" -> Just DeclDataConstructor
  "typeclass" -> Just DeclTypeClass
  "valueoperator" -> Just DeclValueOperator
  "typeoperator" -> Just DeclTypeOperator
  "module" -> Just DeclModule
  _ -> Nothing

declarationTypeToString :: DeclarationType -> String
declarationTypeToString = case _ of
  DeclValue -> "value"
  DeclType -> "type"
  DeclTypeSynonym -> "synonym"
  DeclDataConstructor -> "dataconstructor"
  DeclTypeClass -> "typeclass"
  DeclValueOperator -> "valueoperator"
  DeclTypeOperator -> "typeoperator"
  DeclModule -> "module"

commandWrapper :: forall a. (EncodeJson a) => String -> a -> Json
commandWrapper s o =
  "command" := s
  ~> ("params" := o)
  ~> jsonEmptyObject

instance encodeCommand :: EncodeJson Command where
  encodeJson Cwd = jsonSingletonObject' "command" "cwd"
  encodeJson (Ls LoadedModules) =
    commandWrapper "list" ("type" := "loadedModules" ~> jsonEmptyObject)
  encodeJson (Ls AvailableModules) =
    commandWrapper "list" ("type" := "availableModules" ~> jsonEmptyObject)
  encodeJson (Ls (Imports fp)) =
    commandWrapper "list" ("type" := "import" ~> "file" := fp ~> jsonEmptyObject)
  encodeJson Quit = jsonSingletonObject' "command" "quit"
  encodeJson Reset = jsonSingletonObject' "command" "reset"
  encodeJson (Load modules dependencies) =
    commandWrapper "load" (
      "modules" := (encodeJson modules)
      ~> "dependencies" := (encodeJson dependencies)
      ~> jsonEmptyObject
      )
  encodeJson (Complete filters matcher currentModule options) =
    commandWrapper "complete" (
      "filters" := (encodeJson filters)
      ~> "matcher" := (encodeMaybeNull matcher)
      ~> "currentModule" := (encodeMaybeNull currentModule)
      ~> "options" := (encodeJson options)
      ~> jsonEmptyObject
      )
  encodeJson (Pursuit psType q) =
    commandWrapper "pursuit" (
        "type" := (encodeJson psType)
        ~> "query" := q
        ~> jsonEmptyObject
      )
  encodeJson (Type text filters currentModule) =
    commandWrapper "type" (
        "search" := encodeJson text
        ~> "filters" := (encodeJson filters)
        ~> "currentModule" := (encodeMaybeNull currentModule)
        ~> jsonEmptyObject
      )
  encodeJson (AddClause line annotations) =
    commandWrapper "addClause" (
        "line" := encodeJson line
        ~> "annotations" := encodeJson annotations
        ~> jsonEmptyObject
      )
  encodeJson (CaseSplit line begin end annotations typ) =
    commandWrapper "caseSplit" (
        "line" := encodeJson line
        ~> "begin" := encodeJson begin
        ~> "end" := encodeJson end
        ~> "annotations" := encodeJson annotations
        ~> "type" := encodeJson typ
        ~> jsonEmptyObject
      )
  encodeJson (ImportCmd inFile outFile filters cmd) =
    commandWrapper "import" (
      "file" := encodeJson inFile
      ~> "outfile" := encodeMaybeNull outFile
      ~> "filters" := encodeJson filters
      ~> "importCommand" := encodeJson cmd
      ~> jsonEmptyObject
      )
  encodeJson (RebuildCmd file actualFile codegen) =
    commandWrapper "rebuild" (
      "file" := encodeJson file
      ~> "actualFile" := encodeMaybeNull actualFile
      ~> "codegen" := encodeMaybeNull codegen
      ~> jsonEmptyObject
      )
  encodeJson (Usages mod ns ident) =
    commandWrapper "usages" (
      "module" := encodeJson mod
      ~> "namespace" := encodeJson ns
      ~> "identifier" := encodeJson ident
      ~> jsonEmptyObject
    )

encodeMaybeNull :: forall a. (EncodeJson a) => Maybe a -> Json
encodeMaybeNull = maybe jsonNull encodeJson

instance encodeImportCommand :: EncodeJson ImportCommand where
  encodeJson (AddImplicitImport ident) =
    "importCommand" := "addImplicitImport"
    ~> "module" := encodeJson ident
    ~> jsonEmptyObject
  encodeJson (AddQualifiedImport mod qualifier) =
    "importCommand" := "addQualifiedImport"
    ~> "module" := encodeJson mod
    ~> "qualifier" := encodeJson qualifier
    ~> jsonEmptyObject
  encodeJson (AddImport mod qualifier) =
    "importCommand" := "addImport"
    ~> "identifier" := encodeJson mod
    ~> "qualifier" := encodeJson qualifier
    ~> jsonEmptyObject

instance encodeNamespace :: EncodeJson Namespace where
  encodeJson NSValue = fromString "value"
  encodeJson NSType = fromString "type"
  encodeJson NSKind = fromString "kind"

instance encodeCodegenTarget :: EncodeJson CodegenTarget where
  encodeJson JS = fromString "js"
  encodeJson JSSourceMap = fromString "sourcemaps"
  encodeJson CoreFn = fromString "corefn"
  encodeJson (Other s) = fromString s

type Result a = Either String a

type GenCompletion a = {
  type' :: String,
  identifier :: String,
  module' :: String
  | a
}

newtype TypePosition = TypePosition {
  name :: String,
  start :: Position,
  end :: Position
}

newtype TypeInfo = TypeInfo (GenCompletion (
  definedAt :: Maybe TypePosition,
  expandedType :: Maybe String,
  documentation :: Maybe String,
  exportedFrom :: Array String,
  declarationType :: Maybe DeclarationType
))

newtype PursuitCompletion = PursuitCompletion {
  type' :: Maybe String,
  identifier :: String,
  module' :: String,
  package :: String,
  text :: String
  }

newtype ModuleList = ModuleList (Array String)
newtype Message = Message String
newtype ImportList = ImportList { moduleName :: Maybe String, imports :: Array Import }
newtype Import = Import
  {
    moduleName :: String,
    importType :: ImportType,
    qualifier  :: Maybe String
  }

type Position = { line :: Int, column :: Int }
type RangePosition = { startLine :: Int, startColumn :: Int, endLine :: Int, endColumn :: Int }

newtype RebuildError =
  RebuildError
  { position :: Maybe RangePosition
  , moduleName :: Maybe String
  , filename :: Maybe String
  , errorCode :: String
  , message :: String
  , errorLink :: String
  , pursIde :: Maybe PursIdeInfo
  , suggestion :: Maybe PscSuggestion
  }

newtype PscSuggestion =
  PscSuggestion
  { replacement :: String
  , replaceRange :: Maybe RangePosition
  }

newtype RebuildResult = RebuildResult (Array RebuildError)

newtype PursIdeInfo =
  PursIdeInfo
  { name :: String
  , completions :: Array TypeInfo
  }

data ImportType = Implicit | Explicit (Array String) | Hiding (Array String)

data ImportResult = SuccessFile Message | SuccessText (Array String) | MultipleResults (Array TypeInfo)

unwrapResponse :: forall a b. DecodeJson a => DecodeJson b => String -> Either String (Either a b)
unwrapResponse s = lmap printJsonDecodeError do
  json <- parseJson s
  o <- decodeJson json
  resultType <- o .: "resultType"
  case resultType of
    "success" -> do
      result <- o .: "result"
      pure (Right result)
    _ -> do
      result <- o .: "result"
      pure (Left result)

instance decodeMessage :: DecodeJson Message where
  decodeJson json = maybe (Left (TypeMismatch "String")) (Right <<< Message) $ toString json

instance decodeModuleList :: DecodeJson ModuleList where
  decodeJson json = ModuleList <$> decodeJson json

instance decodeTypeInfo :: DecodeJson TypeInfo where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .: "identifier"
    type' <- o .: "type"
    module' <- o .: "module"
    definedAt <- o `getFieldMaybe` "definedAt"
    expandedType <- o `getFieldMaybe` "expandedType"
    documentation <- o `getFieldMaybe` "documentation"
    declarationTypeStr <- o `getFieldMaybe` "declarationType"
    -- TODO: Handling both missing/incorrect exportedFrom. Remove this after 0.12
    exportedFrom <- Right $ either (const []) identity $ getField o "exportedFrom"
    pure (TypeInfo
      { identifier
      , type'
      , module'
      , definedAt
      , expandedType
      , documentation
      , exportedFrom
      , declarationType: declarationTypeFromString =<< declarationTypeStr
      })
    where
    getFieldMaybe :: forall a. (DecodeJson a) => Object Json -> String -> Either JsonDecodeError (Maybe a)
    getFieldMaybe o f = Right $ either (const Nothing) Just $ getField o f

instance decodeTypePosition :: DecodeJson TypePosition where
  decodeJson json = do
    o <- decodeJson json
    name <- o .: "name"
    start <- o .: "start"
    end <- o .: "end"
    case start, end of
      [sl, sc], [el, ec] ->
        Right (TypePosition { name, start: { line: sl, column: sc }, end: { line: el, column: ec } })
      _, _ -> Left (TypeMismatch "Array")

instance decodePursuitCompletion :: DecodeJson PursuitCompletion where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .: "ident"
    type' <- o .: "type"
    module' <- o .: "module"
    package <- o .: "package"
    text <- o .: "text"
    pure (PursuitCompletion {
      identifier: identifier,
      type': type',
      module': module',
      package: package,
      text: text
      })

instance decodeImportList :: DecodeJson ImportList where
  decodeJson json = decodeObject <|> decodeArray
    where
      decodeObject = do
        o <- decodeJson json
        moduleNameField <- o .: "moduleName"
        moduleName <- decodeModuleNameBug moduleNameField <|> decodeJson moduleNameField
        imports <- o .: "imports"
        pure (ImportList { moduleName: Just moduleName, imports })
      -- TODO: Working around a bug where module Foo.Bar is jsonified as ["Foo", "Bar"] instead of "Foo.Bar"
      decodeModuleNameBug moduleName = joinWith "." <$> decodeJson moduleName
      decodeArray = do
        imports <- decodeJson json
        pure (ImportList { moduleName: Nothing, imports })

instance decodeImport :: DecodeJson Import where
  decodeJson json = do
    o <- decodeJson json
    moduleName <- o .: "module"
    importType <- o .: "importType"
    q <- (Just <$> o .: "qualifier") <|> pure Nothing
    case importType of
      "implicit" -> do
        pure $ Import {moduleName: moduleName, importType: Implicit, qualifier: q}
      "explicit" -> do
        identifiers <- o .: "identifiers"
        pure $ Import {moduleName: moduleName, importType: Explicit identifiers, qualifier: q}
      "hiding"   -> do
        identifiers <- o .: "identifiers"
        pure $ Import {moduleName: moduleName, importType: Hiding identifiers, qualifier: q}
      v -> Left (TypeMismatch "ImportType")

instance decodeImportResult :: DecodeJson ImportResult where
  decodeJson json = do
    (SuccessText <$> decodeJson json)
    <|> (SuccessFile <$> decodeJson json)
    <|> (MultipleResults <$> decodeJson json)
    <|> (Left (TypeMismatch "ImportResult"))

instance decodeRebuildError :: DecodeJson RebuildError where
  decodeJson json = do
    o <- decodeJson json
    message <- o .: "message"
    errorCode <- o .: "errorCode"
    errorLink <- o .: "errorLink"
    moduleName <- o .: "moduleName"
    filename <- o .: "filename"
    position <- pure $ hush do
      p <- o .: "position"
      { startLine: _, startColumn: _, endLine: _, endColumn: _ } <$> p .: "startLine" <*> p .: "startColumn" <*> p .: "endLine" <*> p .: "endColumn"
    pursIde <- pure $ hush do
      pio <- o .: "pursIde"
      name <- pio .: "name"
      completions <- pio .: "completions"
      pure $ PursIdeInfo { name, completions }
    suggestion <- pure $ hush do
      so <- o .: "suggestion"
      replacement <- so .: "replacement"
      rr <- so .: "replaceRange"
      replaceRange <- pure $ hush $ { startLine: _, startColumn: _, endLine: _, endColumn: _ } <$> rr .: "startLine" <*> rr .: "startColumn" <*> rr .: "endLine" <*> rr .: "endColumn"
      pure $ PscSuggestion { replacement, replaceRange }
    pure (RebuildError { errorCode, errorLink, moduleName, filename, message, position, pursIde, suggestion })

instance decodeRebuildResult :: DecodeJson RebuildResult where
  decodeJson json = RebuildResult <$> (decodeJson json <|> (singleton <$> decodeJson json))

module PscIde.Command where

import Prelude

import Control.Alt ((<|>))
import Data.Argonaut (JsonDecodeError(..), getField, parseJson, printJsonDecodeError)
import Data.Argonaut.Core (jsonEmptyObject, jsonSingletonObject, jsonNull, fromString, Json, toString)
import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.:))
import Data.Argonaut.Encode (class EncodeJson, encodeJson, (~>), (:=))
import Data.Array (singleton)
import Data.Bifunctor (lmap)
import Data.Either (Either(..), either, hush)
import Data.Maybe (Maybe(..), maybe)
import Data.String (joinWith)
import Foreign.Object (Object)

data PursuitType = Package | Ident

instance showPursuitType :: Show PursuitType where
  show Package = "package"
  show Ident   = "completion"

instance encodePursuitType :: EncodeJson PursuitType where
  encodeJson = encodeJson <<< show

data Matcher =
  Flex String
  | Distance String Int

instance encodeMatcher :: EncodeJson Matcher where
  encodeJson (Flex q) =
    "matcher" := "flex"
    ~> "params" := (jsonSingletonObject' "search" q)
    ~> jsonEmptyObject
  encodeJson (Distance q maxDist) =
    "matcher" := "distance"
    ~> "params" := (
       "search" := q
       ~> "maximumDistance" := maxDist
       ~> jsonEmptyObject
      )
    ~> jsonEmptyObject

data Filter =
  ExactFilter String
  | PrefixFilter String
  | ModuleFilter (Array String)
  | DependencyFilter (Array String)
  | NamespaceFilter (Array Namespace)
  | DeclarationFilter (Array String)

filterWrapper :: forall a. (EncodeJson a) => String -> a -> Json
filterWrapper f q =
  "filter" := f
  ~> ("params" := q)
  ~> jsonEmptyObject

jsonSingletonObject' :: forall a. (EncodeJson a) => String -> a -> Json
jsonSingletonObject' s o = jsonSingletonObject s (encodeJson o)

instance encodeFilter :: EncodeJson Filter where
  encodeJson (ExactFilter q) =
    filterWrapper "exact" (jsonSingletonObject' "search" q)
  encodeJson (PrefixFilter q) =
    filterWrapper "prefix" (jsonSingletonObject' "search" q)
  encodeJson (ModuleFilter modules) =
    filterWrapper "modules" (jsonSingletonObject' "modules" modules)
  encodeJson (DependencyFilter deps) =
    filterWrapper "dependencies" (jsonSingletonObject' "modules" deps)
  encodeJson (NamespaceFilter nss) =
    filterWrapper "namespace" (jsonSingletonObject' "namespaces" nss)
  encodeJson (DeclarationFilter decls) =
    filterWrapper "declarations" decls

newtype CompletionOptions = CompletionOptions {
  maxResults :: Maybe Int,
  groupReexports :: Boolean
}

instance encodeCompletionOptions :: EncodeJson CompletionOptions where
  encodeJson (CompletionOptions { maxResults, groupReexports }) =
   "maxResults" := encodeMaybeNull maxResults
    ~> "groupReexports" := encodeJson groupReexports
    ~> jsonEmptyObject

data Command =
  Cwd
  | Ls ListType
  | Quit
  | Reset
  | Load (Array String) (Array String)
  | Complete (Array Filter) (Maybe Matcher) (Maybe String) CompletionOptions
  | Pursuit PursuitType String
  | Type String (Array Filter) (Maybe String)
  | AddClause String Boolean
  | CaseSplit String Int Int Boolean String
  | ImportCmd FileName (Maybe FileName) (Array Filter) ImportCommand
  | RebuildCmd String (Maybe FileName) (Maybe (Array CodegenTarget))
  | Usages String Namespace String

data ListType = LoadedModules | Imports String | AvailableModules
data Namespace = NSValue | NSType | NSKind
data CodegenTarget =  JS | JSSourceMap | CoreFn | Other String

type FileName = String
data ImportCommand = AddImplicitImport String | AddQualifiedImport String String | AddImport String (Maybe String)

data DeclarationType =
  DeclValue
  | DeclType
  | DeclTypeSynonym
  | DeclDataConstructor
  | DeclTypeClass
  | DeclValueOperator
  | DeclTypeOperator
  | DeclModule

declarationTypeFromString :: String -> Maybe DeclarationType
declarationTypeFromString = case _ of
  "value" -> Just DeclValue
  "type" -> Just DeclType
  "synonym" -> Just DeclTypeSynonym
  "dataconstructor" -> Just DeclDataConstructor
  "typeclass" -> Just DeclTypeClass
  "valueoperator" -> Just DeclValueOperator
  "typeoperator" -> Just DeclTypeOperator
  "module" -> Just DeclModule
  _ -> Nothing

declarationTypeToString :: DeclarationType -> String
declarationTypeToString = case _ of
  DeclValue -> "value"
  DeclType -> "type"
  DeclTypeSynonym -> "synonym"
  DeclDataConstructor -> "dataconstructor"
  DeclTypeClass -> "typeclass"
  DeclValueOperator -> "valueoperator"
  DeclTypeOperator -> "typeoperator"
  DeclModule -> "module"

commandWrapper :: forall a. (EncodeJson a) => String -> a -> Json
commandWrapper s o =
  "command" := s
  ~> ("params" := o)
  ~> jsonEmptyObject

instance encodeCommand :: EncodeJson Command where
  encodeJson Cwd = jsonSingletonObject' "command" "cwd"
  encodeJson (Ls LoadedModules) =
    commandWrapper "list" ("type" := "loadedModules" ~> jsonEmptyObject)
  encodeJson (Ls AvailableModules) =
    commandWrapper "list" ("type" := "availableModules" ~> jsonEmptyObject)
  encodeJson (Ls (Imports fp)) =
    commandWrapper "list" ("type" := "import" ~> "file" := fp ~> jsonEmptyObject)
  encodeJson Quit = jsonSingletonObject' "command" "quit"
  encodeJson Reset = jsonSingletonObject' "command" "reset"
  encodeJson (Load modules dependencies) =
    commandWrapper "load" (
      "modules" := (encodeJson modules)
      ~> "dependencies" := (encodeJson dependencies)
      ~> jsonEmptyObject
      )
  encodeJson (Complete filters matcher currentModule options) =
    commandWrapper "complete" (
      "filters" := (encodeJson filters)
      ~> "matcher" := (encodeMaybeNull matcher)
      ~> "currentModule" := (encodeMaybeNull currentModule)
      ~> "options" := (encodeJson options)
      ~> jsonEmptyObject
      )
  encodeJson (Pursuit psType q) =
    commandWrapper "pursuit" (
        "type" := (encodeJson psType)
        ~> "query" := q
        ~> jsonEmptyObject
      )
  encodeJson (Type text filters currentModule) =
    commandWrapper "type" (
        "search" := encodeJson text
        ~> "filters" := (encodeJson filters)
        ~> "currentModule" := (encodeMaybeNull currentModule)
        ~> jsonEmptyObject
      )
  encodeJson (AddClause line annotations) =
    commandWrapper "addClause" (
        "line" := encodeJson line
        ~> "annotations" := encodeJson annotations
        ~> jsonEmptyObject
      )
  encodeJson (CaseSplit line begin end annotations typ) =
    commandWrapper "caseSplit" (
        "line" := encodeJson line
        ~> "begin" := encodeJson begin
        ~> "end" := encodeJson end
        ~> "annotations" := encodeJson annotations
        ~> "type" := encodeJson typ
        ~> jsonEmptyObject
      )
  encodeJson (ImportCmd inFile outFile filters cmd) =
    commandWrapper "import" (
      "file" := encodeJson inFile
      ~> "outfile" := encodeMaybeNull outFile
      ~> "filters" := encodeJson filters
      ~> "importCommand" := encodeJson cmd
      ~> jsonEmptyObject
      )
  encodeJson (RebuildCmd file actualFile codegen) =
    commandWrapper "rebuild" (
      "file" := encodeJson file
      ~> "actualFile" := encodeMaybeNull actualFile
      ~> "codegen" := encodeMaybeNull codegen
      ~> jsonEmptyObject
      )
  encodeJson (Usages mod ns ident) =
    commandWrapper "usages" (
      "module" := encodeJson mod
      ~> "namespace" := encodeJson ns
      ~> "identifier" := encodeJson ident
      ~> jsonEmptyObject
    )

encodeMaybeNull :: forall a. (EncodeJson a) => Maybe a -> Json
encodeMaybeNull = maybe jsonNull encodeJson

instance encodeImportCommand :: EncodeJson ImportCommand where
  encodeJson (AddImplicitImport ident) =
    "importCommand" := "addImplicitImport"
    ~> "module" := encodeJson ident
    ~> jsonEmptyObject
  encodeJson (AddQualifiedImport mod qualifier) =
    "importCommand" := "addQualifiedImport"
    ~> "module" := encodeJson mod
    ~> "qualifier" := encodeJson qualifier
    ~> jsonEmptyObject
  encodeJson (AddImport mod qualifier) =
    "importCommand" := "addImport"
    ~> "identifier" := encodeJson mod
    ~> "qualifier" := encodeJson qualifier
    ~> jsonEmptyObject

instance encodeNamespace :: EncodeJson Namespace where
  encodeJson NSValue = fromString "value"
  encodeJson NSType = fromString "type"
  encodeJson NSKind = fromString "kind"

instance encodeCodegenTarget :: EncodeJson CodegenTarget where
  encodeJson JS = fromString "js"
  encodeJson JSSourceMap = fromString "sourcemaps"
  encodeJson CoreFn = fromString "corefn"
  encodeJson (Other s) = fromString s

type Result a = Either String a

type GenCompletion a = {
  type' :: String,
  identifier :: String,
  module' :: String
  | a
}

newtype TypePosition = TypePosition {
  name :: String,
  start :: Position,
  end :: Position
}

newtype TypeInfo = TypeInfo (GenCompletion (
  definedAt :: Maybe TypePosition,
  expandedType :: Maybe String,
  documentation :: Maybe String,
  exportedFrom :: Array String,
  declarationType :: Maybe DeclarationType
))

newtype PursuitCompletion = PursuitCompletion {
  type' :: Maybe String,
  identifier :: String,
  module' :: String,
  package :: String,
  text :: String
  }

newtype ModuleList = ModuleList (Array String)
newtype Message = Message String
newtype ImportList = ImportList { moduleName :: Maybe String, imports :: Array Import }
newtype Import = Import
  {
    moduleName :: String,
    importType :: ImportType,
    qualifier  :: Maybe String
  }

type Position = { line :: Int, column :: Int }
type RangePosition = { startLine :: Int, startColumn :: Int, endLine :: Int, endColumn :: Int }

newtype RebuildError =
  RebuildError
  { position :: Maybe RangePosition
  , moduleName :: Maybe String
  , filename :: Maybe String
  , errorCode :: String
  , message :: String
  , errorLink :: String
  , pursIde :: Maybe PursIdeInfo
  , suggestion :: Maybe PscSuggestion
  }

newtype PscSuggestion =
  PscSuggestion
  { replacement :: String
  , replaceRange :: Maybe RangePosition
  }

newtype RebuildResult = RebuildResult (Array RebuildError)

newtype PursIdeInfo =
  PursIdeInfo
  { name :: String
  , completions :: Array TypeInfo
  }

data ImportType = Implicit | Explicit (Array String) | Hiding (Array String)

data ImportResult = SuccessFile Message | SuccessText (Array String) | MultipleResults (Array TypeInfo)

unwrapResponse :: forall a b. DecodeJson a => DecodeJson b => String -> Either String (Either a b)
unwrapResponse s = lmap printJsonDecodeError do
  json <- parseJson s
  o <- decodeJson json
  resultType <- o .: "resultType"
  case resultType of
    "success" -> do
      result <- o .: "result"
      pure (Right result)
    _ -> do
      result <- o .: "result"
      pure (Left result)

instance decodeMessage :: DecodeJson Message where
  decodeJson json = maybe (Left (TypeMismatch "String")) (Right <<< Message) $ toString json

instance decodeModuleList :: DecodeJson ModuleList where
  decodeJson json = ModuleList <$> decodeJson json

instance decodeTypeInfo :: DecodeJson TypeInfo where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .: "identifier"
    type' <- o .: "type"
    module' <- o .: "module"
    definedAt <- o `getFieldMaybe` "definedAt"
    expandedType <- o `getFieldMaybe` "expandedType"
    documentation <- o `getFieldMaybe` "documentation"
    declarationTypeStr <- o `getFieldMaybe` "declarationType"
    -- TODO: Handling both missing/incorrect exportedFrom. Remove this after 0.12
    exportedFrom <- Right $ either (const []) identity $ getField o "exportedFrom"
    pure (TypeInfo
      { identifier
      , type'
      , module'
      , definedAt
      , expandedType
      , documentation
      , exportedFrom
      , declarationType: declarationTypeFromString =<< declarationTypeStr
      })
    where
    getFieldMaybe :: forall a. (DecodeJson a) => Object Json -> String -> Either JsonDecodeError (Maybe a)
    getFieldMaybe o f = Right $ either (const Nothing) Just $ getField o f

instance decodeTypePosition :: DecodeJson TypePosition where
  decodeJson json = do
    o <- decodeJson json
    name <- o .: "name"
    start <- o .: "start"
    end <- o .: "end"
    case start, end of
      [sl, sc], [el, ec] ->
        Right (TypePosition { name, start: { line: sl, column: sc }, end: { line: el, column: ec } })
      _, _ -> Left (TypeMismatch "Array")

instance decodePursuitCompletion :: DecodeJson PursuitCompletion where
  decodeJson json = do
    o <- decodeJson json
    identifier <- o .: "ident"
    type' <- o .: "type"
    module' <- o .: "module"
    package <- o .: "package"
    text <- o .: "text"
    pure (PursuitCompletion {
      identifier: identifier,
      type': type',
      module': module',
      package: package,
      text: text
      })

instance decodeImportList :: DecodeJson ImportList where
  decodeJson json = decodeObject <|> decodeArray
    where
      decodeObject = do
        o <- decodeJson json
        moduleNameField <- o .: "moduleName"
        moduleName <- decodeModuleNameBug moduleNameField <|> decodeJson moduleNameField
        imports <- o .: "imports"
        pure (ImportList { moduleName: Just moduleName, imports })
      -- TODO: Working around a bug where module Foo.Bar is jsonified as ["Foo", "Bar"] instead of "Foo.Bar"
      decodeModuleNameBug moduleName = joinWith "." <$> decodeJson moduleName
      decodeArray = do
        imports <- decodeJson json
        pure (ImportList { moduleName: Nothing, imports })

instance decodeImport :: DecodeJson Import where
  decodeJson json = do
    o <- decodeJson json
    moduleName <- o .: "module"
    importType <- o .: "importType"
    q <- (Just <$> o .: "qualifier") <|> pure Nothing
    case importType of
      "implicit" -> do
        pure $ Import {moduleName: moduleName, importType: Implicit, qualifier: q}
      "explicit" -> do
        identifiers <- o .: "identifiers"
        pure $ Import {moduleName: moduleName, importType: Explicit identifiers, qualifier: q}
      "hiding"   -> do
        identifiers <- o .: "identifiers"
        pure $ Import {moduleName: moduleName, importType: Hiding identifiers, qualifier: q}
      v -> Left (TypeMismatch "ImportType")

instance decodeImportResult :: DecodeJson ImportResult where
  decodeJson json = do
    (SuccessText <$> decodeJson json)
    <|> (SuccessFile <$> decodeJson json)
    <|> (MultipleResults <$> decodeJson json)
    <|> (Left (TypeMismatch "ImportResult"))

instance decodeRebuildError :: DecodeJson RebuildError where
  decodeJson json = do
    o <- decodeJson json
    message <- o .: "message"
    errorCode <- o .: "errorCode"
    errorLink <- o .: "errorLink"
    moduleName <- o .: "moduleName"
    filename <- o .: "filename"
    position <- pure $ hush do
      p <- o .: "position"
      { startLine: _, startColumn: _, endLine: _, endColumn: _ } <$> p .: "startLine" <*> p .: "startColumn" <*> p .: "endLine" <*> p .: "endColumn"
    pursIde <- pure $ hush do
      pio <- o .: "pursIde"
      name <- pio .: "name"
      completions <- pio .: "completions"
      pure $ PursIdeInfo { name, completions }
    suggestion <- pure $ hush do
      so <- o .: "suggestion"
      replacement <- so .: "replacement"
      rr <- so .: "replaceRange"
      replaceRange <- pure $ hush $ { startLine: _, startColumn: _, endLine: _, endColumn: _ } <$> rr .: "startLine" <*> rr .: "startColumn" <*> rr .: "endLine" <*> rr .: "endColumn"
      pure $ PscSuggestion { replacement, replaceRange }
    pure (RebuildError { errorCode, errorLink, moduleName, filename, message, position, pursIde, suggestion })

instance decodeRebuildResult :: DecodeJson RebuildResult where
  decodeJson json = RebuildResult <$> (decodeJson json <|> (singleton <$> decodeJson json))


Fix whitespace in unrelated SlamData.Monad.Auth file

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Monad.Auth where

import SlamData.Prelude
import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus as Bus
import Quasar.Advanced.QuasarAF as QA
import Quasar.Advanced.Types as QAT
import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.LocalStorage.Class as LS
import SlamData.LocalStorage.Keys as LSK
import SlamData.Quasar.Auth.Authentication as Auth
import SlamData.Quasar.Error as QError
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVar)
import Quasar.Error (QError(..), UnauthorizedDetails(..))
import SlamData.AuthenticationMode (AuthenticationMode, AllowedAuthenticationModes)
import SlamData.Effects (SlamDataEffects)
import SlamData.Quasar.Aff (runQuasarF)
import Utils (passover, singletonValue)

getIdTokenSilently ∷ AllowedAuthenticationModes → Auth.RequestIdTokenBus → Aff SlamDataEffects (Either QError Auth.EIdToken)
getIdTokenSilently interactionlessSignIn idTokenRequestBus =
  -- Currently singleton provider from Quasar configuration if none chosen.
  -- Eventually this will use all providers in Quasar configuration
  case interactionlessSignIn of
    AuthenticationMode.ChosenProviderAndAllProviders →
      either (const $ getWithSingletonProviderFromQuasar) (pure ∘ Right)
        =<< getWithProviderFromLocalStorage
    AuthenticationMode.ChosenProviderOnly →
      either
        (const $ signedOutBefore >>= if _ then pure unauthorized else getWithSingletonProviderFromQuasar)
        (pure ∘ Right)
        =<< getWithProviderFromLocalStorage
  where

  unauthorized ∷ Either QError Auth.EIdToken
  unauthorized =
    Left $ Unauthorized $ Just $ UnauthorizedDetails "Signed out"

  signedOutBefore ∷ Aff SlamDataEffects Boolean
  signedOutBefore =
    isRight <$> LS.retrieve LSK.signedOutBefore

  authModeSignedOutBefore ∷ AuthenticationMode.AuthenticationMode → Aff SlamDataEffects Boolean
  authModeSignedOutBefore =
    map isRight
      ∘ LS.retrieve
      ∘ LSK.nonceLocalStorageKey
      ∘ AuthenticationMode.toKeySuffix

  getWithProviderFromLocalStorage ∷ Aff SlamDataEffects (Either QError Auth.EIdToken)
  getWithProviderFromLocalStorage =
    shiftAffErrorsIntoQError $ traverse (get AuthenticationMode.ChosenProvider)
      =<< getProviderFromLocalStorage

  getWithSingletonProviderFromQuasar ∷ Aff SlamDataEffects (Either QError Auth.EIdToken)
  getWithSingletonProviderFromQuasar =
      shiftAffErrorsIntoQError $ traverse (get AuthenticationMode.AllProviders)
        =<< getSingletonProviderFromQuasar

  get ∷ AuthenticationMode → QAT.ProviderR → Aff SlamDataEffects Auth.EIdToken
  get mode providerR =
    AVar.takeVar =<< passover (write mode providerR) =<< AVar.makeVar

  write ∷ AuthenticationMode → QAT.ProviderR → AVar Auth.EIdToken → Aff SlamDataEffects Unit
  write mode providerR idToken =
    Bus.write
      { idToken
      , providerR
      , prompt: false
      , keySuffix: AuthenticationMode.toKeySuffix mode
      }
      idTokenRequestBus

  getSingletonProviderFromQuasar ∷ Aff SlamDataEffects (Either QError QAT.ProviderR)
  getSingletonProviderFromQuasar =
    flip bind singletonProvider <$> runQuasarF Nothing QA.authProviders

  singletonProvider ∷ Array QAT.ProviderR → Either QError QAT.ProviderR
  singletonProvider =
    singletonValue
      (Left $ unauthorizedError $ Just noProvidersMessage)
      (const $ Left $ unauthorizedError $ Just tooManyProvidersMessage)

  -- Get previously chosen provider from local storage
  getProviderFromLocalStorage ∷ Aff SlamDataEffects (Either QError QAT.ProviderR)
  getProviderFromLocalStorage =
    lmap (unauthorizedError ∘ Just) ∘ map QAT.runProvider
      <$> LS.retrieve
            (LSK.providerLocalStorageKey
               $ AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider)

  noProvidersMessage ∷ String
  noProvidersMessage =
    "Quasar is not configured with any authentication providers."

  tooManyProvidersMessage ∷ String
  tooManyProvidersMessage =
    "Quasar is configured with more than one authentication providers. Interactionless sign in currently only supports configurations with a single provider."

  unauthorizedError ∷ Maybe String → QError
  unauthorizedError =
    QError.Unauthorized ∘ map QError.UnauthorizedDetails

  shiftAffErrorsIntoQError ∷ ∀ a eff. Aff eff (Either QError a) → Aff eff (Either QError a)
  shiftAffErrorsIntoQError = map (either (Left ∘ QError.Error) id) ∘ Aff.attempt


add functions to generate and show samples

module Test.QuickCheck.LCG
  (
    Gen(),
    GenState(),
    GenOut(),
    Size(),
    LCG(),
    repeatable,
    stateful,
    variant,
    sized,
    resize,
    choose,
    chooseInt,
    oneOf,
    frequency,
    listOf,
    listOf1,
    vectorOf,
    elements,
    runGen,
    evalGen,
    perturbGen,
    uniform
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Random
import Debug.Trace
import Data.Maybe
import Data.Tuple
import Data.Foldable
import Data.Traversable
import Data.Monoid.Sum
import qualified Data.Array as A
import qualified Math as M

type LCG = Number
type Size = Number

type GenState = { newSeed :: LCG, size :: Size }

type GenOut a = { state :: GenState, value :: a }

data Gen a = Gen (GenState -> GenOut a)

repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ \s -> { value: \a -> (runGen (f a) s).value, state: s }

stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen (\s -> runGen (f s) s)

variant :: forall a. LCG -> Gen a -> Gen a
variant n g = Gen $ \s -> runGen g s { newSeed = n }

sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ \s -> runGen g s { size = sz }

choose :: Number -> Number -> Gen Number
choose a b = (*) (max - min) >>> (+) min <$> uniform where
  min = M.min a b
  max = M.max a b

chooseInt :: Number -> Number -> Gen Number
chooseInt a b = M.floor <$> choose (M.ceil a) (M.floor b + 0.999999999)

oneOf :: forall a. Gen a -> [Gen a] -> Gen a
oneOf x xs = do
  n <- chooseInt 0 (A.length xs)
  if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

frequency :: forall a. Tuple Number (Gen a) -> [Tuple Number (Gen a)] -> Gen a
frequency x xs = let
    xxs   = x : xs
    total = runSum $ fold (((Sum <<< fst) <$> xxs) :: [Sum])
    pick n d [] = d
    pick n d ((Tuple k x) : xs) = if n <= k then x else pick (n - k) d xs
  in do
    n <- chooseInt 1 total
    pick n (snd x) xxs

listOf :: forall a. Gen a -> Gen [a]
listOf g = sized $ \n ->
  do k <- chooseInt 0 n
     vectorOf k g

listOf1 :: forall a. Gen a -> Gen (Tuple a [a])
listOf1 g = sized $ \n ->
  do k  <- chooseInt 0 n
     x  <- g
     xs <- vectorOf (k - 1) g
     return $ Tuple x xs

vectorOf :: forall a. Number -> Gen a -> Gen [a]
vectorOf k g = sequence $ const g <$> (A.range 1 k)

elements :: forall a. a -> [a] -> Gen a
elements x xs = do
  n <- chooseInt 0 (A.length xs)
  pure if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

runGen :: forall a. Gen a -> GenState -> GenOut a
runGen (Gen f) = f

evalGen :: forall a. Gen a -> GenState -> a
evalGen gen st = (runGen gen st).value

sample :: forall r a. Size -> Gen a -> [a]
sample sz g = evalGen (vectorOf sz g) { newSeed: 0, size: sz }

showSample' :: forall r a. (Show a) => Size -> Gen a -> Eff (trace :: Trace | r) Unit
showSample' n g = print $ sample n g

showSample :: forall r a. (Show a) => Gen a -> Eff (trace :: Trace | r) Unit
showSample g = showSample' 10 g

--
-- Magic Numbers
--

lcgM :: Number
lcgM = 1103515245

lcgC :: Number
lcgC = 12345

lcgN :: Number
lcgN = 1 `shl` 30

lcgNext :: Number -> Number
lcgNext n = (lcgM * n + lcgC) % lcgN

lcgStep :: Gen Number
lcgStep = Gen f where
  f s = { value: s.newSeed, state: s { newSeed = lcgNext s.newSeed } }

uniform :: Gen Number
uniform = (\n -> n / (1 `shl` 30)) <$> lcgStep

foreign import float32ToInt32
  "function float32ToInt32(n) {\
  \  var arr = new ArrayBuffer(4);\
  \  var fv = new Float32Array(arr);\
  \  var iv = new Int32Array(arr);\
  \  fv[0] = n;\
  \  return iv[0];\
  \}" :: Number -> Number

perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n (Gen f) = Gen $ \s -> f (s { newSeed = lcgNext (float32ToInt32 n) + s.newSeed })

instance functorGen :: Functor Gen where
  (<$>) f (Gen g) = Gen $ \s -> case g s of
    { value = value, state = state } -> { value: f value, state: state }

instance applyGen :: Apply Gen where
  (<*>) (Gen f) (Gen x) = Gen $ \s ->
    case f s of
      { value = f', state = s' } -> case x s' of
        { value = x', state = s'' } -> { value: f' x', state: s'' }

instance applicativeGen :: Applicative Gen where
  pure a = Gen (\s -> { value: a, state: s })

instance bindGen :: Bind Gen where
  (>>=) (Gen f) g = Gen $ \s -> case f s of
    { value = value, state = state } -> runGen (g value) state

instance monadGen :: Monad Gen

module Test.QuickCheck.LCG
  (
    Gen(),
    GenState(),
    GenOut(),
    Size(),
    LCG(),
    repeatable,
    stateful,
    variant,
    sized,
    resize,
    choose,
    chooseInt,
    oneOf,
    frequency,
    listOf,
    listOf1,
    vectorOf,
    elements,
    runGen,
    evalGen,
    perturbGen,
    uniform
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Random
import Debug.Trace
import Data.Maybe
import Data.Tuple
import Data.Foldable
import Data.Traversable
import Data.Monoid.Sum
import qualified Data.Array as A
import qualified Math as M

type LCG = Number
type Size = Number

type GenState = { newSeed :: LCG, size :: Size }

type GenOut a = { state :: GenState, value :: a }

data Gen a = Gen (GenState -> GenOut a)

repeatable :: forall a b. (a -> Gen b) -> Gen (a -> b)
repeatable f = Gen $ \s -> { value: \a -> (runGen (f a) s).value, state: s }

stateful :: forall a. (GenState -> Gen a) -> Gen a
stateful f = Gen (\s -> runGen (f s) s)

variant :: forall a. LCG -> Gen a -> Gen a
variant n g = Gen $ \s -> runGen g s { newSeed = n }

sized :: forall a. (Size -> Gen a) -> Gen a
sized f = stateful (\s -> f s.size)

resize :: forall a. Size -> Gen a -> Gen a
resize sz g = Gen $ \s -> runGen g s { size = sz }

choose :: Number -> Number -> Gen Number
choose a b = (*) (max - min) >>> (+) min <$> uniform where
  min = M.min a b
  max = M.max a b

chooseInt :: Number -> Number -> Gen Number
chooseInt a b = M.floor <$> choose (M.ceil a) (M.floor b + 0.999999999)

oneOf :: forall a. Gen a -> [Gen a] -> Gen a
oneOf x xs = do
  n <- chooseInt 0 (A.length xs)
  if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

frequency :: forall a. Tuple Number (Gen a) -> [Tuple Number (Gen a)] -> Gen a
frequency x xs = let
    xxs   = x : xs
    total = runSum $ fold (((Sum <<< fst) <$> xxs) :: [Sum])
    pick n d [] = d
    pick n d ((Tuple k x) : xs) = if n <= k then x else pick (n - k) d xs
  in do
    n <- chooseInt 1 total
    pick n (snd x) xxs

listOf :: forall a. Gen a -> Gen [a]
listOf g = sized $ \n ->
  do k <- chooseInt 0 n
     vectorOf k g

listOf1 :: forall a. Gen a -> Gen (Tuple a [a])
listOf1 g = sized $ \n ->
  do k  <- chooseInt 0 n
     x  <- g
     xs <- vectorOf (k - 1) g
     return $ Tuple x xs

vectorOf :: forall a. Number -> Gen a -> Gen [a]
vectorOf k g = sequence $ const g <$> (A.range 1 k)

elements :: forall a. a -> [a] -> Gen a
elements x xs = do
  n <- chooseInt 0 (A.length xs)
  pure if n == 0 then x else fromMaybe x (xs A.!! (n - 1))

runGen :: forall a. Gen a -> GenState -> GenOut a
runGen (Gen f) = f

evalGen :: forall a. Gen a -> GenState -> a
evalGen gen st = (runGen gen st).value

sample :: forall a. Size -> Gen a -> [a]
sample sz g = evalGen (vectorOf sz g) { newSeed: 0, size: sz }

showSample' :: forall a. (Show a) => Size -> Gen a -> Eff (trace :: Trace) Unit
showSample' n g = print $ sample n g

showSample :: forall a. (Show a) => Gen a -> Eff (trace :: Trace) Unit
showSample g = showSample' 10 g

--
-- Magic Numbers
--

lcgM :: Number
lcgM = 1103515245

lcgC :: Number
lcgC = 12345

lcgN :: Number
lcgN = 1 `shl` 30

lcgNext :: Number -> Number
lcgNext n = (lcgM * n + lcgC) % lcgN

lcgStep :: Gen Number
lcgStep = Gen f where
  f s = { value: s.newSeed, state: s { newSeed = lcgNext s.newSeed } }

uniform :: Gen Number
uniform = (\n -> n / (1 `shl` 30)) <$> lcgStep

foreign import float32ToInt32
  "function float32ToInt32(n) {\
  \  var arr = new ArrayBuffer(4);\
  \  var fv = new Float32Array(arr);\
  \  var iv = new Int32Array(arr);\
  \  fv[0] = n;\
  \  return iv[0];\
  \}" :: Number -> Number

perturbGen :: forall a. Number -> Gen a -> Gen a
perturbGen n (Gen f) = Gen $ \s -> f (s { newSeed = lcgNext (float32ToInt32 n) + s.newSeed })

instance functorGen :: Functor Gen where
  (<$>) f (Gen g) = Gen $ \s -> case g s of
    { value = value, state = state } -> { value: f value, state: state }

instance applyGen :: Apply Gen where
  (<*>) (Gen f) (Gen x) = Gen $ \s ->
    case f s of
      { value = f', state = s' } -> case x s' of
        { value = x', state = s'' } -> { value: f' x', state: s'' }

instance applicativeGen :: Applicative Gen where
  pure a = Gen (\s -> { value: a, state: s })

instance bindGen :: Bind Gen where
  (>>=) (Gen f) g = Gen $ \s -> case f s of
    { value = value, state = state } -> runGen (g value) state

instance monadGen :: Monad Gen


Array and text box

Array and text box

module Component.Chat where

import Prelude
import WebAPI.Settings
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Servant.Subscriber as Subscribe
import Signal.Channel as Chan
import WebAPI.Subscriber as Sub
import Control.Category ((<<<))
import Control.Monad (class Monad, pure, bind)
import Control.Monad.Aff.Free (class Affable)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Reader (runReaderT)
import Data.Function ((<<<))
import Data.Generic (gCompare, gShow)
import Data.Maybe (Maybe(..), maybe, maybe')
import Data.Monoid (append)
import Data.NaturalTransformation (type (~>))
import Halogen (Component, ComponentDSL, ComponentHTML, EventSource, HalogenEffects, action, eventSource, subscribe, modify)
import Halogen.Component (lifecycleComponent)
import Halogen.HTML.Events (onChange)
import Halogen.HTML.Indexed (input, textarea)
import Network.HTTP.Affjax (AJAX)
import Servant.Subscriber (Subscriber, SubscriberEff, makeSubscriber)
import Servant.Subscriber.Connection (Config)
import Signal (Signal, runSignal)
import Signal.Channel (Channel, send, channel, CHANNEL)
import WebAPI.Subscriber (getGame)
import WebSocket (WEBSOCKET)

type State = {cur :: String , text :: Array String}

initial :: State
initial = {cur: "", text: []}

data Query a = Connect a | Disconnect a | UpdateText String a

type Effects  eff = (ajax :: AJAX, channel :: CHANNEL, ref :: REF, ws :: WEBSOCKET | eff)

chat :: forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g, MonadEff (HalogenEffects(Effects eff)) g) => Component State Query g
chat = lifecycleComponent {render, eval, initializer: Just (action Connect), finalizer: Just (action Disconnect)}
        where
              render :: State -> ComponentHTML Query
              render {text, cur} = H.div_ $ append [H.input []] $ (\t -> H.div_ [H.text t]) <$> text
              eval :: Query ~> (ComponentDSL State Query g)
              eval (Connect a) = do
                subscribe chatMessages
                pure a
              eval (Disconnect a) = pure a
              eval (UpdateText t a) = do
                modify (\s ->  s {text= append [t] s.text})
                pure a

data Action = Update String
            | ReportError
            | SubscriberLog String
            | Nop

type SubscriberData eff = {
  subscriber :: Subscriber eff Action
, messages :: Signal Action
}

initSubscriber :: forall eff. SubscriberEff (channel :: CHANNEL | eff) (SubscriberData (channel :: CHANNEL | eff))
initSubscriber = do
  ch <- channel Nop
  let
    c :: Config (channel :: CHANNEL | eff) Action
    c = {
        url : "ws://localhost:8080/subscriber"
      , notify : send ch <<< SubscriberLog <<< gShow
      , callback : send ch
      }
  sub <- makeSubscriber c
  let sig = Chan.subscribe ch
  --pongReq <- flip runReaderT settings $ MakeReq.putCounter (CounterAdd 1) -- | Let's play a bit! :-)
  -- closeReq <- flip runReaderT settings $ MakeReq.putCounter (CounterSet 100)
  subs <- flip runReaderT settings $ Sub.getGame (maybe (ReportError) Update)
  let conn = Subscribe.getConnection sub
 -- C.setPongRequest pongReq conn -- |< Hihi :-)
 -- C.setCloseRequest closeReq conn
  Subscribe.deploy subs sub
  pure $ { subscriber : sub, messages : sig }

callback :: forall eff.
  (Action -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       | eff
       ) Unit  )
  -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       | eff
       )
       Unit
callback eff = do
    s <- initSubscriber
    runSignal (eff <$> s.messages)

chatMessages ::  forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g) => EventSource Query g
chatMessages = eventSource callback (\a -> case a of
            Update s -> f $ UpdateText s
            Nop -> f $ UpdateText "No op"
            ReportError -> f $ UpdateText "Error"
            SubscriberLog s -> f $ UpdateText s
        )
        where
            f x = pure $ action x

module Component.Chat where

import Prelude
import WebAPI.Settings
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Servant.Subscriber as Subscribe
import Signal.Channel as Chan
import WebAPI.Subscriber as Sub
import CSS.Transform (offset)
import Control.Category ((<<<))
import Control.Monad (class Monad, pure, bind)
import Control.Monad.Aff.Free (class Affable)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Eff.Var (class Updatable)
import Control.Monad.Reader (runReaderT)
import Data.Function ((<<<))
import Data.Generic (gCompare, gShow)
import Data.Maybe (Maybe(..), maybe, maybe')
import Data.NaturalTransformation (type (~>))
import Halogen (Component, ComponentDSL, ComponentHTML, EventSource, HalogenEffects, action, eventSource, subscribe)
import Halogen.Component (lifecycleComponent)
import Halogen.Query (set)
import Network.HTTP.Affjax (AJAX, get)
import Servant.Subscriber (Subscriber, SubscriberEff, makeSubscriber)
import Servant.Subscriber.Connection (Config)
import Signal (Signal, runSignal)
import Signal.Channel (Channel, send, channel, CHANNEL)
import WebAPI.Subscriber (getGame)
import WebSocket (WEBSOCKET)

type State = {text :: String}

initial :: State
initial = {text: "Sup?"}

data Query a = Connect a | Disconnect a | UpdateText String a

type Effects  eff = (ajax :: AJAX, channel :: CHANNEL, ref :: REF, ws :: WEBSOCKET | eff)

chat :: forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g, MonadEff (HalogenEffects(Effects eff)) g) => Component State Query g
chat = lifecycleComponent {render, eval, initializer: Just (action Connect), finalizer: Just (action Disconnect)}
        where
              render :: State -> ComponentHTML Query
              render {text} = H.text text
              eval :: Query ~> (ComponentDSL State Query g)
              eval (Connect a) = do
                subscribe chatMessages
                pure a
              eval (Disconnect a) = pure a
              eval (UpdateText t a) = do
                set {text: t}
                pure a

data Action = Update String
            | ReportError
            | SubscriberLog String
            | Nop

type SubscriberData eff = {
  subscriber :: Subscriber eff Action
, messages :: Signal Action
}

initSubscriber :: forall eff. SubscriberEff (channel :: CHANNEL | eff) (SubscriberData (channel :: CHANNEL | eff))
initSubscriber = do
  ch <- channel Nop
  let
    c :: Config (channel :: CHANNEL | eff) Action
    c = {
        url : "ws://localhost:8080/subscriber"
      , notify : send ch <<< SubscriberLog <<< gShow
      , callback : send ch
      }
  sub <- makeSubscriber c
  let sig = Chan.subscribe ch
  --pongReq <- flip runReaderT settings $ MakeReq.putCounter (CounterAdd 1) -- | Let's play a bit! :-)
  -- closeReq <- flip runReaderT settings $ MakeReq.putCounter (CounterSet 100)
  subs <- flip runReaderT settings $ Sub.getGame (maybe (ReportError) Update)
  let conn = Subscribe.getConnection sub
 -- C.setPongRequest pongReq conn -- |< Hihi :-)
 -- C.setCloseRequest closeReq conn
  Subscribe.deploy subs sub
  pure $ { subscriber : sub, messages : sig }

callback :: forall eff.
  (Action -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       | eff
       ) Unit  )
  -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       | eff
       )
       Unit
callback eff = do
    s <- initSubscriber
    runSignal (eff <$> s.messages)

chatMessages ::  forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g) => EventSource Query g
chatMessages = eventSource callback (\a -> case a of
            Update s -> f $ UpdateText s
            Nop -> f $ UpdateText "No op"
            ReportError -> f $ UpdateText "Error"
            SubscriberLog s -> f $ UpdateText s
        )
        where
            f x = pure $ action x


Fix a whole bunch of coordinate bugs

Fix a whole bunch of coordinate bugs

module Genetics.Browser.Types.Coordinates where

import Prelude

import Control.Alternative (empty)
import Control.MonadPlus (guard)
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Foldable (length, sum)
import Data.Foreign.Class (class Decode, class Encode)
import Data.Int as Int
import Data.Lens (APrism', Iso', Lens', Prism', Traversal', filtered, foldMapOf, iso, lens, preview, previewOn, prism', takeBoth, traversed, view, (^.))
import Data.Lens as Lens
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record as Lens
import Data.Lens.Types (Iso')
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Profunctor.Choice (fanin)
import Data.Profunctor.Strong (fanout, splitStrong)
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Symbol (SProxy(..))
import Data.Tuple (Tuple(..), fst, snd, uncurry)
import Debug.Trace as Debug
import Genetics.Browser.Types (Bp(..), Point)
import Genetics.Browser.View (Pixels)
import Unsafe.Coerce (unsafeCoerce)

-- The global coordinate system works by taking the sum of the chromosome sizes;
-- we represent it using a BigInt

-- Consider making it a wrapper on Ratio BigInt instead.
-- Would ensure exactness when moving between global & interval points...
-- ... while that shouldn't be a problem anyway, it would make things feel safer.
newtype BrowserPoint = BPoint BigInt

derive instance eqBrowserPoint :: Eq BrowserPoint
derive instance ordBrowserPoint :: Ord BrowserPoint
derive instance newtypeBrowserPoint :: Newtype BrowserPoint _

derive newtype instance ringBrowserPoint :: Ring BrowserPoint
derive newtype instance semiringBrowserPoint :: Semiring BrowserPoint
derive newtype instance commutativeringBrowserPoint :: CommutativeRing BrowserPoint
derive newtype instance euclideanringBrowserPoint :: EuclideanRing BrowserPoint

-- Subsets of the global coordinate system are defined by some interval,
--

-- data Interval c = Interval c c

type Interval = Pair

type RelPoint = Ratio BigInt
-- data IntervalPoint c = IntervalPoint (Interval c) RelPoint

relPointToNumber :: RelPoint -> Number
relPointToNumber p =
  let d = Ratio.denominator p
      n = Ratio.numerator p
      qt = BigInt.toNumber $ n / d
      -- rm = BigInt.toNumber $ case n `mod` d of
      --                          0 -> 1
      --                          x -> x
      -- TODO be safer by using Number.EPSILON etc.
      -- eps =  2.220446049250313e-16
      -- epsD =  BigInt.fromString "22204460492503130000000000000000"
  in qt -- + (rm / (BigInt.toNumber d))

intervalSize :: forall c.
                Ring c
             => Interval c
             -> c
intervalSize (Pair l r) = r - l

inInterval :: forall c.
               Ord c
            => c
            -> Interval c
            -> Boolean
inInterval p (Pair l r) = l <= p && p <= r

-- TODO test this
intervalsOverlap :: forall c.
                    Ord c
                 => Interval c
                 -> Interval c
                 -> Boolean
intervalsOverlap (Pair l1 r1) (Pair l2 r2) =
  let (Pair l1' r1') = Pair (min l1 l2) (min r1 r2)
      (Pair l2' r2') = Pair (max l1 l2) (max r1 r2)
  in r1' >= l2'

p0 = Pair 0 0
p1 = Pair 0 2
p2 = Pair 2 4
p3 = Pair 3 4
p4 = Pair (-2) (-1)

coveringIntervals :: forall f i c.
                     Ord c
                  => Filterable f
                  => Interval c
                  -> f (Interval c)
                  -> f (Interval c)
coveringIntervals iv = filter (intervalsOverlap iv)

-- type ChrInterval c = { interval :: Interval c, chrSize :: Number }

type CoordInterval i c = { index :: i
                         , interval :: Interval c
                         , chrSize :: Bp }

_Index :: forall i c. Lens' (CoordInterval i c) i
_Index = Lens.prop (SProxy :: SProxy "index")

_Interval :: forall i c. Lens' (CoordInterval i c) (Interval c)
_Interval = Lens.prop (SProxy :: SProxy "interval")

_ChrSize :: forall i c. Lens' (CoordInterval i c) Bp
_ChrSize = Lens.prop (SProxy :: SProxy "chrSize")

type CoordSysRec i c =
  { size :: c
  , padding :: c
  -- , intervals :: Array (Tuple i (Interval c))
  , intervals :: Array (CoordInterval i c)
  }

newtype CoordSys i c =
  CoordSys (CoordSysRec i c)

-- traversed :: forall t a b. Traversable t => Traversal (t a) (t b) a b
_CoordSys :: forall i c. Lens' (CoordSys i c) (CoordSysRec i c)
_CoordSys = lens (\(CoordSys x) -> x) (\(CoordSys _) x -> CoordSys x)

_BrowserIntervals :: forall i c. Traversal' (CoordSys i c) (CoordInterval i c)
_BrowserIntervals = _CoordSys <<<
                    Lens.prop (SProxy :: SProxy "intervals") <<<
                    traversed

_BrowserSize :: forall i c. Lens' (CoordSys i c) c
_BrowserSize = _CoordSys <<<
               Lens.prop (SProxy :: SProxy "size")

_BrowserPadding :: forall i c. Lens' (CoordSys i c) c
_BrowserPadding = _CoordSys <<<
               Lens.prop (SProxy :: SProxy "padding")

findIntervalFromGlobal :: forall f i c r.
                          Ord c
                       => c
                       -> Array { interval :: Interval c | r }
                       -> Maybe { interval :: Interval c | r }
findIntervalFromGlobal x = Array.find (inInterval x <<< _.interval)

findBrowserInterval :: forall i c.
                       Ord c
                    => CoordSys i c
                    -> c
                    -> Maybe (CoordInterval i c)
findBrowserInterval cs x = previewOn cs
                            (_BrowserIntervals <<<
                             Lens.filtered
                             (inInterval x <<< view _Interval))

viewIntervals :: forall i c.
                 Ord c
              => CoordSys i c
              -> Interval c
              -> Array (CoordInterval i c)
viewIntervals cs vw = foldMapOf inView pure cs
  where inView = _BrowserIntervals <<<
                 Lens.filtered (intervalsOverlap vw <<< view _Interval)

globalToInterval :: forall c.
                    Newtype c BigInt
                 => Interval c
                 -> c
                 -> RelPoint
globalToInterval v x = globalToInterval' (map unwrap v) (unwrap x)

globalToInterval' :: forall c.
                     Ord c
                  => EuclideanRing c
                  => Interval c
                  -> c
                  -> Ratio c
globalToInterval' (Pair l r) x =
  let n = x - l
      d = max one (r - l)
  in n % d

-- Global <-> Interval are isomorphic for big enough intervals...
intervalToGlobal :: forall c.
                    Newtype c BigInt
                 => Interval c
                 -> RelPoint
                 -> c
intervalToGlobal v x = wrap $ intervalToGlobal' (map unwrap v) x

intervalToGlobal' :: forall c.
                     Ord c
                  => Show c
                  => EuclideanRing c
                  => Interval c
                  -> Ratio c
                  -> c
intervalToGlobal' iv@(Pair l r) p =
  let d1 = max one (r - l)
      d2 = Ratio.denominator p
      a = d1 / d2
      n = a * Ratio.numerator p
  in l + n

offsets :: BigInt -> Array BigInt -> Array (Pair BigInt)
offsets pad xs = ivals
  where os = Array.scanl (\x y -> pad + x + y) zero xs
        ivals = Array.zipWith Pair (zero `Array.cons` os) os

mkCoordSys :: forall i c.
           Array (Tuple i BigInt)
        -> BigInt
        -> CoordSys i BrowserPoint
mkCoordSys chrs pad = CoordSys { size
                               , intervals
                               , padding
                               }
  where (Tuple ids sizes) = Array.unzip chrs
        ivals = (map <<< map) wrap $ offsets pad sizes

        f :: i -> BigInt -> { index :: i, chrSize :: Bp }
        f index s = { index, chrSize: wrap $ BigInt.toNumber s }

        g :: Interval BrowserPoint -> { index :: i, chrSize :: _ } -> _
        g interval { index, chrSize } = { interval, index, chrSize }

        intervals :: Array (CoordInterval i _)
        intervals = Array.zipWith g ivals (uncurry f <$> chrs)

        size' = (sum sizes) + (length sizes * pad)
        size :: BrowserPoint
        size = wrap size'
        padding :: BrowserPoint
        padding = wrap pad

canvasToView :: forall r.
                { width :: Number | r }
             -> Number
             -> RelPoint
canvasToView {width} x = globalToInterval' (Pair zero w') x'
  where (Pair x' w') = BigInt.fromInt <<< Int.round <$> Pair x width

canvasToBrowserPoint :: forall r.
                        { width :: Number | r }
                     -> Interval BrowserPoint
                     -> Number
                     -> BrowserPoint
canvasToBrowserPoint cw v@(Pair vL vR) x =
  intervalToGlobal v $ (canvasToView cw x)

browserPointToCanvas :: forall r.
                        { width :: Number | r }
                     -> Interval BrowserPoint
                     -> BrowserPoint
                     -> Number
browserPointToCanvas screenSize v@(Pair vL vR) p = relPointToNumber pixels'
  where viewSize :: BigInt
        viewSize = unwrap $ intervalSize v
        width' = BigInt.fromInt $ Int.round screenSize.width
        -- Pixels/BrowserPoint
        scale :: Ratio BigInt
        scale = width' % viewSize
        pixels' = (unwrap (p - vL) % one) * scale

intervalToScreen :: forall i c r.
                    { width :: Number | r }
                 -> Interval BrowserPoint
                 -> Interval BrowserPoint
                 -> { width :: Number, offset :: Number }
intervalToScreen screen v interval = {width, offset}
  where (Pair l r) = browserPointToCanvas screen v <$> interval
        width = r - l
        offset = l

shiftIntervalBy :: forall c.
                   Newtype c BigInt
                => Interval c
                -> Ratio BigInt
                -> Interval c
shiftIntervalBy v rat = wrap <$> shiftIntervalBy' (unwrap <$> v) rat

shiftIntervalBy' :: forall c.
                    EuclideanRing c
                 => Interval c
                 -> Ratio c
                 -> Interval c
shiftIntervalBy' v@(Pair l r) rat =
  let diff = ((r - l) * (Ratio.numerator rat)) / (Ratio.denominator rat)
      v' = Pair (l + diff) (r + diff)
  in v'

newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (Normalized a) _

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint {width, height} {x, y} = Normalized { x: x', y: y' }
  where x' = x / width
        y' = y / height

normPoint :: Point -> Maybe (Normalized Point)
normPoint p@{x, y}
  | x < 0.0 || x > 1.0 = Nothing
  | y < 0.0 || y > 1.0 = Nothing
  | otherwise = Just $ Normalized p

nPointToFrame :: Pixels -> Pixels -> Normalized Point -> Point
nPointToFrame w h (Normalized p) = {x: p.x * w, y: p.y * h}

module Genetics.Browser.Types.Coordinates where

import Prelude

import Control.Alternative (empty)
import Control.MonadPlus (guard)
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Filterable (class Filterable, filter, filterMap)
import Data.Foldable (length, sum)
import Data.Foreign.Class (class Decode, class Encode)
import Data.Int as Int
import Data.Lens (APrism', Iso', Lens', Prism', Traversal', filtered, foldMapOf, iso, lens, preview, previewOn, prism', takeBoth, traversed, view, (^.))
import Data.Lens as Lens
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record as Lens
import Data.Lens.Types (Iso')
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.Pair (Pair(..))
import Data.Profunctor.Choice (fanin)
import Data.Profunctor.Strong (fanout, splitStrong)
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Symbol (SProxy(..))
import Data.Tuple (Tuple(..), fst, snd, uncurry)
import Debug.Trace as Debug
import Genetics.Browser.Types (Bp(..), Point)
import Genetics.Browser.View (Pixels)
import Unsafe.Coerce (unsafeCoerce)

-- The global coordinate system works by taking the sum of the chromosome sizes;
-- we represent it using a BigInt

-- Consider making it a wrapper on Ratio BigInt instead.
-- Would ensure exactness when moving between global & interval points...
-- ... while that shouldn't be a problem anyway, it would make things feel safer.
newtype BrowserPoint = BPoint BigInt

derive instance eqBrowserPoint :: Eq BrowserPoint
derive instance ordBrowserPoint :: Ord BrowserPoint
derive instance newtypeBrowserPoint :: Newtype BrowserPoint _

derive newtype instance ringBrowserPoint :: Ring BrowserPoint
derive newtype instance semiringBrowserPoint :: Semiring BrowserPoint
derive newtype instance euclideanringBrowserPoint :: EuclideanRing BrowserPoint

-- Subsets of the global coordinate system are defined by some interval,
--

-- data Interval c = Interval c c

type Interval = Pair

type RelPoint = Ratio BigInt
-- data IntervalPoint c = IntervalPoint (Interval c) RelPoint

relPointToNumber :: RelPoint -> Number
relPointToNumber p =
  let d = Ratio.denominator p
      n = Ratio.numerator p
      qt = BigInt.toNumber $ n / d
      -- rm = BigInt.toNumber $ case n `mod` d of
      --                          0 -> 1
      --                          x -> x
      -- TODO be safer by using Number.EPSILON etc.
      -- eps =  2.220446049250313e-16
      -- epsD =  BigInt.fromString "22204460492503130000000000000000"
  in qt -- + (rm / (BigInt.toNumber d))

intervalSize :: forall c.
                Ring c
             => Interval c
             -> c
intervalSize (Pair l r) = r - l

inInterval :: forall c.
               Ord c
            => c
            -> Interval c
            -> Boolean
inInterval p (Pair l r) = l <= p && p <= r

-- TODO test this
intervalsOverlap :: forall c.
                    Ord c
                 => Interval c
                 -> Interval c
                 -> Boolean
intervalsOverlap (Pair l1 r1) (Pair l2 r2) = not $ r1 < l2 && r2 < l1

coveringIntervals :: forall f i c.
                     Ord c
                  => Filterable f
                  => Interval c
                  -> f (Interval c)
                  -> f (Interval c)
coveringIntervals iv = filter (intervalsOverlap iv)

-- type ChrInterval c = { interval :: Interval c, chrSize :: Number }

type CoordInterval i c = { index :: i
                         , interval :: Interval c
                         , chrSize :: Bp }

_Index :: forall i c. Lens' (CoordInterval i c) i
_Index = Lens.prop (SProxy :: SProxy "index")

_Interval :: forall i c. Lens' (CoordInterval i c) (Interval c)
_Interval = Lens.prop (SProxy :: SProxy "interval")

_ChrSize :: forall i c. Lens' (CoordInterval i c) Bp
_ChrSize = Lens.prop (SProxy :: SProxy "chrSize")

type CoordSysRec i c =
  { size :: c
  , padding :: c
  -- , intervals :: Array (Tuple i (Interval c))
  , intervals :: Array (CoordInterval i c)
  }

newtype CoordSys i c =
  CoordSys (CoordSysRec i c)

-- traversed :: forall t a b. Traversable t => Traversal (t a) (t b) a b
_CoordSys :: forall i c. Lens' (CoordSys i c) (CoordSysRec i c)
_CoordSys = lens (\(CoordSys x) -> x) (\(CoordSys _) x -> CoordSys x)

_BrowserIntervals :: forall i c. Traversal' (CoordSys i c) (CoordInterval i c)
_BrowserIntervals = _CoordSys <<<
                    Lens.prop (SProxy :: SProxy "intervals") <<<
                    traversed

_BrowserSize :: forall i c. Lens' (CoordSys i c) c
_BrowserSize = _CoordSys <<<
               Lens.prop (SProxy :: SProxy "size")

_BrowserPadding :: forall i c. Lens' (CoordSys i c) c
_BrowserPadding = _CoordSys <<<
               Lens.prop (SProxy :: SProxy "padding")

findIntervalFromGlobal :: forall f i c r.
                          Ord c
                       => c
                       -> Array { interval :: Interval c | r }
                       -> Maybe { interval :: Interval c | r }
findIntervalFromGlobal x = Array.find (inInterval x <<< _.interval)

findBrowserInterval :: forall i c.
                       Ord c
                    => CoordSys i c
                    -> c
                    -> Maybe (CoordInterval i c)
findBrowserInterval cs x = previewOn cs
                            (_BrowserIntervals <<<
                             Lens.filtered
                             (inInterval x <<< view _Interval))

viewIntervals :: forall i c.
                 Ord c
              => CoordSys i c
              -> Interval c
              -> Array (CoordInterval i c)
viewIntervals cs vw = foldMapOf inView pure cs
  where inView = _BrowserIntervals <<<
                 Lens.filtered (intervalsOverlap vw <<< view _Interval)

globalToInterval :: forall c.
                    Newtype c BigInt
                 => Interval c
                 -> c
                 -> RelPoint
globalToInterval v x = globalToInterval' (map unwrap v) (unwrap x)

globalToInterval' :: Interval BigInt
                  -> BigInt
                  -> RelPoint
globalToInterval' (Pair l r) x =
  let n = x - l
      d = r - l
  in n % d

intervalToGlobal :: forall c.
                    Newtype c BigInt
                 => Interval c
                 -> RelPoint
                 -> c
intervalToGlobal v x = wrap $ intervalToGlobal' (map unwrap v) x

intervalToGlobal' :: Interval BigInt
                  -> RelPoint
                  -> BigInt
intervalToGlobal' iv p =
  let (Pair l r) = iv
      s = (r - l) % one
      x = p*s + (l % one)
      n = Ratio.numerator x
      d = Ratio.denominator x
  in (n / d)

offsets :: BigInt -> Array BigInt -> Array (Pair BigInt)
offsets pad xs = ivals
  where os = Array.scanl (\x y -> pad + x + y) zero xs
        ivals = Array.zipWith Pair (zero `Array.cons` os) os

mkCoordSys :: forall i c.
           Array (Tuple i BigInt)
        -> BigInt
        -> CoordSys i BrowserPoint
mkCoordSys chrs pad = CoordSys { size
                               , intervals
                               , padding
                               }
  where (Tuple ids sizes) = Array.unzip chrs
        ivals = (map <<< map) wrap $ offsets pad sizes

        f :: i -> BigInt -> { index :: i, chrSize :: Bp }
        f index s = { index, chrSize: wrap $ BigInt.toNumber s }

        g :: Interval BrowserPoint -> { index :: i, chrSize :: _ } -> _
        g interval { index, chrSize } = { interval, index, chrSize }

        intervals :: Array (CoordInterval i _)
        intervals = Array.zipWith g ivals (uncurry f <$> chrs)

        size' = (sum sizes) + (length sizes * pad)
        size :: BrowserPoint
        size = wrap size'
        padding :: BrowserPoint
        padding = wrap pad

canvasToView :: forall r.
                { width :: Number | r }
             -> Number
             -> RelPoint
canvasToView {width} x = globalToInterval' (Pair zero w') x'
  where (Pair x' w') = BigInt.fromInt <<< Int.round <$> Pair x width

canvasToBrowserPoint :: forall r.
                        { width :: Number | r }
                     -> Interval BrowserPoint
                     -> Number
                     -> BrowserPoint
canvasToBrowserPoint cw v@(Pair vL vR) x =
  intervalToGlobal v $ (canvasToView cw x)

browserPointToCanvas :: forall r.
                        { width :: Number | r }
                     -> Interval BrowserPoint
                     -> BrowserPoint
                     -> Number
browserPointToCanvas screenSize v@(Pair vL vR) p = relPointToNumber pixels'
  where viewSize :: BigInt
        viewSize = unwrap $ intervalSize v
        width' = BigInt.fromInt $ Int.round screenSize.width
        -- Pixels/BrowserPoint
        scale :: Ratio BigInt
        scale = width' % viewSize
        pixels' = (unwrap p % one) * scale

intervalToScreen :: forall i c r.
                    { width :: Number | r }
                 -> Interval BrowserPoint
                 -> Interval BrowserPoint
                 -> { width :: Number, offset :: Number }
intervalToScreen screen v interval = {width, offset}
  where (Pair l r) = browserPointToCanvas screen v <$> interval
        width = r - l
        offset = l

shiftIntervalBy :: forall c.
                   Newtype c BigInt
                => Interval c
                -> Ratio BigInt
                -> Interval c
shiftIntervalBy v@(Pair l r) rat =
  let l' = unwrap l
      r' = unwrap r
      diff = ((r' - l') * (Ratio.numerator rat)) / (Ratio.denominator rat)
      v' = Pair (l' + diff) (r' + diff)
  in Debug.trace (show (map unwrap v) <> " shifted by " <> show rat <> " means " <> show diff <> " output is " <> show v')
     \_ -> map wrap v'

newtype Normalized a = Normalized a

derive instance newtypeNormalized :: Newtype (Normalized a) _

normalizePoint :: { width :: Number
                  , height :: Number }
               -> Point
               -> Normalized Point
normalizePoint {width, height} {x, y} = Normalized { x: x', y: y' }
  where x' = x / width
        y' = y / height

normPoint :: Point -> Maybe (Normalized Point)
normPoint p@{x, y}
  | x < 0.0 || x > 1.0 = Nothing
  | y < 0.0 || y > 1.0 = Nothing
  | otherwise = Just $ Normalized p

nPointToFrame :: Pixels -> Pixels -> Normalized Point -> Point
nPointToFrame w h (Normalized p) = {x: p.x * w, y: p.y * h}


show args

show args

module Main
  ( main
  ) where

import Prelude

import Data.Array as Array
import Data.Maybe (Maybe)
import Data.Maybe as Maybe
import Effect (Effect)
import Effect.Console as Console
import Effect.Exception as Exception
import Foreign.Object as Object
import Node.Process as Process

type Config =
  { apiKey :: String
  , hatenaId :: String
  }

loadConfig :: Effect (Maybe Config)
loadConfig = do
  env <- Process.getEnv
  pure do
    apiKey <- Object.lookup "HATENA_API_KEY" env
    hatenaId <- Object.lookup "HATENA_ID" env
    pure { apiKey, hatenaId }

main :: Effect Unit
main = do
  args <- map (Array.drop 2) Process.argv
  Console.logShow args
  configMaybe <- loadConfig
  config <- Maybe.maybe (Exception.throw "invalid config") pure configMaybe
  Console.logShow config

module Main
  ( main
  ) where

import Prelude

import Data.Maybe (Maybe)
import Effect (Effect)
import Effect.Console as Console
import Foreign.Object as Object
import Node.Process as Process

type Config =
  { apiKey :: String
  , hatenaId :: String
  }

loadConfig :: Effect (Maybe Config)
loadConfig = do
  env <- Process.getEnv
  pure do
    apiKey <- Object.lookup "HATENA_API_KEY" env
    hatenaId <- Object.lookup "HATENA_ID" env
    pure { apiKey, hatenaId }

main :: Effect Unit
main = do
  config <- loadConfig
  Console.logShow config


Delete contents before adding new elements

module Main (main) where

import Control.Monad
import Control.Monad.Eff
import DOM
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.Window
import Data.Enum
import Data.Foldable
import Data.Maybe
import Data.String.Regex (regex, parseFlags, replace)
import Data.Traversable
import Debug.Trace
import qualified Data.StrMap as SM

import DOMHelper
import Isomer
import Level
import Sortable
import Storage
import Transformer
import Types

-- | RGB codes for the abstract colors
cubeColor :: Cube -> IsomerColor
cubeColor Blue = colorFromRGB 0 160 176
cubeColor Brown = colorFromRGB 106 74 60
cubeColor Red = colorFromRGB 204 51 63
cubeColor Orange = colorFromRGB 235 104 65
cubeColor Yellow = colorFromRGB 237 201 81

-- | Like traverse_, but specialized for arrays with an additional parameter (index of element)
traverseWithIndex_ :: forall a b m. (Applicative m) => (Number -> a -> m b) -> [a] -> m Unit
traverseWithIndex_ f xs = sequence_ (zipWith f (0 .. (length xs - 1)) xs)

-- | Render a single stack of cubes
renderStack :: forall eff. IsomerInstance -> Number -> Number -> Stack -> Eff (isomer :: Isomer | eff) Unit
renderStack isomer y x stack =
    traverseWithIndex_ (renderCube isomer x (-6 * y)) $ map cubeColor stack

-- | Render a wall (multiple stacks)
renderWall :: forall eff. IsomerInstance -> Number -> Wall -> Eff (isomer :: Isomer | eff) Unit
renderWall isomer y wall =
    traverseWithIndex_ (\x -> renderStack isomer y (length wall - x)) (reverse wall)

-- | Render a series of walls
renderWalls :: forall eff. IsomerInstance -> [Wall] -> Eff (isomer :: Isomer | eff) Unit
renderWalls isomer walls = do
    setIsomerConfig isomer 40 40 400
    traverseWithIndex_ (renderWall isomer) walls

-- | Render the target shape
renderTarget isomer target = do
    setIsomerConfig isomer 22 1200 250
    renderWall isomer 0 target

-- | Render all UI components, DOM and canvas
render = do
    doc <- document globalWindow
    isomer <- getIsomerInstance "canvas"

    -- Retrieve current 'program'
    Just ulAvailable <- getElementById "program" doc
    lis <- children ulAvailable
    ids <- traverse (getAttribute "id") lis
    let fs = mapMaybe (getTransformerById chapter) ids
    let steps = allSteps fs level.initial

    -- On-canvas rendering
    clearCanvas isomer
    renderWalls isomer steps
    renderTarget isomer level.target

    -- DOM 'rendering'
    let message = if (maybe false (== (level.target)) (last steps))
                  then "Solved!"
                  else "Target"
    withElementById "message" doc (setInnerHTML message)

    -- DEBUG:
    trace $ "IDs: " ++ show ids
    trace $ "Initial: " ++ show level.initial
    trace "Steps:"
    traverse_ print steps
    trace "---"
    trace $ "Target: " ++ show level.target
    trace ""

-- | Replace color placeholders in the transformer description by colored rectangular divs
replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show (Blue `enumFromTo` Yellow))
        where replaceColor s c = replace (regex (pattern c) rf) (replacement c) s
              rf = parseFlags "g"
              pattern c = "{" ++ c ++ "}"
              replacement c = "<div class=\"rect " ++ c ++ "\"> </div>"

-- | General key press handler
keyPress :: forall eff. DOMEvent -> Eff (dom :: DOM, isomer :: Isomer, trace :: Trace | eff) Unit
keyPress event = do
    doc <- document globalWindow
    code <- keyCode event
    case code of
         -- 'g': generate new puzzle
         71 -> return unit
         -- 'r': reset lists
         82 -> do resetUI
                  render
         _ -> return unit
    return unit

-- | Click handler for the <li> elements (transformers)
clickLi :: forall eff. HTMLElement -> DOMEvent -> Eff (dom :: DOM, trace :: Trace, isomer :: Isomer | eff) Unit
clickLi li event = do
    doc <- document globalWindow
    parent <- parentElement li >>= getAttribute "id"
    let other = if parent == "available" then "program" else "available"
    withElementById other doc (flip appendChild li)

    render

appendLiElement :: forall eff. HTMLElement -> String -> TransformerRecord -> Eff (dom :: DOM | eff) Unit
appendLiElement ul id t = do
    doc <- document globalWindow
    li <- createElement doc "li"
    setAttribute "id" id li
    setInnerHTML (replaceColors t.name) li
    appendChild ul li

-- | Set up or reset the whole UI
resetUI :: forall eff. Eff (dom :: DOM | eff) Unit
resetUI = do
    doc <- document globalWindow
    withElementById "available" doc $ \ulAvailable -> do
        -- create li elements for transformers
        setInnerHTML "" ulAvailable
        _ <- SM.foldM (\z -> appendLiElement ulAvailable) unit chapter.transformers

        -- set up mouse event handlers
        items <- children ulAvailable
        traverse_ (\li -> addMouseEventListener MouseClickEvent (clickLi li) li) items

    withElementById "program" doc (setInnerHTML "")

-- TODO
chapter = case (head allChapters) of Just c -> c
level = case (getLevelById "1") of Just level -> level

-- | Initial game state for first-time visitors
initialGS :: GameState
initialGS = { currentLevel: "1", levelState: SM.empty }

main = do
    doc <- document globalWindow

    -- install sortable
    Just ulAvailable <- getElementById "available" doc
    Just ulProgram   <- getElementById "program" doc
    installSortable ulAvailable (return unit)
    installSortable ulProgram render

    -- set up keyboard event handlers
    addKeyboardEventListener KeydownEvent keyPress globalWindow

    -- render initial state
    resetUI
    render

module Main (main) where

import Control.Monad
import Control.Monad.Eff
import DOM
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.Window
import Data.Enum
import Data.Foldable
import Data.Maybe
import Data.String.Regex (regex, parseFlags, replace)
import Data.Traversable
import Debug.Trace
import qualified Data.StrMap as SM

import DOMHelper
import Isomer
import Level
import Sortable
import Storage
import Transformer
import Types

-- | RGB codes for the abstract colors
cubeColor :: Cube -> IsomerColor
cubeColor Blue = colorFromRGB 0 160 176
cubeColor Brown = colorFromRGB 106 74 60
cubeColor Red = colorFromRGB 204 51 63
cubeColor Orange = colorFromRGB 235 104 65
cubeColor Yellow = colorFromRGB 237 201 81

-- | Like traverse_, but specialized for arrays with an additional parameter (index of element)
traverseWithIndex_ :: forall a b m. (Applicative m) => (Number -> a -> m b) -> [a] -> m Unit
traverseWithIndex_ f xs = sequence_ (zipWith f (0 .. (length xs - 1)) xs)

-- | Render a single stack of cubes
renderStack :: forall eff. IsomerInstance -> Number -> Number -> Stack -> Eff (isomer :: Isomer | eff) Unit
renderStack isomer y x stack =
    traverseWithIndex_ (renderCube isomer x (-6 * y)) $ map cubeColor stack

-- | Render a wall (multiple stacks)
renderWall :: forall eff. IsomerInstance -> Number -> Wall -> Eff (isomer :: Isomer | eff) Unit
renderWall isomer y wall =
    traverseWithIndex_ (\x -> renderStack isomer y (length wall - x)) (reverse wall)

-- | Render a series of walls
renderWalls :: forall eff. IsomerInstance -> [Wall] -> Eff (isomer :: Isomer | eff) Unit
renderWalls isomer walls = do
    setIsomerConfig isomer 40 40 400
    traverseWithIndex_ (renderWall isomer) walls

-- | Render the target shape
renderTarget isomer target = do
    setIsomerConfig isomer 22 1200 250
    renderWall isomer 0 target

-- | Render all UI components, DOM and canvas
render = do
    doc <- document globalWindow
    isomer <- getIsomerInstance "canvas"

    -- Retrieve current 'program'
    Just ulAvailable <- getElementById "program" doc
    lis <- children ulAvailable
    ids <- traverse (getAttribute "id") lis
    let fs = mapMaybe (getTransformerById chapter) ids
    let steps = allSteps fs level.initial

    -- On-canvas rendering
    clearCanvas isomer
    renderWalls isomer steps
    renderTarget isomer level.target

    -- DOM 'rendering'
    let message = if (maybe false (== (level.target)) (last steps))
                  then "Solved!"
                  else "Target"
    withElementById "message" doc (setInnerHTML message)

    -- DEBUG:
    trace $ "IDs: " ++ show ids
    trace $ "Initial: " ++ show level.initial
    trace "Steps:"
    traverse_ print steps
    trace "---"
    trace $ "Target: " ++ show level.target
    trace ""

-- | Replace color placeholders in the transformer description by colored rectangular divs
replaceColors :: String -> String
replaceColors s =
    foldl replaceColor s ("X" : map show (Blue `enumFromTo` Yellow))
        where replaceColor s c = replace (regex (pattern c) rf) (replacement c) s
              rf = parseFlags "g"
              pattern c = "{" ++ c ++ "}"
              replacement c = "<div class=\"rect " ++ c ++ "\"> </div>"

-- | General key press handler
keyPress :: forall eff. DOMEvent -> Eff (dom :: DOM, isomer :: Isomer, trace :: Trace | eff) Unit
keyPress event = do
    doc <- document globalWindow
    code <- keyCode event
    case code of
         -- 'g': generate new puzzle
         71 -> return unit
         -- 'r': reset lists
         82 -> do resetUI
                  render
         _ -> return unit
    return unit

-- | Click handler for the <li> elements (transformers)
clickLi :: forall eff. HTMLElement -> DOMEvent -> Eff (dom :: DOM, trace :: Trace, isomer :: Isomer | eff) Unit
clickLi li event = do
    doc <- document globalWindow
    parent <- parentElement li >>= getAttribute "id"
    let other = if parent == "available" then "program" else "available"
    withElementById other doc (flip appendChild li)

    render

appendLiElement :: forall eff. HTMLElement -> String -> TransformerRecord -> Eff (dom :: DOM | eff) Unit
appendLiElement ul id t = do
    doc <- document globalWindow
    li <- createElement doc "li"
    setAttribute "id" id li
    setInnerHTML (replaceColors t.name) li
    appendChild ul li

-- | Set up or reset the whole UI
resetUI :: forall eff. Eff (dom :: DOM | eff) Unit
resetUI = do
    doc <- document globalWindow
    withElementById "available" doc $ \ulAvailable -> do
        -- create li elements for transformers
        _ <- SM.foldM (\z -> appendLiElement ulAvailable) unit chapter.transformers

        -- set up mouse event handlers
        items <- children ulAvailable
        traverse_ (\li -> addMouseEventListener MouseClickEvent (clickLi li) li) items

    withElementById "program" doc (setInnerHTML "")

-- TODO
chapter = case (head allChapters) of Just c -> c
level = case (getLevelById "1") of Just level -> level

-- | Initial game state for first-time visitors
initialGS :: GameState
initialGS = { currentLevel: "1", levelState: SM.empty }

main = do
    doc <- document globalWindow

    -- install sortable
    Just ulAvailable <- getElementById "available" doc
    Just ulProgram   <- getElementById "program" doc
    installSortable ulAvailable (return unit)
    installSortable ulProgram render

    -- set up keyboard event handlers
    addKeyboardEventListener KeydownEvent keyPress globalWindow

    -- render initial state
    resetUI
    render