Add support for declarationType

Add support for declarationType

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
  "typeSynonym" -> 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 -> "typeSynonym"
  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)

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
))
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"
    -- 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 })
    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))


Clean up Biodalliance module

Clean up Biodalliance module

module Genetics.Browser.Biodalliance where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Types (BD, BDFeature, Biodalliance, Cytoscape)
import Genetics.Browser.Units (class HCoordinate, Bp(..), bp)

-- addFeatureListener(callback)

-- Called when the user clicks on a feature. Parameters passed to the callback are:
-- event: the DOM MouseEvent which triggered this callback.
-- feature: the feature which the user clicked on.
-- hit: an array of Feature and Group objects representing the clicked feature plus any parents.
-- tier: the Dalliance tier in which the click occurred.

-- for now we only send the feature
foreign import addFeatureListener :: ∀ eff.
                                     Biodalliance
                                  -> (forall eff2. BDFeature -> Eff eff2 Unit)
                                  -> Eff (bd :: BD | eff) Unit

foreign import addInitListener :: forall eff a.
                                  Biodalliance
                               -> Eff (bd :: BD | eff) a
                               -> Eff (bd :: BD | eff) Unit

onInit :: forall eff a. Biodalliance -> Eff (bd :: BD | eff) a -> Eff (bd :: BD | eff) Unit
onInit bd cb = addInitListener bd cb

foreign import setLocationImpl :: ∀ eff.
                                  Biodalliance
                               -> String -> Bp -> Bp
                               -> Eff (bd :: BD | eff) Unit

setLocation :: ∀ c eff. HCoordinate c =>
               Biodalliance
            -> String -> c -> c
            -> Eff (bd :: BD | eff) Unit
setLocation bd chr xl xr = setLocationImpl bd chr (bp xl) (bp xr)

foreign import scrollViewImpl :: ∀ eff.
                                 Biodalliance
                              -> Bp
                              -> Eff (bd :: BD | eff) Unit

scrollView :: ∀ c eff. HCoordinate c =>
              Biodalliance
           -> c
           -> Eff (bd :: BD | eff) Unit
scrollView bd = scrollViewImpl bd <<< bp

module Genetics.Browser.Biodalliance where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Genetics.Browser.Cytoscape (cyFilterByString, elData, evtTarget, onClick)
import Genetics.Browser.Feature (Feature(..))
import Genetics.Browser.Types (BD, BDFeature, Biodalliance, Cytoscape)
import Genetics.Browser.Units (class HCoordinate, Bp(..), bp)

-- addFeatureListener(callback)

-- Called when the user clicks on a feature. Parameters passed to the callback are:
-- event: the DOM MouseEvent which triggered this callback.
-- feature: the feature which the user clicked on.
-- hit: an array of Feature and Group objects representing the clicked feature plus any parents.
-- tier: the Dalliance tier in which the click occurred.

-- for now we only send the feature
foreign import addFeatureListener :: ∀ eff.
                                     Biodalliance
                                  -> (forall eff2. BDFeature -> Eff eff2 Unit)
                                  -> Eff (bd :: BD | eff) Unit

foreign import addInitListener :: forall eff a.
                                  Biodalliance
                               -> Eff (bd :: BD | eff) a
                               -> Eff (bd :: BD | eff) Unit

onInit :: forall eff a. Biodalliance -> Eff (bd :: BD | eff) a -> Eff (bd :: BD | eff) Unit
onInit bd cb = addInitListener bd cb

foreign import setLocationImpl :: ∀ eff.
                                  Biodalliance
                               -> String -> Bp -> Bp
                               -> Eff (bd :: BD | eff) Unit

setLocation :: ∀ c eff. HCoordinate c =>
               Biodalliance
            -> String -> c -> c
            -> Eff (bd :: BD | eff) Unit
setLocation bd chr xl xr = setLocationImpl bd chr (bp xl) (bp xr)

foreign import scrollViewImpl :: ∀ eff.
                                 Biodalliance
                              -> Bp
                              -> Eff (bd :: BD | eff) Unit

scrollView :: ∀ c eff. HCoordinate c =>
              Biodalliance
           -> c
           -> Eff (bd :: BD | eff) Unit
scrollView bd = scrollViewImpl bd <<< bp

-- TODO: pretty bad, assumes Bp, etc.
foreign import parseBDFeaturePos :: BDFeature -> { chr :: String
                                                 , min :: Bp
                                                 , max :: Bp
                                                 }

feature' { chr, min, max} = Feature chr min max unit

addCyCallback :: _
addCyCallback bd cy = onClick cy $ \evt -> case elData (evtTarget evt) of
        Nothing -> pure unit
        Just { chr, pos } -> setLocation bd chr ((bp pos) - (Bp 1000000.0)) ((bp pos) + (Bp 1000000.0))


Only create cy.js graph if configured to (hacky)

module Genetics.Browser.UI.Container
       where

import Prelude
import Genetics.Browser.Renderer.GWAS as GWAS
import Genetics.Browser.Renderer.Lineplot as QTL
import Genetics.Browser.UI.Biodalliance as UIBD
import Genetics.Browser.UI.Cytoscape as UICy
import Halogen as H
import Halogen.Aff as HA
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array)
import Data.Array (filter, foldr, (:), null)
import Data.Const (Const)
import Data.Either (Either(..), isLeft, isRight)
import Data.Either.Nested (Either2)
import Data.Foldable (fold, foldMap, foldl)
import Data.Functor.Coproduct.Nested (type (<\/>))
import Data.Lens ((^?))
import Data.Maybe (Maybe(..), isJust, isNothing, maybe)
import Data.Monoid (mempty)
import Data.Newtype (wrap)
import Data.Options (Options(..), (:=))
import Genetics.Browser.Biodalliance (BrowserConstructor, RenderWrapper, RendererInfo, initBD, renderers, sources)
import Genetics.Browser.Config (BrowserConfig(..))
import Genetics.Browser.Config.Track (BDTrackConfig, CyGraphConfig, makeBDTrack, validateBDConfig, validateCyConfig)
import Genetics.Browser.Events (JsonEvent(..))
import Genetics.Browser.Renderer.Lineplot (LinePlotConfig)
import Genetics.Browser.Types (Biodalliance, Renderer)
import Genetics.Browser.Units (Bp(..), Chr(..))
import Global.Unsafe (unsafeStringify)
import Halogen.VDom.Driver (runUI)
import Partial (crash)
import Partial.Unsafe (unsafeCrashWith)

qtlGlyphify :: LinePlotConfig -> Renderer
qtlGlyphify = QTL.render

gwasGlyphify :: Renderer
gwasGlyphify = GWAS.render

data Track = BDTrack | CyTrack

type State = Unit

data Query a
  = Nop a
  | CreateBD (∀ eff. HTMLElement -> Eff eff Biodalliance) a
  | BDScroll Bp a
  | BDJump Chr Bp Bp a
  | CreateCy String a
  | ResetCy a
  | DistEvent Track JsonEvent a

type ChildSlot = Either2 UIBD.Slot UICy.Slot

type ChildQuery = UIBD.Query <\/> UICy.Query <\/> Const Void

type Effects eff = UIBD.Effects (UICy.Effects eff)

component :: ∀ eff. H.Component HH.HTML Query Unit Void (Aff (Effects eff))
component =
  H.parentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  initialState :: State
  initialState = unit

  -- #svgHolder {
  --     width: 100%,
  --     float: left;
  -- }
  -- #cyHolder {
  --     width: 100%;
  --     height: 300px;
  --     float: left;
  --     display: block;
  -- }

  render :: State -> H.ParentHTML Query ChildQuery ChildSlot (Aff (Effects eff))
  render state =
    HH.div_
      [ HH.div_
        [ HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp (-1000000.0))))
          ]
          [ HH.text "Scroll left 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp 1000000.0)))
          ]
          [ HH.text "Scroll right 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ ResetCy)
          ]
          [ HH.text "Reset cytoscape" ]
          -- these divs are used to control the sizes of the subcomponents without having to query the children
        , HH.div
            [] [HH.slot' CP.cp1 UIBD.Slot UIBD.component unit handleBDMessage]
        , HH.div
            [] [HH.slot' CP.cp2 UICy.Slot UICy.component unit handleCyMessage]
        ]
      -- , HH.div
      --     [
      --       -- fix stylesheet - should be on the right hand side, not too wide...
      --     ]
      --     [
      --     ]
      ]

  addCyGraph :: Maybe CyGraphConfig -> _
  addCyGraph = case _ of
    Nothing -> []
    Just cy -> [HH.div [] [HH.slot' CP.cp2 UICy.Slot UICy.component unit handleCyMessage]]

  handleBDMessage :: UIBD.Message -> Maybe (Query Unit)
  handleBDMessage UIBD.Initialized = Just $ ResetCy unit
  handleBDMessage (UIBD.SendEvent obj) = Just $ DistEvent BDTrack obj unit

     -- TODO the event source track should be handled automatically somehow
  handleCyMessage :: UICy.Output -> Maybe (Query Unit)
  handleCyMessage (UICy.SendEvent ev) = Just $ DistEvent CyTrack ev unit

  eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Void (Aff (Effects eff))
  eval = case _ of
    Nop next -> do
      pure next

    CreateBD bd next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Initialize bd)
      pure next
    BDScroll dist next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Scroll dist)
      pure next
    BDJump chr xl xr next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Jump chr xl xr)
      pure next

    CreateCy div next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action (UICy.Initialize div)
      pure next
    ResetCy next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action UICy.Reset
      pure next

    DistEvent from ev next -> do
      liftEff $ log "container is distributing event:"
      liftEff $ log $ unsafeStringify ev

      _ <- case from of
        BDTrack ->
          H.query' CP.cp2 UICy.Slot $ H.action (UICy.RecvEvent ev)
        CyTrack ->
          H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.RecvEvent ev)

      pure next

qtlRenderer :: RendererInfo
qtlRenderer = { name: "qtlRenderer"
              , renderer: qtlGlyphify { minScore: 4.0
                                      , maxScore: 6.0
                                      , color: "#ff0000"
                                      }
              , canvasHeight: 200.0
              }

gwasRenderer :: RendererInfo
gwasRenderer = { name: "gwasRenderer"
               , renderer: gwasGlyphify
               , canvasHeight: 300.0
               }

bdOpts :: Options Biodalliance
bdOpts = renderers := [ qtlRenderer, gwasRenderer ]

main :: BrowserConfig -> Eff _ Unit
main (BrowserConfig { wrapRenderer, browser, tracks }) = HA.runHalogenAff do
  when (isNothing $ tracks ^? _Array) $ liftEff $ log "Tracks config is not an array"

  let validated = maybe [] (map validateBDConfig) $ tracks ^? _Array
      validatedCy = maybe [] (map validateCyConfig) $ tracks ^? _Array

      {errors, tracks} = foldr (\c {errors, tracks} ->
                                 case c of Left  e -> {errors: (e : errors), tracks}
                                           Right t -> {errors, tracks: (t : tracks)}
                               ) { errors: [], tracks: [] } validated

      opts' = bdOpts <> sources := tracks

  liftEff $ log $ "Track errors: " <> foldMap ((<>) ", ") errors

  let mkBd :: (∀ eff. HTMLElement -> Eff eff Biodalliance)
      mkBd = initBD opts' wrapRenderer browser

  liftEff $ log "running main"
  HA.awaitLoad
  el <- HA.selectElement (wrap "#psgbHolder")
  case el of
    Nothing -> do
      liftEff $ log "no element for browser!"
    Just el' -> do
      io <- runUI component unit el'
      liftEff $ log "creating BD"
      io.query $ H.action (CreateBD mkBd)
      liftEff $ log "created BD!"
      liftEff $ log $ "cytoscape enabled: " <> show (not null validatedCy)
      when (not null validatedCy) $ do
        liftEff $ log "creating Cy.js"
        io.query $ H.action (CreateCy "http://localhost:8080/eles.json")
        liftEff $ log "created cy!"

module Genetics.Browser.UI.Container
       where

import Prelude
import Genetics.Browser.Renderer.GWAS as GWAS
import Genetics.Browser.Renderer.Lineplot as QTL
import Genetics.Browser.UI.Biodalliance as UIBD
import Genetics.Browser.UI.Cytoscape as UICy
import Halogen as H
import Halogen.Aff as HA
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (Json, _Array)
import Data.Array (filter, foldr, (:))
import Data.Const (Const)
import Data.Either (Either(..), isLeft, isRight)
import Data.Either.Nested (Either2)
import Data.Foldable (fold, foldMap, foldl)
import Data.Functor.Coproduct.Nested (type (<\/>))
import Data.Lens ((^?))
import Data.Maybe (Maybe(..), isJust, isNothing, maybe)
import Data.Newtype (wrap)
import Data.Options (Options(..), (:=))
import Genetics.Browser.Biodalliance (BrowserConstructor, RenderWrapper, RendererInfo, initBD, renderers, sources)
import Genetics.Browser.Config (BrowserConfig(..))
import Genetics.Browser.Config.Track (BDTrackConfig(..), makeBDTrack, validateBDConfig)
import Genetics.Browser.Events (JsonEvent(..))
import Genetics.Browser.Renderer.Lineplot (LinePlotConfig)
import Genetics.Browser.Types (Biodalliance, Renderer)
import Genetics.Browser.Units (Bp(..), Chr(..))
import Global.Unsafe (unsafeStringify)
import Halogen.VDom.Driver (runUI)
import Partial (crash)
import Partial.Unsafe (unsafeCrashWith)

qtlGlyphify :: LinePlotConfig -> Renderer
qtlGlyphify = QTL.render

gwasGlyphify :: Renderer
gwasGlyphify = GWAS.render

data Track = BDTrack | CyTrack

type State = Unit

data Query a
  = Nop a
  | CreateBD (∀ eff. HTMLElement -> Eff eff Biodalliance) a
  | BDScroll Bp a
  | BDJump Chr Bp Bp a
  | CreateCy String a
  | ResetCy a
  | DistEvent Track JsonEvent a

type ChildSlot = Either2 UIBD.Slot UICy.Slot

type ChildQuery = UIBD.Query <\/> UICy.Query <\/> Const Void

type Effects eff = UIBD.Effects (UICy.Effects eff)

component :: ∀ eff. H.Component HH.HTML Query Unit Void (Aff (Effects eff))
component =
  H.parentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  initialState :: State
  initialState = unit

  -- #svgHolder {
  --     width: 100%,
  --     float: left;
  -- }
  -- #cyHolder {
  --     width: 100%;
  --     height: 300px;
  --     float: left;
  --     display: block;
  -- }

  render :: State -> H.ParentHTML Query ChildQuery ChildSlot (Aff (Effects eff))
  render state =
    HH.div_
      [ HH.div_
        [ HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp (-1000000.0))))
          ]
          [ HH.text "Scroll left 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp 1000000.0)))
          ]
          [ HH.text "Scroll right 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ ResetCy)
          ]
          [ HH.text "Reset cytoscape" ]
          -- these divs are used to control the sizes of the subcomponents without having to query the children
        , HH.div
            [] [HH.slot' CP.cp1 UIBD.Slot UIBD.component unit handleBDMessage]
        , HH.div
            [] [HH.slot' CP.cp2 UICy.Slot UICy.component unit handleCyMessage]
        ]
      -- , HH.div
      --     [
      --       -- fix stylesheet - should be on the right hand side, not too wide...
      --     ]
      --     [
      --     ]
      ]

  handleBDMessage :: UIBD.Message -> Maybe (Query Unit)
  handleBDMessage UIBD.Initialized = Just $ ResetCy unit
  handleBDMessage (UIBD.SendEvent obj) = Just $ DistEvent BDTrack obj unit

     -- TODO the event source track should be handled automatically somehow
  handleCyMessage :: UICy.Output -> Maybe (Query Unit)
  handleCyMessage (UICy.SendEvent ev) = Just $ DistEvent CyTrack ev unit

  eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Void (Aff (Effects eff))
  eval = case _ of
    Nop next -> do
      pure next

    CreateBD bd next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Initialize bd)
      pure next
    BDScroll dist next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Scroll dist)
      pure next
    BDJump chr xl xr next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Jump chr xl xr)
      pure next

    CreateCy div next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action (UICy.Initialize div)
      pure next
    ResetCy next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action UICy.Reset
      pure next

    DistEvent from ev next -> do
      liftEff $ log "container is distributing event:"
      liftEff $ log $ unsafeStringify ev

      _ <- case from of
        BDTrack ->
          H.query' CP.cp2 UICy.Slot $ H.action (UICy.RecvEvent ev)
        CyTrack ->
          H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.RecvEvent ev)

      pure next

qtlRenderer :: RendererInfo
qtlRenderer = { name: "qtlRenderer"
              , renderer: qtlGlyphify { minScore: 4.0
                                      , maxScore: 6.0
                                      , color: "#ff0000"
                                      }
              , canvasHeight: 200.0
              }

gwasRenderer :: RendererInfo
gwasRenderer = { name: "gwasRenderer"
               , renderer: gwasGlyphify
               , canvasHeight: 300.0
               }

bdOpts :: Options Biodalliance
bdOpts = renderers := [ qtlRenderer, gwasRenderer ]

main :: BrowserConfig -> Eff _ Unit
main (BrowserConfig { wrapRenderer, browser, tracks }) = HA.runHalogenAff do
  when (isNothing $ tracks ^? _Array) $ liftEff $ log "Tracks config is not an array"

  let validated = maybe [] (map validateBDConfig) $ tracks ^? _Array

      {errors, tracks} = foldr (\c {errors, tracks} ->
                                 case c of Left  e -> {errors: (e : errors), tracks}
                                           Right t -> {errors, tracks: (t : tracks)}
                               ) { errors: [], tracks: [] } validated

      opts' = bdOpts <> sources := tracks

  liftEff $ log $ "Track errors: " <> foldMap ((<>) ", ") errors

  let mkBd :: (∀ eff. HTMLElement -> Eff eff Biodalliance)
      mkBd = initBD opts' wrapRenderer browser

  liftEff $ log "running main"
  HA.awaitLoad
  el <- HA.selectElement (wrap "#psgbHolder")
  case el of
    Nothing -> do
      liftEff $ log "no element for browser!"
    Just el' -> do
      io <- runUI component unit el'
      liftEff $ log "creating BD"
      io.query $ H.action (CreateBD mkBd)
      liftEff $ log "created BD!"
      liftEff $ log "creating Cy.js"
      io.query $ H.action (CreateCy "http://localhost:8080/eles.json")
      liftEff $ log "created cy!"


memoize graph rendering

memoize graph rendering

module App.View where

import Prelude

import App.Background.View (fillBackground)
import App.Background.View (view) as BackgroundView
import App.ColorScheme (ColorScheme, toColor)
import App.Cycle (Cycle(..))
import App.Events (Event(..))
import App.Geometry (Point(Point), Stroke(Arc, Line), distance, firstPoint, ptX, ptY, secondPoint, sweep)
import App.Graph (Graph(..), edges)
import App.State (State, Tool(..))
import App.Tool.View (view) as ToolView
import CSS.Color (toHexString)
import CSS.Geometry (height, width)
import CSS.Size (px)
import Control.Monad.Except (runExcept)
import DOM.Event.MouseEvent (clientX, clientY, eventToMouseEvent)
import Data.Either (either)
import Data.Foldable (elem, for_)
import Data.Function.Uncurried (runFn2)
import Data.Int (toNumber)
import Data.List (List, foldl, (:))
import Data.Map (Map, toUnfoldable)
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty)
import Data.Tuple (Tuple(..))
import Math (abs, pi)
import Pux.DOM.Events (DOMEvent, onClick, onMouseDown, onMouseMove, onMouseUp)
import Pux.DOM.HTML (HTML, memoize)
import Pux.DOM.HTML.Attributes (style)
import Text.Smolder.HTML (div)
import Text.Smolder.HTML.Attributes (className)
import Text.Smolder.Markup (Attribute, (!), (#!))
import Text.Smolder.SVG (circle, g, line, path, svg)
import Text.Smolder.SVG.Attributes (cx, cy, d, fill, r, stroke, strokeDasharray, x1, x2, y1, y2)

drawLine :: Attribute -> Point -> Point -> HTML Event
drawLine strokeStyle (Point px1 py1) (Point px2 py2) =
  line ! (x1 $ show px1)
       ! (y1 $ show py1)
       ! (x2 $ show px2)
       ! (y2 $ show py2)
       ! strokeStyle

drawStroke :: Attribute -> Stroke -> HTML Event
drawStroke strokeStyle s =
  let command = (mCmdString $ firstPoint s) <> (lCmdString s)
   in path ! strokeStyle ! (d command) $ pure unit

drawStrokes :: Graph -> HTML Event
drawStrokes = memoize \graph ->
  let
      strokeStyle :: Attribute
      strokeStyle = stroke "black" <> fill "transparent" <> className "stroke"
   in g ! className "strokes" $ for_ (edges graph) (drawStroke strokeStyle)

pathAttrs :: List Stroke -> Attribute
pathAttrs strokes@(s1 : _) =
  let p = firstPoint s1
   in d (foldl append (mCmdString p) (lCmdString <$> strokes))

pathAttrs _ = mempty

mCmdString :: Point -> String
mCmdString (Point x y) = "M " <> (show $ x) <> " " <> (show $ y) <> " "

lCmdString :: Stroke -> String
lCmdString (Line _ (Point x2 y2)) = "L " <> show x2 <> " " <> show y2 <> " "
lCmdString arc@(Arc c p q ccw) =
  if p == q then let halfPoint = c + c - p
                  in arcCmdString (Arc c p halfPoint ccw) <> arcCmdString (Arc c halfPoint q ccw)
            else arcCmdString arc

arcCmdString :: Stroke -> String
arcCmdString arc@(Arc c p q ccw) =
  let endPoint = secondPoint arc
      r = runFn2 distance c p
      s = sweep arc
   in "A "
      <> show r <> " " -- rx
      <> show r -- ry
      <> " 0 " -- x-axis-rotation
      <> show (if abs s > pi then 1 else 0) -- large sweep flag (sweep > 180 degrees)
      <> " "
      <> show (if ccw then 1 else 0) -- sweep flag (sweep starts positive or negative)
      <> " "
      <> show (ptX endPoint) <> " "
      <> show (ptY endPoint) <> " "

arcCmdString _ = ""

drawCycle :: Tool -> Tuple Cycle ColorScheme -> HTML Event
drawCycle tool (Tuple cycle@(Cycle strokes) colorScheme) =
  let
    handler = case tool of
                ColorTool newColorScheme -> onClick $ \_ -> Color cycle newColorScheme
                _ -> onClick (const $ NoOp)
  in path ! pathAttrs strokes ! stroke "black" ! (fill $ toHexString $ toColor colorScheme) #! handler $ pure unit

mapToList :: forall k v. Map k v -> List (Tuple k v)
mapToList = toUnfoldable

drawCycles :: Tool -> Map Cycle ColorScheme -> HTML Event
drawCycles tool cycles =
  g ! className "cycles" $ for_ (mapToList cycles) (drawCycle tool)

drawPoint :: Point -> Number -> HTML Event
drawPoint (Point x y) size =
  circle ! (cx $ show x)
         ! (cy $ show y)
         ! (r $ show size)

drawSnapPoint :: Maybe Point -> HTML Event
drawSnapPoint Nothing = g $ pure unit
drawSnapPoint (Just p) = drawPoint p 3.0

currentStrokeAttrs:: Attribute
currentStrokeAttrs = stroke "black" <> strokeDasharray "5 5" <> fill "transparent"

drawCurrentStroke :: Maybe Stroke -> HTML Event
drawCurrentStroke Nothing = g $ pure unit
drawCurrentStroke (Just s) =
  drawStroke currentStrokeAttrs s

readPageXY :: DOMEvent -> {clientX:: Number, clientY:: Number}
readPageXY ev =
  let readXY mouseEv = {clientX: toNumber $ clientX mouseEv, clientY: toNumber $ clientY mouseEv}
   in either (const {clientX: 0.0, clientY: 0.0}) readXY $ runExcept $ eventToMouseEvent ev

withListeners :: Tool -> HTML Event -> HTML Event
withListeners tool html =
  case tool of _ | elem tool [LineTool, ArcTool] -> html #! (onClick (readPageXY >>> \{clientX, clientY} -> Click (Point clientX clientY)))
                                                         #! (onMouseMove (readPageXY >>> \{clientX, clientY} -> Move (Point clientX clientY)))
               EraserTool -> html #! (onMouseDown $ readPageXY >>> \{clientX, clientY} -> EraserDown (Point clientX clientY))
                                  #! (onMouseUp $ readPageXY >>> \{clientX, clientY} -> EraserUp (Point clientX clientY))
                                  #! (onMouseMove $ readPageXY >>> \{clientX, clientY} -> EraserMove (Point clientX clientY))
               _ -> html

drawing :: State -> HTML Event
drawing state =
  withListeners state.tool $
  svg ! style do
          width $ (toNumber state.windowWidth) # px
          height $ (toNumber state.windowHeight) # px
      $ do
        fillBackground state.background state.windowWidth state.windowHeight
        drawStrokes state.graph
        drawCycles state.tool state.cycles
        drawSnapPoint state.snapPoint
        drawCurrentStroke state.currentStroke

view :: State -> HTML Event
view state =
  div $ do
    BackgroundView.view state.background
    ToolView.view state.tool
    drawing state

module App.View where

import Prelude

import App.Background.View (fillBackground)
import App.Background.View (view) as BackgroundView
import App.ColorScheme (ColorScheme, toColor)
import App.Cycle (Cycle(..))
import App.Events (Event(..))
import App.Geometry (Point(Point), Stroke(Arc, Line), distance, firstPoint, ptX, ptY, secondPoint, sweep)
import App.Graph (edges)
import App.State (State, Tool(..))
import App.Tool.View (view) as ToolView
import CSS.Color (toHexString)
import CSS.Geometry (height, width)
import CSS.Size (px)
import Control.Monad.Except (runExcept)
import DOM.Event.MouseEvent (clientX, clientY, eventToMouseEvent)
import Data.Either (either)
import Data.Foldable (elem, for_)
import Data.Function.Uncurried (runFn2)
import Data.Int (toNumber)
import Data.List (List, foldl, (:))
import Data.Map (Map, toUnfoldable)
import Data.Maybe (Maybe(..))
import Data.Monoid (mempty)
import Data.Tuple (Tuple(..))
import Math (abs, pi)
import Pux.DOM.Events (DOMEvent, onClick, onMouseDown, onMouseMove, onMouseUp)
import Pux.DOM.HTML (HTML)
import Pux.DOM.HTML.Attributes (style)
import Text.Smolder.HTML (div)
import Text.Smolder.HTML.Attributes (className)
import Text.Smolder.Markup (Attribute, (!), (#!))
import Text.Smolder.SVG (circle, g, line, path, svg)
import Text.Smolder.SVG.Attributes (cx, cy, d, fill, r, stroke, strokeDasharray, x1, x2, y1, y2)

drawLine :: Attribute -> Point -> Point -> HTML Event
drawLine strokeStyle (Point px1 py1) (Point px2 py2) =
  line ! (x1 $ show px1)
       ! (y1 $ show py1)
       ! (x2 $ show px2)
       ! (y2 $ show py2)
       ! strokeStyle

drawStroke :: Attribute -> Stroke -> HTML Event
drawStroke strokeStyle s =
  let command = (mCmdString $ firstPoint s) <> (lCmdString s)
   in path ! strokeStyle ! (d command) $ pure unit

drawStrokes :: List Stroke -> HTML Event
drawStrokes strokes =
  let
      strokeStyle :: Attribute
      strokeStyle = stroke "black" <> fill "transparent" <> className "stroke"
   in g ! className "strokes" $ for_ strokes (drawStroke strokeStyle)

pathAttrs :: List Stroke -> Attribute
pathAttrs strokes@(s1 : _) =
  let p = firstPoint s1
   in d (foldl append (mCmdString p) (lCmdString <$> strokes))

pathAttrs _ = mempty

mCmdString :: Point -> String
mCmdString (Point x y) = "M " <> (show $ x) <> " " <> (show $ y) <> " "

lCmdString :: Stroke -> String
lCmdString (Line _ (Point x2 y2)) = "L " <> show x2 <> " " <> show y2 <> " "
lCmdString arc@(Arc c p q ccw) =
  if p == q then let halfPoint = c + c - p
                  in arcCmdString (Arc c p halfPoint ccw) <> arcCmdString (Arc c halfPoint q ccw)
            else arcCmdString arc

arcCmdString :: Stroke -> String
arcCmdString arc@(Arc c p q ccw) =
  let endPoint = secondPoint arc
      r = runFn2 distance c p
      s = sweep arc
   in "A "
      <> show r <> " " -- rx
      <> show r -- ry
      <> " 0 " -- x-axis-rotation
      <> show (if abs s > pi then 1 else 0) -- large sweep flag (sweep > 180 degrees)
      <> " "
      <> show (if ccw then 1 else 0) -- sweep flag (sweep starts positive or negative)
      <> " "
      <> show (ptX endPoint) <> " "
      <> show (ptY endPoint) <> " "

arcCmdString _ = ""

drawCycle :: Tool -> Tuple Cycle ColorScheme -> HTML Event
drawCycle tool (Tuple cycle@(Cycle strokes) colorScheme) =
  let
    handler = case tool of
                ColorTool newColorScheme -> onClick $ \_ -> Color cycle newColorScheme
                _ -> onClick (const $ NoOp)
  in path ! pathAttrs strokes ! stroke "black" ! (fill $ toHexString $ toColor colorScheme) #! handler $ pure unit

mapToList :: forall k v. Map k v -> List (Tuple k v)
mapToList = toUnfoldable

drawCycles :: Tool -> Map Cycle ColorScheme -> HTML Event
drawCycles tool cycles =
  g ! className "cycles" $ for_ (mapToList cycles) (drawCycle tool)

drawPoint :: Point -> Number -> HTML Event
drawPoint (Point x y) size =
  circle ! (cx $ show x)
         ! (cy $ show y)
         ! (r $ show size)

drawSnapPoint :: Maybe Point -> HTML Event
drawSnapPoint Nothing = g $ pure unit
drawSnapPoint (Just p) = drawPoint p 3.0

currentStrokeAttrs:: Attribute
currentStrokeAttrs = stroke "black" <> strokeDasharray "5 5" <> fill "transparent"

drawCurrentStroke :: Maybe Stroke -> HTML Event
drawCurrentStroke Nothing = g $ pure unit
drawCurrentStroke (Just s) =
  drawStroke currentStrokeAttrs s

readPageXY :: DOMEvent -> {clientX:: Number, clientY:: Number}
readPageXY ev =
  let readXY mouseEv = {clientX: toNumber $ clientX mouseEv, clientY: toNumber $ clientY mouseEv}
   in either (const {clientX: 0.0, clientY: 0.0}) readXY $ runExcept $ eventToMouseEvent ev

withListeners :: Tool -> HTML Event -> HTML Event
withListeners tool html =
  case tool of _ | elem tool [LineTool, ArcTool] -> html #! (onClick (readPageXY >>> \{clientX, clientY} -> Click (Point clientX clientY)))
                                                         #! (onMouseMove (readPageXY >>> \{clientX, clientY} -> Move (Point clientX clientY)))
               EraserTool -> html #! (onMouseDown $ readPageXY >>> \{clientX, clientY} -> EraserDown (Point clientX clientY))
                                  #! (onMouseUp $ readPageXY >>> \{clientX, clientY} -> EraserUp (Point clientX clientY))
                                  #! (onMouseMove $ readPageXY >>> \{clientX, clientY} -> EraserMove (Point clientX clientY))
               _ -> html

drawing :: State -> HTML Event
drawing state =
  withListeners state.tool $
  svg ! style do
          width $ (toNumber state.windowWidth) # px
          height $ (toNumber state.windowHeight) # px
      $ do
        fillBackground state.background state.windowWidth state.windowHeight
        drawStrokes (edges state.graph)
        drawCycles state.tool state.cycles
        drawSnapPoint state.snapPoint
        drawCurrentStroke state.currentStroke

view :: State -> HTML Event
view state =
  div $ do
    BackgroundView.view state.background
    ToolView.view state.tool
    drawing state


Add base36

Add base36

Fix #21.

module Data.Int
  ( fromNumber
  , ceil
  , floor
  , round
  , toNumber
  , fromString
  , Radix()
  , radix
  , binary
  , octal
  , decimal
  , hexadecimal
  , base36
  , fromStringAs
  , toStringAs
  , even
  , odd
  ) where

import Data.Boolean (otherwise)
import Data.BooleanAlgebra ((&&))
import Data.Bounded (top, bottom)
import Data.Eq ((==), (/=))
import Data.Function ((<<<))
import Data.Int.Bits ((.&.))
import Data.Maybe (Maybe(..), fromJust)
import Data.Ord ((<=), (>=))

import Math as Math

import Partial.Unsafe (unsafePartial)

-- | Creates an `Int` from a `Number` value. The number must already be an
-- | integer and fall within the valid range of values for the `Int` type
-- | otherwise `Nothing` is returned.
fromNumber :: Number -> Maybe Int
fromNumber = fromNumberImpl Just Nothing

foreign import fromNumberImpl
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Number
  -> Maybe Int

-- | Convert a `Number` to an `Int`, by taking the closest integer equal to or
-- | less than the argument. Values outside the `Int` range are clamped.
floor :: Number -> Int
floor = unsafeClamp <<< Math.floor

-- | Convert a `Number` to an `Int`, by taking the closest integer equal to or
-- | greater than the argument. Values outside the `Int` range are clamped.
ceil :: Number -> Int
ceil = unsafeClamp <<< Math.ceil

-- | Convert a `Number` to an `Int`, by taking the nearest integer to the
-- | argument. Values outside the `Int` range are clamped.
round :: Number -> Int
round = unsafeClamp <<< Math.round

-- | Convert an integral `Number` to an `Int`, by clamping to the `Int` range.
-- | This function will throw an error at runtime if the argument is
-- | non-integral.
unsafeClamp :: Number -> Int
unsafeClamp x
  | x >= toNumber top = top
  | x <= toNumber bottom = bottom
  | otherwise = unsafePartial (fromJust (fromNumber x))

-- | Converts an `Int` value back into a `Number`. Any `Int` is a valid `Number`
-- | so there is no loss of precision with this function.
foreign import toNumber :: Int -> Number

-- | Reads an `Int` from a `String` value. The number must parse as an integer
-- | and fall within the valid range of values for the `Int` type, otherwise
-- | `Nothing` is returned.
fromString :: String -> Maybe Int
fromString = fromStringAs (Radix 10)

-- | Returns whether an `Int` is an even number.
-- |
-- | ``` purescript
-- | even 0 == true
-- | even 1 == false
-- | ```
even :: Int -> Boolean
even x = x .&. 1 == 0

-- | The negation of `even`.
-- |
-- | ``` purescript
-- | odd 0 == false
-- | odd 1 == false
-- | ```
odd :: Int -> Boolean
odd x = x .&. 1 /= 0

-- | The number of unique digits (including zero) used to represent integers in
-- | a specific base.
newtype Radix = Radix Int

-- | The base-2 system.
binary :: Radix
binary = Radix 2

-- | The base-8 system.
octal :: Radix
octal = Radix 8

-- | The base-10 system.
decimal :: Radix
decimal = Radix 10

-- | The base-16 system.
hexadecimal :: Radix
hexadecimal = Radix 16

-- | The base-36 system.
base36 :: Radix
base36 = Radix 36

-- | Create a `Radix` from a number between 2 and 36.
radix :: Int -> Maybe Radix
radix n | n >= 2 && n <= 36 = Just (Radix n)
        | otherwise         = Nothing

-- | Like `fromString`, but the integer can be specified in a different base.
-- |
-- | Example:
-- | ``` purs
-- | fromStringAs binary      "100" == Just 4
-- | fromStringAs hexadecimal "ff"  == Just 255
-- | ```
fromStringAs :: Radix -> String -> Maybe Int
fromStringAs = fromStringAsImpl Just Nothing

foreign import fromStringAsImpl
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Radix
  -> String
  -> Maybe Int

foreign import toStringAs :: Radix -> Int -> String

module Data.Int
  ( fromNumber
  , ceil
  , floor
  , round
  , toNumber
  , fromString
  , Radix()
  , radix
  , binary
  , octal
  , decimal
  , hexadecimal
  , fromStringAs
  , toStringAs
  , even
  , odd
  ) where

import Data.Boolean (otherwise)
import Data.BooleanAlgebra ((&&))
import Data.Bounded (top, bottom)
import Data.Eq ((==), (/=))
import Data.Function ((<<<))
import Data.Int.Bits ((.&.))
import Data.Maybe (Maybe(..), fromJust)
import Data.Ord ((<=), (>=))

import Math as Math

import Partial.Unsafe (unsafePartial)

-- | Creates an `Int` from a `Number` value. The number must already be an
-- | integer and fall within the valid range of values for the `Int` type
-- | otherwise `Nothing` is returned.
fromNumber :: Number -> Maybe Int
fromNumber = fromNumberImpl Just Nothing

foreign import fromNumberImpl
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Number
  -> Maybe Int

-- | Convert a `Number` to an `Int`, by taking the closest integer equal to or
-- | less than the argument. Values outside the `Int` range are clamped.
floor :: Number -> Int
floor = unsafeClamp <<< Math.floor

-- | Convert a `Number` to an `Int`, by taking the closest integer equal to or
-- | greater than the argument. Values outside the `Int` range are clamped.
ceil :: Number -> Int
ceil = unsafeClamp <<< Math.ceil

-- | Convert a `Number` to an `Int`, by taking the nearest integer to the
-- | argument. Values outside the `Int` range are clamped.
round :: Number -> Int
round = unsafeClamp <<< Math.round

-- | Convert an integral `Number` to an `Int`, by clamping to the `Int` range.
-- | This function will throw an error at runtime if the argument is
-- | non-integral.
unsafeClamp :: Number -> Int
unsafeClamp x
  | x >= toNumber top = top
  | x <= toNumber bottom = bottom
  | otherwise = unsafePartial (fromJust (fromNumber x))

-- | Converts an `Int` value back into a `Number`. Any `Int` is a valid `Number`
-- | so there is no loss of precision with this function.
foreign import toNumber :: Int -> Number

-- | Reads an `Int` from a `String` value. The number must parse as an integer
-- | and fall within the valid range of values for the `Int` type, otherwise
-- | `Nothing` is returned.
fromString :: String -> Maybe Int
fromString = fromStringAs (Radix 10)

-- | Returns whether an `Int` is an even number.
-- |
-- | ``` purescript
-- | even 0 == true
-- | even 1 == false
-- | ```
even :: Int -> Boolean
even x = x .&. 1 == 0

-- | The negation of `even`.
-- |
-- | ``` purescript
-- | odd 0 == false
-- | odd 1 == false
-- | ```
odd :: Int -> Boolean
odd x = x .&. 1 /= 0

-- | The number of unique digits (including zero) used to represent integers in
-- | a specific base.
newtype Radix = Radix Int

-- | The base-2 system.
binary :: Radix
binary = Radix 2

-- | The base-8 system.
octal :: Radix
octal = Radix 8

-- | The base-10 system.
decimal :: Radix
decimal = Radix 10

-- | The base-16 system.
hexadecimal :: Radix
hexadecimal = Radix 16

-- | Create a `Radix` from a number between 2 and 36.
radix :: Int -> Maybe Radix
radix n | n >= 2 && n <= 36 = Just (Radix n)
        | otherwise         = Nothing

-- | Like `fromString`, but the integer can be specified in a different base.
-- |
-- | Example:
-- | ``` purs
-- | fromStringAs binary      "100" == Just 4
-- | fromStringAs hexadecimal "ff"  == Just 255
-- | ```
fromStringAs :: Radix -> String -> Maybe Int
fromStringAs = fromStringAsImpl Just Nothing

foreign import fromStringAsImpl
  :: (forall a. a -> Maybe a)
  -> (forall a. Maybe a)
  -> Radix
  -> String
  -> Maybe Int

foreign import toStringAs :: Radix -> Int -> String


Use NO_ERROR enum in debug interpretation.

-- Free Monad for WebGL
module Graphics.WebGL.Free (
	AttributeLocation(..),
	WebGL(),
	WebGLF(),
	debugWebGL,
	runWebGL,
	attachShader,
	bindBuffer,
	bufferData,
	clear,
	createBuffer,
	clearColor,
	createProgram,
	compileShader,
	createShader,
	depthFunc,
	enable,
	enableVertexAttribArray,
	getAttribLocation,
	getCanvas,
	getDrawingBufferHeight,
	getDrawingBufferWidth,
	getProgramInfoLog,
	getProgramLinkStatus,
	getShaderCompileStatus,
	getShaderInfoLog,
	getUniformLocation,
	linkProgram,
	shaderSource,
	useProgram,
	viewport
	) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.Free
import Data.Maybe
import Graphics.Canvas (Canvas(), CanvasElement())
import qualified Graphics.WebGL.Raw as R
import qualified Graphics.WebGL.Raw.Extra as R
import qualified Graphics.WebGL.Raw.Enums as GL
import Graphics.WebGL.Raw.Types

newtype AttributeLocation = AttributeLocation GLuint

data WebGLF a
	= AttachShader WebGLProgram WebGLShader a
	| BindBuffer GLenum WebGLBuffer a
	| BufferData GLenum BufferDataSource GLenum a
	| Clear GLbitfield a
	| ClearColor GLclampf GLclampf GLclampf GLclampf a
	| CompileShader WebGLShader a
	| CreateBuffer (Maybe WebGLBuffer -> a)
	| CreateProgram (Maybe WebGLProgram -> a)
	| CreateShader GLenum (Maybe WebGLShader -> a)
	| DepthFunc GLenum a
	| Enable GLenum a
	| EnableVertexAttribArray AttributeLocation a
	| GetAttribLocation WebGLProgram DOMString (Maybe AttributeLocation -> a)
	| GetCanvas (CanvasElement -> a)
	| GetDrawingBufferHeight (Int -> a)
	| GetDrawingBufferWidth (Int -> a)
	| GetProgramInfoLog WebGLProgram (Maybe DOMString -> a)
	| GetProgramLinkStatus WebGLProgram (Boolean -> a)
	| GetShaderCompileStatus WebGLShader (Boolean -> a)
	| GetShaderInfoLog WebGLShader (Maybe DOMString -> a)
	| GetUniformLocation WebGLProgram DOMString (Maybe WebGLUniformLocation -> a)
	| LinkProgram WebGLProgram a
	| ShaderSource WebGLShader DOMString a
	| UseProgram WebGLProgram a
	| Viewport GLint GLint GLsizei GLsizei a

instance functorWebGLF :: Functor WebGLF where
	map f (AttachShader p s x) = AttachShader p s (f x)
	map f (BindBuffer t b x) = BindBuffer t b (f x)
	map f (BufferData t s u x) = BufferData t s u (f x)
	map f (Clear mask x) = Clear mask (f x)
	map f (ClearColor r g b a x) = ClearColor r g b a (f x)
	map f (CompileShader s x) = CompileShader s (f x)
	map f (CreateBuffer k) = CreateBuffer (f <<< k)
	map f (CreateProgram k) = CreateProgram (f <<< k)
	map f (CreateShader t k) = CreateShader t (f <<< k)
	map f (DepthFunc func x) = DepthFunc func (f x)
	map f (Enable cap x) = Enable cap (f x)
	map f (EnableVertexAttribArray i x) = EnableVertexAttribArray i (f x)
	map f (GetAttribLocation p s k) = GetAttribLocation p s (f <<< k)
	map f (GetCanvas k) = GetCanvas (f <<< k)
	map f (GetDrawingBufferHeight k) = GetDrawingBufferHeight (f <<< k)
	map f (GetDrawingBufferWidth k) = GetDrawingBufferWidth (f <<< k)
	map f (GetProgramInfoLog s k) = GetProgramInfoLog s (f <<< k)
	map f (GetProgramLinkStatus p k) = GetProgramLinkStatus p (f <<< k)
	map f (GetShaderCompileStatus s k) = GetShaderCompileStatus s (f <<< k)
	map f (GetShaderInfoLog s k) = GetShaderInfoLog s (f <<< k)
	map f (GetUniformLocation p n k) = GetUniformLocation p n (f <<< k)
	map f (LinkProgram p x) = LinkProgram p (f x)
	map f (ShaderSource sh src x) = ShaderSource sh src (f x)
	map f (UseProgram p x) = UseProgram p (f x)
	map f (Viewport x y w h a) = Viewport x y w h (f a)

type WebGL = Free WebGLF

attachShader :: WebGLProgram -> WebGLShader -> WebGL Unit
attachShader p s = liftF $ AttachShader p s unit

bindBuffer :: GLenum -> WebGLBuffer -> WebGL Unit
bindBuffer t b = liftF $ BindBuffer t b unit

bufferData :: GLenum -> BufferDataSource -> GLenum -> WebGL Unit
bufferData t s u = liftF $ BufferData t s u unit

clear :: GLbitfield -> WebGL Unit
clear mask = liftF $ Clear mask unit

clearColor :: GLclampf -> GLclampf -> GLclampf -> GLclampf -> WebGL Unit
clearColor r g b a = liftF $ ClearColor r g b a unit

compileShader :: WebGLShader -> WebGL Unit
compileShader s = liftF $ CompileShader s unit

createBuffer :: WebGL (Maybe WebGLBuffer)
createBuffer = liftF $ CreateBuffer id

createProgram :: WebGL (Maybe WebGLProgram)
createProgram = liftF $ CreateProgram id

createShader :: GLenum -> WebGL (Maybe WebGLShader)
createShader t = liftF $ CreateShader t id

depthFunc :: GLenum -> WebGL Unit
depthFunc func = liftF $ DepthFunc func unit

enable :: GLenum -> WebGL Unit
enable cap = liftF $ Enable cap unit

enableVertexAttribArray :: AttributeLocation -> WebGL Unit
enableVertexAttribArray location = liftF $ EnableVertexAttribArray location unit

getAttribLocation :: WebGLProgram -> DOMString -> WebGL (Maybe AttributeLocation)
getAttribLocation program name = liftF $ GetAttribLocation program name id

getCanvas :: WebGL CanvasElement
getCanvas = liftF $ GetCanvas id

getDrawingBufferHeight :: WebGL Int
getDrawingBufferHeight = liftF $ GetDrawingBufferHeight id

getDrawingBufferWidth :: WebGL Int
getDrawingBufferWidth = liftF $ GetDrawingBufferWidth id

getProgramInfoLog :: WebGLProgram -> WebGL (Maybe DOMString)
getProgramInfoLog p = liftF $ GetProgramInfoLog p id

getProgramLinkStatus :: WebGLProgram -> WebGL Boolean
getProgramLinkStatus p = liftF $ GetProgramLinkStatus p id

getShaderCompileStatus :: WebGLShader -> WebGL Boolean
getShaderCompileStatus s = liftF $ GetShaderCompileStatus s id

getShaderInfoLog :: WebGLShader -> WebGL (Maybe DOMString)
getShaderInfoLog s = liftF $ GetShaderInfoLog s id

getUniformLocation :: WebGLProgram -> DOMString -> WebGL (Maybe WebGLUniformLocation)
getUniformLocation program name = liftF $ GetUniformLocation program name id

linkProgram :: WebGLProgram -> WebGL Unit
linkProgram p = liftF $ LinkProgram p unit

shaderSource :: WebGLShader -> DOMString -> WebGL Unit
shaderSource sh src = liftF $ ShaderSource sh src unit

useProgram :: WebGLProgram -> WebGL Unit
useProgram p = liftF $ UseProgram p unit

viewport :: GLint -> GLint -> GLsizei -> GLsizei -> WebGL Unit
viewport x y w h = liftF $ Viewport x y w h unit

interpretWebGL :: forall a eff. WebGLContext -> WebGLF (WebGL a) -> Eff (canvas :: Canvas | eff) (WebGL a)
interpretWebGL gl (AttachShader p s rest) = do
	R.attachShader gl p s
	return rest
interpretWebGL gl (BindBuffer t buffer rest) = do
	R.bindBuffer gl t buffer
	return rest
interpretWebGL gl (BufferData t source usage rest) = do
	R.bufferData gl t source usage
	return rest
interpretWebGL gl (Clear mask rest) = do
	R.clear gl mask
	return rest
interpretWebGL gl (ClearColor r g b a rest) = do
	R.clearColor gl r g b a
	return rest
interpretWebGL gl (CompileShader sh rest) = do
	R.compileShader gl sh
	return rest
interpretWebGL gl (CreateBuffer k) = do
	buffer <- R.createBuffer gl
	return $ k buffer
interpretWebGL gl (CreateProgram k) = do
	program <- R.createProgram gl
	return $ k program
interpretWebGL gl (CreateShader t k) = do
	shader <- R.createShader gl t
	return $ k shader
interpretWebGL gl (DepthFunc func rest) = do
	R.depthFunc gl func
	return rest
interpretWebGL gl (Enable cap rest) = do
	R.enable gl cap
	return rest
interpretWebGL gl (EnableVertexAttribArray (AttributeLocation location) rest) = do
	R.enableVertexAttribArray gl location
	return rest
interpretWebGL gl (GetAttribLocation program name k) = do
	location <- R.getAttribLocation gl program name
	if location == -1
		then return $ k Nothing
		else return $ k $ Just (AttributeLocation location)
interpretWebGL gl (GetCanvas k) = do
	el <- R.getCanvas gl
	return $ k el
interpretWebGL gl (GetDrawingBufferHeight k) = do
	h <- R.getDrawingBufferHeight gl
	return $ k h
interpretWebGL gl (GetDrawingBufferWidth k) = do
	w <- R.getDrawingBufferWidth gl
	return $ k w
interpretWebGL gl (GetProgramInfoLog p k) = do
	maybeLog <- R.getProgramInfoLog gl p
	return $ k maybeLog
interpretWebGL gl (GetProgramLinkStatus p k) = do
	Just b <- R.getProgramParameter gl p GL.linkStatus
	return $ k b
interpretWebGL gl (GetShaderCompileStatus s k) = do
	Just b <- R.getShaderParameter gl s GL.compileStatus
	return $ k b
interpretWebGL gl (GetShaderInfoLog s k) = do
	maybeLog <- R.getShaderInfoLog gl s
	return $ k maybeLog
interpretWebGL gl (GetUniformLocation program name k) = do
	location <- R.getUniformLocation gl program name
	return $ k location
interpretWebGL gl (LinkProgram p rest) = do
	R.linkProgram gl p
	return rest
interpretWebGL gl (ShaderSource sh src rest) = do
	R.shaderSource gl sh src
	return rest
interpretWebGL gl (UseProgram p rest) = do
	R.useProgram gl p
	return rest
interpretWebGL gl (Viewport x y w h rest) = do
	R.viewport gl x y w h
	return rest

runWebGL :: forall a eff. WebGLContext -> WebGL a -> Eff (canvas :: Canvas | eff) a
runWebGL = runFreeM <<< interpretWebGL

debugWebGL :: forall a eff. WebGLContext -> WebGL a -> Eff (canvas :: Canvas, console :: CONSOLE | eff) a
debugWebGL gl = runFreeM interpretDebug
	where
	interpretDebug :: forall a. WebGLF (WebGL a) -> Eff (canvas :: Canvas, console :: CONSOLE | eff) (WebGL a)
	interpretDebug comp = do
		rest <- interpretWebGL gl comp
		err <- R.getError gl
		if err == GL.noError
			then return rest
			else do
				error $ "WebGL Error: " ++ show err
				return rest

-- Free Monad for WebGL
module Graphics.WebGL.Free (
	AttributeLocation(..),
	WebGL(),
	WebGLF(),
	debugWebGL,
	runWebGL,
	attachShader,
	bindBuffer,
	bufferData,
	clear,
	createBuffer,
	clearColor,
	createProgram,
	compileShader,
	createShader,
	depthFunc,
	enable,
	enableVertexAttribArray,
	getAttribLocation,
	getCanvas,
	getDrawingBufferHeight,
	getDrawingBufferWidth,
	getProgramInfoLog,
	getProgramLinkStatus,
	getShaderCompileStatus,
	getShaderInfoLog,
	getUniformLocation,
	linkProgram,
	shaderSource,
	useProgram,
	viewport
	) where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.Free
import Data.Maybe
import Graphics.Canvas (Canvas(), CanvasElement())
import qualified Graphics.WebGL.Raw as R
import qualified Graphics.WebGL.Raw.Extra as R
import qualified Graphics.WebGL.Raw.Enums as GL
import Graphics.WebGL.Raw.Types

newtype AttributeLocation = AttributeLocation GLuint

data WebGLF a
	= AttachShader WebGLProgram WebGLShader a
	| BindBuffer GLenum WebGLBuffer a
	| BufferData GLenum BufferDataSource GLenum a
	| Clear GLbitfield a
	| ClearColor GLclampf GLclampf GLclampf GLclampf a
	| CompileShader WebGLShader a
	| CreateBuffer (Maybe WebGLBuffer -> a)
	| CreateProgram (Maybe WebGLProgram -> a)
	| CreateShader GLenum (Maybe WebGLShader -> a)
	| DepthFunc GLenum a
	| Enable GLenum a
	| EnableVertexAttribArray AttributeLocation a
	| GetAttribLocation WebGLProgram DOMString (Maybe AttributeLocation -> a)
	| GetCanvas (CanvasElement -> a)
	| GetDrawingBufferHeight (Int -> a)
	| GetDrawingBufferWidth (Int -> a)
	| GetProgramInfoLog WebGLProgram (Maybe DOMString -> a)
	| GetProgramLinkStatus WebGLProgram (Boolean -> a)
	| GetShaderCompileStatus WebGLShader (Boolean -> a)
	| GetShaderInfoLog WebGLShader (Maybe DOMString -> a)
	| GetUniformLocation WebGLProgram DOMString (Maybe WebGLUniformLocation -> a)
	| LinkProgram WebGLProgram a
	| ShaderSource WebGLShader DOMString a
	| UseProgram WebGLProgram a
	| Viewport GLint GLint GLsizei GLsizei a

instance functorWebGLF :: Functor WebGLF where
	map f (AttachShader p s x) = AttachShader p s (f x)
	map f (BindBuffer t b x) = BindBuffer t b (f x)
	map f (BufferData t s u x) = BufferData t s u (f x)
	map f (Clear mask x) = Clear mask (f x)
	map f (ClearColor r g b a x) = ClearColor r g b a (f x)
	map f (CompileShader s x) = CompileShader s (f x)
	map f (CreateBuffer k) = CreateBuffer (f <<< k)
	map f (CreateProgram k) = CreateProgram (f <<< k)
	map f (CreateShader t k) = CreateShader t (f <<< k)
	map f (DepthFunc func x) = DepthFunc func (f x)
	map f (Enable cap x) = Enable cap (f x)
	map f (EnableVertexAttribArray i x) = EnableVertexAttribArray i (f x)
	map f (GetAttribLocation p s k) = GetAttribLocation p s (f <<< k)
	map f (GetCanvas k) = GetCanvas (f <<< k)
	map f (GetDrawingBufferHeight k) = GetDrawingBufferHeight (f <<< k)
	map f (GetDrawingBufferWidth k) = GetDrawingBufferWidth (f <<< k)
	map f (GetProgramInfoLog s k) = GetProgramInfoLog s (f <<< k)
	map f (GetProgramLinkStatus p k) = GetProgramLinkStatus p (f <<< k)
	map f (GetShaderCompileStatus s k) = GetShaderCompileStatus s (f <<< k)
	map f (GetShaderInfoLog s k) = GetShaderInfoLog s (f <<< k)
	map f (GetUniformLocation p n k) = GetUniformLocation p n (f <<< k)
	map f (LinkProgram p x) = LinkProgram p (f x)
	map f (ShaderSource sh src x) = ShaderSource sh src (f x)
	map f (UseProgram p x) = UseProgram p (f x)
	map f (Viewport x y w h a) = Viewport x y w h (f a)

type WebGL = Free WebGLF

attachShader :: WebGLProgram -> WebGLShader -> WebGL Unit
attachShader p s = liftF $ AttachShader p s unit

bindBuffer :: GLenum -> WebGLBuffer -> WebGL Unit
bindBuffer t b = liftF $ BindBuffer t b unit

bufferData :: GLenum -> BufferDataSource -> GLenum -> WebGL Unit
bufferData t s u = liftF $ BufferData t s u unit

clear :: GLbitfield -> WebGL Unit
clear mask = liftF $ Clear mask unit

clearColor :: GLclampf -> GLclampf -> GLclampf -> GLclampf -> WebGL Unit
clearColor r g b a = liftF $ ClearColor r g b a unit

compileShader :: WebGLShader -> WebGL Unit
compileShader s = liftF $ CompileShader s unit

createBuffer :: WebGL (Maybe WebGLBuffer)
createBuffer = liftF $ CreateBuffer id

createProgram :: WebGL (Maybe WebGLProgram)
createProgram = liftF $ CreateProgram id

createShader :: GLenum -> WebGL (Maybe WebGLShader)
createShader t = liftF $ CreateShader t id

depthFunc :: GLenum -> WebGL Unit
depthFunc func = liftF $ DepthFunc func unit

enable :: GLenum -> WebGL Unit
enable cap = liftF $ Enable cap unit

enableVertexAttribArray :: AttributeLocation -> WebGL Unit
enableVertexAttribArray location = liftF $ EnableVertexAttribArray location unit

getAttribLocation :: WebGLProgram -> DOMString -> WebGL (Maybe AttributeLocation)
getAttribLocation program name = liftF $ GetAttribLocation program name id

getCanvas :: WebGL CanvasElement
getCanvas = liftF $ GetCanvas id

getDrawingBufferHeight :: WebGL Int
getDrawingBufferHeight = liftF $ GetDrawingBufferHeight id

getDrawingBufferWidth :: WebGL Int
getDrawingBufferWidth = liftF $ GetDrawingBufferWidth id

getProgramInfoLog :: WebGLProgram -> WebGL (Maybe DOMString)
getProgramInfoLog p = liftF $ GetProgramInfoLog p id

getProgramLinkStatus :: WebGLProgram -> WebGL Boolean
getProgramLinkStatus p = liftF $ GetProgramLinkStatus p id

getShaderCompileStatus :: WebGLShader -> WebGL Boolean
getShaderCompileStatus s = liftF $ GetShaderCompileStatus s id

getShaderInfoLog :: WebGLShader -> WebGL (Maybe DOMString)
getShaderInfoLog s = liftF $ GetShaderInfoLog s id

getUniformLocation :: WebGLProgram -> DOMString -> WebGL (Maybe WebGLUniformLocation)
getUniformLocation program name = liftF $ GetUniformLocation program name id

linkProgram :: WebGLProgram -> WebGL Unit
linkProgram p = liftF $ LinkProgram p unit

shaderSource :: WebGLShader -> DOMString -> WebGL Unit
shaderSource sh src = liftF $ ShaderSource sh src unit

useProgram :: WebGLProgram -> WebGL Unit
useProgram p = liftF $ UseProgram p unit

viewport :: GLint -> GLint -> GLsizei -> GLsizei -> WebGL Unit
viewport x y w h = liftF $ Viewport x y w h unit

interpretWebGL :: forall a eff. WebGLContext -> WebGLF (WebGL a) -> Eff (canvas :: Canvas | eff) (WebGL a)
interpretWebGL gl (AttachShader p s rest) = do
	R.attachShader gl p s
	return rest
interpretWebGL gl (BindBuffer t buffer rest) = do
	R.bindBuffer gl t buffer
	return rest
interpretWebGL gl (BufferData t source usage rest) = do
	R.bufferData gl t source usage
	return rest
interpretWebGL gl (Clear mask rest) = do
	R.clear gl mask
	return rest
interpretWebGL gl (ClearColor r g b a rest) = do
	R.clearColor gl r g b a
	return rest
interpretWebGL gl (CompileShader sh rest) = do
	R.compileShader gl sh
	return rest
interpretWebGL gl (CreateBuffer k) = do
	buffer <- R.createBuffer gl
	return $ k buffer
interpretWebGL gl (CreateProgram k) = do
	program <- R.createProgram gl
	return $ k program
interpretWebGL gl (CreateShader t k) = do
	shader <- R.createShader gl t
	return $ k shader
interpretWebGL gl (DepthFunc func rest) = do
	R.depthFunc gl func
	return rest
interpretWebGL gl (Enable cap rest) = do
	R.enable gl cap
	return rest
interpretWebGL gl (EnableVertexAttribArray (AttributeLocation location) rest) = do
	R.enableVertexAttribArray gl location
	return rest
interpretWebGL gl (GetAttribLocation program name k) = do
	location <- R.getAttribLocation gl program name
	if location == -1
		then return $ k Nothing
		else return $ k $ Just (AttributeLocation location)
interpretWebGL gl (GetCanvas k) = do
	el <- R.getCanvas gl
	return $ k el
interpretWebGL gl (GetDrawingBufferHeight k) = do
	h <- R.getDrawingBufferHeight gl
	return $ k h
interpretWebGL gl (GetDrawingBufferWidth k) = do
	w <- R.getDrawingBufferWidth gl
	return $ k w
interpretWebGL gl (GetProgramInfoLog p k) = do
	maybeLog <- R.getProgramInfoLog gl p
	return $ k maybeLog
interpretWebGL gl (GetProgramLinkStatus p k) = do
	Just b <- R.getProgramParameter gl p GL.linkStatus
	return $ k b
interpretWebGL gl (GetShaderCompileStatus s k) = do
	Just b <- R.getShaderParameter gl s GL.compileStatus
	return $ k b
interpretWebGL gl (GetShaderInfoLog s k) = do
	maybeLog <- R.getShaderInfoLog gl s
	return $ k maybeLog
interpretWebGL gl (GetUniformLocation program name k) = do
	location <- R.getUniformLocation gl program name
	return $ k location
interpretWebGL gl (LinkProgram p rest) = do
	R.linkProgram gl p
	return rest
interpretWebGL gl (ShaderSource sh src rest) = do
	R.shaderSource gl sh src
	return rest
interpretWebGL gl (UseProgram p rest) = do
	R.useProgram gl p
	return rest
interpretWebGL gl (Viewport x y w h rest) = do
	R.viewport gl x y w h
	return rest

runWebGL :: forall a eff. WebGLContext -> WebGL a -> Eff (canvas :: Canvas | eff) a
runWebGL = runFreeM <<< interpretWebGL

debugWebGL :: forall a eff. WebGLContext -> WebGL a -> Eff (canvas :: Canvas, console :: CONSOLE | eff) a
debugWebGL gl = runFreeM interpretDebug
	where
	interpretDebug :: forall a. WebGLF (WebGL a) -> Eff (canvas :: Canvas, console :: CONSOLE | eff) (WebGL a)
	interpretDebug comp = do
		rest <- interpretWebGL gl comp
		err <- R.getError gl
		if err == 0
			then return rest
			else do
				error $ "WebGL Error: " ++ show err
				return rest


export new functions

export new functions

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,
    showSample,
    showSample'
  ) 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 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